1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Eval_Fat; use Eval_Fat;
32 with Exp_Ch11; use Exp_Ch11;
33 with Exp_Ch2; use Exp_Ch2;
34 with Exp_Ch4; use Exp_Ch4;
35 with Exp_Pakd; use Exp_Pakd;
36 with Exp_Util; use Exp_Util;
37 with Expander; use Expander;
38 with Freeze; use Freeze;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Eval; use Sem_Eval;
52 with Sem_Res; use Sem_Res;
53 with Sem_Util; use Sem_Util;
54 with Sem_Warn; use Sem_Warn;
55 with Sinfo; use Sinfo;
56 with Sinput; use Sinput;
57 with Snames; use Snames;
58 with Sprint; use Sprint;
59 with Stand; use Stand;
60 with Stringt; use Stringt;
61 with Targparm; use Targparm;
62 with Tbuild; use Tbuild;
63 with Ttypes; use Ttypes;
64 with Validsw; use Validsw;
66 package body Checks is
68 -- General note: many of these routines are concerned with generating
69 -- checking code to make sure that constraint error is raised at runtime.
70 -- Clearly this code is only needed if the expander is active, since
71 -- otherwise we will not be generating code or going into the runtime
74 -- We therefore disconnect most of these checks if the expander is
75 -- inactive. This has the additional benefit that we do not need to
76 -- worry about the tree being messed up by previous errors (since errors
77 -- turn off expansion anyway).
79 -- There are a few exceptions to the above rule. For instance routines
80 -- such as Apply_Scalar_Range_Check that do not insert any code can be
81 -- safely called even when the Expander is inactive (but Errors_Detected
82 -- is 0). The benefit of executing this code when expansion is off, is
83 -- the ability to emit constraint error warning for static expressions
84 -- even when we are not generating code.
86 -- The above is modified in gnatprove mode to ensure that proper check
87 -- flags are always placed, even if expansion is off.
89 -------------------------------------
90 -- Suppression of Redundant Checks --
91 -------------------------------------
93 -- This unit implements a limited circuit for removal of redundant
94 -- checks. The processing is based on a tracing of simple sequential
95 -- flow. For any sequence of statements, we save expressions that are
96 -- marked to be checked, and then if the same expression appears later
97 -- with the same check, then under certain circumstances, the second
98 -- check can be suppressed.
100 -- Basically, we can suppress the check if we know for certain that
101 -- the previous expression has been elaborated (together with its
102 -- check), and we know that the exception frame is the same, and that
103 -- nothing has happened to change the result of the exception.
105 -- Let us examine each of these three conditions in turn to describe
106 -- how we ensure that this condition is met.
108 -- First, we need to know for certain that the previous expression has
109 -- been executed. This is done principally by the mechanism of calling
110 -- Conditional_Statements_Begin at the start of any statement sequence
111 -- and Conditional_Statements_End at the end. The End call causes all
112 -- checks remembered since the Begin call to be discarded. This does
113 -- miss a few cases, notably the case of a nested BEGIN-END block with
114 -- no exception handlers. But the important thing is to be conservative.
115 -- The other protection is that all checks are discarded if a label
116 -- is encountered, since then the assumption of sequential execution
117 -- is violated, and we don't know enough about the flow.
119 -- Second, we need to know that the exception frame is the same. We
120 -- do this by killing all remembered checks when we enter a new frame.
121 -- Again, that's over-conservative, but generally the cases we can help
122 -- with are pretty local anyway (like the body of a loop for example).
124 -- Third, we must be sure to forget any checks which are no longer valid.
125 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
126 -- used to note any changes to local variables. We only attempt to deal
127 -- with checks involving local variables, so we do not need to worry
128 -- about global variables. Second, a call to any non-global procedure
129 -- causes us to abandon all stored checks, since such a all may affect
130 -- the values of any local variables.
132 -- The following define the data structures used to deal with remembering
133 -- checks so that redundant checks can be eliminated as described above.
135 -- Right now, the only expressions that we deal with are of the form of
136 -- simple local objects (either declared locally, or IN parameters) or
137 -- such objects plus/minus a compile time known constant. We can do
138 -- more later on if it seems worthwhile, but this catches many simple
139 -- cases in practice.
141 -- The following record type reflects a single saved check. An entry
142 -- is made in the stack of saved checks if and only if the expression
143 -- has been elaborated with the indicated checks.
145 type Saved_Check is record
147 -- Set True if entry is killed by Kill_Checks
150 -- The entity involved in the expression that is checked
153 -- A compile time value indicating the result of adding or
154 -- subtracting a compile time value. This value is to be
155 -- added to the value of the Entity. A value of zero is
156 -- used for the case of a simple entity reference.
158 Check_Type : Character;
159 -- This is set to 'R' for a range check (in which case Target_Type
160 -- is set to the target type for the range check) or to 'O' for an
161 -- overflow check (in which case Target_Type is set to Empty).
163 Target_Type : Entity_Id;
164 -- Used only if Do_Range_Check is set. Records the target type for
165 -- the check. We need this, because a check is a duplicate only if
166 -- it has the same target type (or more accurately one with a
167 -- range that is smaller or equal to the stored target type of a
171 -- The following table keeps track of saved checks. Rather than use an
172 -- extensible table. We just use a table of fixed size, and we discard
173 -- any saved checks that do not fit. That's very unlikely to happen and
174 -- this is only an optimization in any case.
176 Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
177 -- Array of saved checks
179 Num_Saved_Checks : Nat := 0;
180 -- Number of saved checks
182 -- The following stack keeps track of statement ranges. It is treated
183 -- as a stack. When Conditional_Statements_Begin is called, an entry
184 -- is pushed onto this stack containing the value of Num_Saved_Checks
185 -- at the time of the call. Then when Conditional_Statements_End is
186 -- called, this value is popped off and used to reset Num_Saved_Checks.
188 -- Note: again, this is a fixed length stack with a size that should
189 -- always be fine. If the value of the stack pointer goes above the
190 -- limit, then we just forget all saved checks.
192 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
193 Saved_Checks_TOS : Nat := 0;
195 -----------------------
196 -- Local Subprograms --
197 -----------------------
199 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id);
200 -- Used to apply arithmetic overflow checks for all cases except operators
201 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
202 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
203 -- signed integer arithmetic operator (but not an if or case expression).
204 -- It is also called for types other than signed integers.
206 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id);
207 -- Used to apply arithmetic overflow checks for the case where the overflow
208 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
209 -- arithmetic op (which includes the case of if and case expressions). Note
210 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
211 -- we have work to do even if overflow checking is suppressed.
213 procedure Apply_Division_Check
218 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
219 -- division checks as required if the Do_Division_Check flag is set.
220 -- Rlo and Rhi give the possible range of the right operand, these values
221 -- can be referenced and trusted only if ROK is set True.
223 procedure Apply_Float_Conversion_Check
225 Target_Typ : Entity_Id);
226 -- The checks on a conversion from a floating-point type to an integer
227 -- type are delicate. They have to be performed before conversion, they
228 -- have to raise an exception when the operand is a NaN, and rounding must
229 -- be taken into account to determine the safe bounds of the operand.
231 procedure Apply_Selected_Length_Checks
233 Target_Typ : Entity_Id;
234 Source_Typ : Entity_Id;
235 Do_Static : Boolean);
236 -- This is the subprogram that does all the work for Apply_Length_Check
237 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
238 -- described for the above routines. The Do_Static flag indicates that
239 -- only a static check is to be done.
241 procedure Apply_Selected_Range_Checks
243 Target_Typ : Entity_Id;
244 Source_Typ : Entity_Id;
245 Do_Static : Boolean);
246 -- This is the subprogram that does all the work for Apply_Range_Check.
247 -- Expr, Target_Typ and Source_Typ are as described for the above
248 -- routine. The Do_Static flag indicates that only a static check is
251 type Check_Type is new Check_Id range Access_Check .. Division_Check;
252 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
253 -- This function is used to see if an access or division by zero check is
254 -- needed. The check is to be applied to a single variable appearing in the
255 -- source, and N is the node for the reference. If N is not of this form,
256 -- True is returned with no further processing. If N is of the right form,
257 -- then further processing determines if the given Check is needed.
259 -- The particular circuit is to see if we have the case of a check that is
260 -- not needed because it appears in the right operand of a short circuited
261 -- conditional where the left operand guards the check. For example:
263 -- if Var = 0 or else Q / Var > 12 then
267 -- In this example, the division check is not required. At the same time
268 -- we can issue warnings for suspicious use of non-short-circuited forms,
271 -- if Var = 0 or Q / Var > 12 then
277 Check_Type : Character;
278 Target_Type : Entity_Id;
279 Entry_OK : out Boolean;
283 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
284 -- to see if a check is of the form for optimization, and if so, to see
285 -- if it has already been performed. Expr is the expression to check,
286 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
287 -- Target_Type is the target type for a range check, and Empty for an
288 -- overflow check. If the entry is not of the form for optimization,
289 -- then Entry_OK is set to False, and the remaining out parameters
290 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
291 -- entity and offset from the expression. Check_Num is the number of
292 -- a matching saved entry in Saved_Checks, or zero if no such entry
295 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
296 -- If a discriminal is used in constraining a prival, Return reference
297 -- to the discriminal of the protected body (which renames the parameter
298 -- of the enclosing protected operation). This clumsy transformation is
299 -- needed because privals are created too late and their actual subtypes
300 -- are not available when analysing the bodies of the protected operations.
301 -- This function is called whenever the bound is an entity and the scope
302 -- indicates a protected operation. If the bound is an in-parameter of
303 -- a protected operation that is not a prival, the function returns the
305 -- To be cleaned up???
307 function Guard_Access
310 Ck_Node : Node_Id) return Node_Id;
311 -- In the access type case, guard the test with a test to ensure
312 -- that the access value is non-null, since the checks do not
313 -- not apply to null access values.
315 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
316 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
317 -- Constraint_Error node.
319 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean;
320 -- Returns True if node N is for an arithmetic operation with signed
321 -- integer operands. This includes unary and binary operators, and also
322 -- if and case expression nodes where the dependent expressions are of
323 -- a signed integer type. These are the kinds of nodes for which special
324 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
326 function Range_Or_Validity_Checks_Suppressed
327 (Expr : Node_Id) return Boolean;
328 -- Returns True if either range or validity checks or both are suppressed
329 -- for the type of the given expression, or, if the expression is the name
330 -- of an entity, if these checks are suppressed for the entity.
332 function Selected_Length_Checks
334 Target_Typ : Entity_Id;
335 Source_Typ : Entity_Id;
336 Warn_Node : Node_Id) return Check_Result;
337 -- Like Apply_Selected_Length_Checks, except it doesn't modify
338 -- anything, just returns a list of nodes as described in the spec of
339 -- this package for the Range_Check function.
341 function Selected_Range_Checks
343 Target_Typ : Entity_Id;
344 Source_Typ : Entity_Id;
345 Warn_Node : Node_Id) return Check_Result;
346 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
347 -- just returns a list of nodes as described in the spec of this package
348 -- for the Range_Check function.
350 ------------------------------
351 -- Access_Checks_Suppressed --
352 ------------------------------
354 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
356 if Present (E) and then Checks_May_Be_Suppressed (E) then
357 return Is_Check_Suppressed (E, Access_Check);
359 return Scope_Suppress.Suppress (Access_Check);
361 end Access_Checks_Suppressed;
363 -------------------------------------
364 -- Accessibility_Checks_Suppressed --
365 -------------------------------------
367 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
369 if Present (E) and then Checks_May_Be_Suppressed (E) then
370 return Is_Check_Suppressed (E, Accessibility_Check);
372 return Scope_Suppress.Suppress (Accessibility_Check);
374 end Accessibility_Checks_Suppressed;
376 -----------------------------
377 -- Activate_Division_Check --
378 -----------------------------
380 procedure Activate_Division_Check (N : Node_Id) is
382 Set_Do_Division_Check (N, True);
383 Possible_Local_Raise (N, Standard_Constraint_Error);
384 end Activate_Division_Check;
386 -----------------------------
387 -- Activate_Overflow_Check --
388 -----------------------------
390 procedure Activate_Overflow_Check (N : Node_Id) is
391 Typ : constant Entity_Id := Etype (N);
394 -- Floating-point case. If Etype is not set (this can happen when we
395 -- activate a check on a node that has not yet been analyzed), then
396 -- we assume we do not have a floating-point type (as per our spec).
398 if Present (Typ) and then Is_Floating_Point_Type (Typ) then
400 -- Ignore call if we have no automatic overflow checks on the target
401 -- and Check_Float_Overflow mode is not set. These are the cases in
402 -- which we expect to generate infinities and NaN's with no check.
404 if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
407 -- Ignore for unary operations ("+", "-", abs) since these can never
408 -- result in overflow for floating-point cases.
410 elsif Nkind (N) in N_Unary_Op then
413 -- Otherwise we will set the flag
422 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
423 -- for zero-divide is a divide check, not an overflow check).
425 if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
430 -- Fall through for cases where we do set the flag
432 Set_Do_Overflow_Check (N, True);
433 Possible_Local_Raise (N, Standard_Constraint_Error);
434 end Activate_Overflow_Check;
436 --------------------------
437 -- Activate_Range_Check --
438 --------------------------
440 procedure Activate_Range_Check (N : Node_Id) is
442 Set_Do_Range_Check (N, True);
443 Possible_Local_Raise (N, Standard_Constraint_Error);
444 end Activate_Range_Check;
446 ---------------------------------
447 -- Alignment_Checks_Suppressed --
448 ---------------------------------
450 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
452 if Present (E) and then Checks_May_Be_Suppressed (E) then
453 return Is_Check_Suppressed (E, Alignment_Check);
455 return Scope_Suppress.Suppress (Alignment_Check);
457 end Alignment_Checks_Suppressed;
459 ----------------------------------
460 -- Allocation_Checks_Suppressed --
461 ----------------------------------
463 -- Note: at the current time there are no calls to this function, because
464 -- the relevant check is in the run-time, so it is not a check that the
465 -- compiler can suppress anyway, but we still have to recognize the check
466 -- name Allocation_Check since it is part of the standard.
468 function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
470 if Present (E) and then Checks_May_Be_Suppressed (E) then
471 return Is_Check_Suppressed (E, Allocation_Check);
473 return Scope_Suppress.Suppress (Allocation_Check);
475 end Allocation_Checks_Suppressed;
477 -------------------------
478 -- Append_Range_Checks --
479 -------------------------
481 procedure Append_Range_Checks
482 (Checks : Check_Result;
484 Suppress_Typ : Entity_Id;
485 Static_Sloc : Source_Ptr;
488 Internal_Flag_Node : constant Node_Id := Flag_Node;
489 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
491 Checks_On : constant Boolean :=
492 (not Index_Checks_Suppressed (Suppress_Typ))
493 or else (not Range_Checks_Suppressed (Suppress_Typ));
496 -- For now we just return if Checks_On is false, however this should
497 -- be enhanced to check for an always True value in the condition
498 -- and to generate a compilation warning???
500 if not Checks_On then
505 exit when No (Checks (J));
507 if Nkind (Checks (J)) = N_Raise_Constraint_Error
508 and then Present (Condition (Checks (J)))
510 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
511 Append_To (Stmts, Checks (J));
512 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
518 Make_Raise_Constraint_Error (Internal_Static_Sloc,
519 Reason => CE_Range_Check_Failed));
522 end Append_Range_Checks;
524 ------------------------
525 -- Apply_Access_Check --
526 ------------------------
528 procedure Apply_Access_Check (N : Node_Id) is
529 P : constant Node_Id := Prefix (N);
532 -- We do not need checks if we are not generating code (i.e. the
533 -- expander is not active). This is not just an optimization, there
534 -- are cases (e.g. with pragma Debug) where generating the checks
535 -- can cause real trouble).
537 if not Expander_Active then
541 -- No check if short circuiting makes check unnecessary
543 if not Check_Needed (P, Access_Check) then
547 -- No check if accessing the Offset_To_Top component of a dispatch
548 -- table. They are safe by construction.
550 if Tagged_Type_Expansion
551 and then Present (Etype (P))
552 and then RTU_Loaded (Ada_Tags)
553 and then RTE_Available (RE_Offset_To_Top_Ptr)
554 and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
559 -- Otherwise go ahead and install the check
561 Install_Null_Excluding_Check (P);
562 end Apply_Access_Check;
564 -------------------------------
565 -- Apply_Accessibility_Check --
566 -------------------------------
568 procedure Apply_Accessibility_Check
571 Insert_Node : Node_Id)
573 Loc : constant Source_Ptr := Sloc (N);
574 Param_Ent : Entity_Id := Param_Entity (N);
575 Param_Level : Node_Id;
576 Type_Level : Node_Id;
579 if Ada_Version >= Ada_2012
580 and then not Present (Param_Ent)
581 and then Is_Entity_Name (N)
582 and then Ekind_In (Entity (N), E_Constant, E_Variable)
583 and then Present (Effective_Extra_Accessibility (Entity (N)))
585 Param_Ent := Entity (N);
586 while Present (Renamed_Object (Param_Ent)) loop
588 -- Renamed_Object must return an Entity_Name here
589 -- because of preceding "Present (E_E_A (...))" test.
591 Param_Ent := Entity (Renamed_Object (Param_Ent));
595 if Inside_A_Generic then
598 -- Only apply the run-time check if the access parameter has an
599 -- associated extra access level parameter and when the level of the
600 -- type is less deep than the level of the access parameter, and
601 -- accessibility checks are not suppressed.
603 elsif Present (Param_Ent)
604 and then Present (Extra_Accessibility (Param_Ent))
605 and then UI_Gt (Object_Access_Level (N),
606 Deepest_Type_Access_Level (Typ))
607 and then not Accessibility_Checks_Suppressed (Param_Ent)
608 and then not Accessibility_Checks_Suppressed (Typ)
611 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
614 Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
616 -- Raise Program_Error if the accessibility level of the access
617 -- parameter is deeper than the level of the target access type.
619 Insert_Action (Insert_Node,
620 Make_Raise_Program_Error (Loc,
623 Left_Opnd => Param_Level,
624 Right_Opnd => Type_Level),
625 Reason => PE_Accessibility_Check_Failed));
627 Analyze_And_Resolve (N);
629 end Apply_Accessibility_Check;
631 --------------------------------
632 -- Apply_Address_Clause_Check --
633 --------------------------------
635 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
636 pragma Assert (Nkind (N) = N_Freeze_Entity);
638 AC : constant Node_Id := Address_Clause (E);
639 Loc : constant Source_Ptr := Sloc (AC);
640 Typ : constant Entity_Id := Etype (E);
641 Aexp : constant Node_Id := Expression (AC);
644 -- Address expression (not necessarily the same as Aexp, for example
645 -- when Aexp is a reference to a constant, in which case Expr gets
646 -- reset to reference the value expression of the constant).
648 procedure Compile_Time_Bad_Alignment;
649 -- Post error warnings when alignment is known to be incompatible. Note
650 -- that we do not go as far as inserting a raise of Program_Error since
651 -- this is an erroneous case, and it may happen that we are lucky and an
652 -- underaligned address turns out to be OK after all.
654 --------------------------------
655 -- Compile_Time_Bad_Alignment --
656 --------------------------------
658 procedure Compile_Time_Bad_Alignment is
660 if Address_Clause_Overlay_Warnings then
662 ("?o?specified address for& may be inconsistent with alignment",
665 ("\?o?program execution may be erroneous (RM 13.3(27))",
667 Set_Address_Warning_Posted (AC);
669 end Compile_Time_Bad_Alignment;
671 -- Start of processing for Apply_Address_Clause_Check
674 -- See if alignment check needed. Note that we never need a check if the
675 -- maximum alignment is one, since the check will always succeed.
677 -- Note: we do not check for checks suppressed here, since that check
678 -- was done in Sem_Ch13 when the address clause was processed. We are
679 -- only called if checks were not suppressed. The reason for this is
680 -- that we have to delay the call to Apply_Alignment_Check till freeze
681 -- time (so that all types etc are elaborated), but we have to check
682 -- the status of check suppressing at the point of the address clause.
685 or else not Check_Address_Alignment (AC)
686 or else Maximum_Alignment = 1
691 -- Obtain expression from address clause
693 Expr := Expression (AC);
695 -- The following loop digs for the real expression to use in the check
698 -- For constant, get constant expression
700 if Is_Entity_Name (Expr)
701 and then Ekind (Entity (Expr)) = E_Constant
703 Expr := Constant_Value (Entity (Expr));
705 -- For unchecked conversion, get result to convert
707 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
708 Expr := Expression (Expr);
710 -- For (common case) of To_Address call, get argument
712 elsif Nkind (Expr) = N_Function_Call
713 and then Is_Entity_Name (Name (Expr))
714 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
716 Expr := First (Parameter_Associations (Expr));
718 if Nkind (Expr) = N_Parameter_Association then
719 Expr := Explicit_Actual_Parameter (Expr);
722 -- We finally have the real expression
729 -- See if we know that Expr has a bad alignment at compile time
731 if Compile_Time_Known_Value (Expr)
732 and then (Known_Alignment (E) or else Known_Alignment (Typ))
735 AL : Uint := Alignment (Typ);
738 -- The object alignment might be more restrictive than the
741 if Known_Alignment (E) then
745 if Expr_Value (Expr) mod AL /= 0 then
746 Compile_Time_Bad_Alignment;
752 -- If the expression has the form X'Address, then we can find out if
753 -- the object X has an alignment that is compatible with the object E.
754 -- If it hasn't or we don't know, we defer issuing the warning until
755 -- the end of the compilation to take into account back end annotations.
757 elsif Nkind (Expr) = N_Attribute_Reference
758 and then Attribute_Name (Expr) = Name_Address
759 and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible
764 -- Here we do not know if the value is acceptable. Strictly we don't
765 -- have to do anything, since if the alignment is bad, we have an
766 -- erroneous program. However we are allowed to check for erroneous
767 -- conditions and we decide to do this by default if the check is not
770 -- However, don't do the check if elaboration code is unwanted
772 if Restriction_Active (No_Elaboration_Code) then
775 -- Generate a check to raise PE if alignment may be inappropriate
778 -- If the original expression is a non-static constant, use the
779 -- name of the constant itself rather than duplicating its
780 -- defining expression, which was extracted above.
782 -- Note: Expr is empty if the address-clause is applied to in-mode
783 -- actuals (allowed by 13.1(22)).
785 if not Present (Expr)
787 (Is_Entity_Name (Expression (AC))
788 and then Ekind (Entity (Expression (AC))) = E_Constant
789 and then Nkind (Parent (Entity (Expression (AC))))
790 = N_Object_Declaration)
792 Expr := New_Copy_Tree (Expression (AC));
794 Remove_Side_Effects (Expr);
797 if No (Actions (N)) then
798 Set_Actions (N, New_List);
801 Prepend_To (Actions (N),
802 Make_Raise_Program_Error (Loc,
809 (RTE (RE_Integer_Address), Expr),
811 Make_Attribute_Reference (Loc,
812 Prefix => New_Occurrence_Of (E, Loc),
813 Attribute_Name => Name_Alignment)),
814 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
815 Reason => PE_Misaligned_Address_Value));
817 Warning_Msg := No_Error_Msg;
818 Analyze (First (Actions (N)), Suppress => All_Checks);
820 -- If the address clause generated a warning message (for example,
821 -- from Warn_On_Non_Local_Exception mode with the active restriction
822 -- No_Exception_Propagation).
824 if Warning_Msg /= No_Error_Msg then
826 -- If the expression has a known at compile time value, then
827 -- once we know the alignment of the type, we can check if the
828 -- exception will be raised or not, and if not, we don't need
829 -- the warning so we will kill the warning later on.
831 if Compile_Time_Known_Value (Expr) then
832 Alignment_Warnings.Append
833 ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
836 -- Add explanation of the warning that is generated by the check
839 ("\address value may be incompatible with alignment "
840 & "of object?X?", AC);
847 -- If we have some missing run time component in configurable run time
848 -- mode then just skip the check (it is not required in any case).
850 when RE_Not_Available =>
852 end Apply_Address_Clause_Check;
854 -------------------------------------
855 -- Apply_Arithmetic_Overflow_Check --
856 -------------------------------------
858 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
860 -- Use old routine in almost all cases (the only case we are treating
861 -- specially is the case of a signed integer arithmetic op with the
862 -- overflow checking mode set to MINIMIZED or ELIMINATED).
864 if Overflow_Check_Mode = Strict
865 or else not Is_Signed_Integer_Arithmetic_Op (N)
867 Apply_Arithmetic_Overflow_Strict (N);
869 -- Otherwise use the new routine for the case of a signed integer
870 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
871 -- mode is MINIMIZED or ELIMINATED.
874 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
876 end Apply_Arithmetic_Overflow_Check;
878 --------------------------------------
879 -- Apply_Arithmetic_Overflow_Strict --
880 --------------------------------------
882 -- This routine is called only if the type is an integer type, and a
883 -- software arithmetic overflow check may be needed for op (add, subtract,
884 -- or multiply). This check is performed only if Software_Overflow_Checking
885 -- is enabled and Do_Overflow_Check is set. In this case we expand the
886 -- operation into a more complex sequence of tests that ensures that
887 -- overflow is properly caught.
889 -- This is used in CHECKED modes. It is identical to the code for this
890 -- cases before the big overflow earthquake, thus ensuring that in this
891 -- modes we have compatible behavior (and reliability) to what was there
892 -- before. It is also called for types other than signed integers, and if
893 -- the Do_Overflow_Check flag is off.
895 -- Note: we also call this routine if we decide in the MINIMIZED case
896 -- to give up and just generate an overflow check without any fuss.
898 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
899 Loc : constant Source_Ptr := Sloc (N);
900 Typ : constant Entity_Id := Etype (N);
901 Rtyp : constant Entity_Id := Root_Type (Typ);
904 -- Nothing to do if Do_Overflow_Check not set or overflow checks
907 if not Do_Overflow_Check (N) then
911 -- An interesting special case. If the arithmetic operation appears as
912 -- the operand of a type conversion:
916 -- and all the following conditions apply:
918 -- arithmetic operation is for a signed integer type
919 -- target type type1 is a static integer subtype
920 -- range of x and y are both included in the range of type1
921 -- range of x op y is included in the range of type1
922 -- size of type1 is at least twice the result size of op
924 -- then we don't do an overflow check in any case, instead we transform
925 -- the operation so that we end up with:
927 -- type1 (type1 (x) op type1 (y))
929 -- This avoids intermediate overflow before the conversion. It is
930 -- explicitly permitted by RM 3.5.4(24):
932 -- For the execution of a predefined operation of a signed integer
933 -- type, the implementation need not raise Constraint_Error if the
934 -- result is outside the base range of the type, so long as the
935 -- correct result is produced.
937 -- It's hard to imagine that any programmer counts on the exception
938 -- being raised in this case, and in any case it's wrong coding to
939 -- have this expectation, given the RM permission. Furthermore, other
940 -- Ada compilers do allow such out of range results.
942 -- Note that we do this transformation even if overflow checking is
943 -- off, since this is precisely about giving the "right" result and
944 -- avoiding the need for an overflow check.
946 -- Note: this circuit is partially redundant with respect to the similar
947 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
948 -- with cases that do not come through here. We still need the following
949 -- processing even with the Exp_Ch4 code in place, since we want to be
950 -- sure not to generate the arithmetic overflow check in these cases
951 -- (Exp_Ch4 would have a hard time removing them once generated).
953 if Is_Signed_Integer_Type (Typ)
954 and then Nkind (Parent (N)) = N_Type_Conversion
956 Conversion_Optimization : declare
957 Target_Type : constant Entity_Id :=
958 Base_Type (Entity (Subtype_Mark (Parent (N))));
972 if Is_Integer_Type (Target_Type)
973 and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
975 Tlo := Expr_Value (Type_Low_Bound (Target_Type));
976 Thi := Expr_Value (Type_High_Bound (Target_Type));
979 (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
981 (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
984 and then Tlo <= Llo and then Lhi <= Thi
985 and then Tlo <= Rlo and then Rhi <= Thi
987 Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
989 if VOK and then Tlo <= Vlo and then Vhi <= Thi then
990 Rewrite (Left_Opnd (N),
991 Make_Type_Conversion (Loc,
992 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
993 Expression => Relocate_Node (Left_Opnd (N))));
995 Rewrite (Right_Opnd (N),
996 Make_Type_Conversion (Loc,
997 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
998 Expression => Relocate_Node (Right_Opnd (N))));
1000 -- Rewrite the conversion operand so that the original
1001 -- node is retained, in order to avoid the warning for
1002 -- redundant conversions in Resolve_Type_Conversion.
1004 Rewrite (N, Relocate_Node (N));
1006 Set_Etype (N, Target_Type);
1008 Analyze_And_Resolve (Left_Opnd (N), Target_Type);
1009 Analyze_And_Resolve (Right_Opnd (N), Target_Type);
1011 -- Given that the target type is twice the size of the
1012 -- source type, overflow is now impossible, so we can
1013 -- safely kill the overflow check and return.
1015 Set_Do_Overflow_Check (N, False);
1020 end Conversion_Optimization;
1023 -- Now see if an overflow check is required
1026 Siz : constant Int := UI_To_Int (Esize (Rtyp));
1027 Dsiz : constant Int := Siz * 2;
1034 -- Skip check if back end does overflow checks, or the overflow flag
1035 -- is not set anyway, or we are not doing code expansion, or the
1036 -- parent node is a type conversion whose operand is an arithmetic
1037 -- operation on signed integers on which the expander can promote
1038 -- later the operands to type Integer (see Expand_N_Type_Conversion).
1040 -- Special case CLI target, where arithmetic overflow checks can be
1041 -- performed for integer and long_integer
1043 if Backend_Overflow_Checks_On_Target
1044 or else not Do_Overflow_Check (N)
1045 or else not Expander_Active
1046 or else (Present (Parent (N))
1047 and then Nkind (Parent (N)) = N_Type_Conversion
1048 and then Integer_Promotion_Possible (Parent (N)))
1050 (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
1055 -- Otherwise, generate the full general code for front end overflow
1056 -- detection, which works by doing arithmetic in a larger type:
1062 -- Typ (Checktyp (x) op Checktyp (y));
1064 -- where Typ is the type of the original expression, and Checktyp is
1065 -- an integer type of sufficient length to hold the largest possible
1068 -- If the size of check type exceeds the size of Long_Long_Integer,
1069 -- we use a different approach, expanding to:
1071 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1073 -- where xxx is Add, Multiply or Subtract as appropriate
1075 -- Find check type if one exists
1077 if Dsiz <= Standard_Integer_Size then
1078 Ctyp := Standard_Integer;
1080 elsif Dsiz <= Standard_Long_Long_Integer_Size then
1081 Ctyp := Standard_Long_Long_Integer;
1083 -- No check type exists, use runtime call
1086 if Nkind (N) = N_Op_Add then
1087 Cent := RE_Add_With_Ovflo_Check;
1089 elsif Nkind (N) = N_Op_Multiply then
1090 Cent := RE_Multiply_With_Ovflo_Check;
1093 pragma Assert (Nkind (N) = N_Op_Subtract);
1094 Cent := RE_Subtract_With_Ovflo_Check;
1099 Make_Function_Call (Loc,
1100 Name => New_Occurrence_Of (RTE (Cent), Loc),
1101 Parameter_Associations => New_List (
1102 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
1103 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
1105 Analyze_And_Resolve (N, Typ);
1109 -- If we fall through, we have the case where we do the arithmetic
1110 -- in the next higher type and get the check by conversion. In these
1111 -- cases Ctyp is set to the type to be used as the check type.
1113 Opnod := Relocate_Node (N);
1115 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
1118 Set_Etype (Opnd, Ctyp);
1119 Set_Analyzed (Opnd, True);
1120 Set_Left_Opnd (Opnod, Opnd);
1122 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
1125 Set_Etype (Opnd, Ctyp);
1126 Set_Analyzed (Opnd, True);
1127 Set_Right_Opnd (Opnod, Opnd);
1129 -- The type of the operation changes to the base type of the check
1130 -- type, and we reset the overflow check indication, since clearly no
1131 -- overflow is possible now that we are using a double length type.
1132 -- We also set the Analyzed flag to avoid a recursive attempt to
1135 Set_Etype (Opnod, Base_Type (Ctyp));
1136 Set_Do_Overflow_Check (Opnod, False);
1137 Set_Analyzed (Opnod, True);
1139 -- Now build the outer conversion
1141 Opnd := OK_Convert_To (Typ, Opnod);
1143 Set_Etype (Opnd, Typ);
1145 -- In the discrete type case, we directly generate the range check
1146 -- for the outer operand. This range check will implement the
1147 -- required overflow check.
1149 if Is_Discrete_Type (Typ) then
1151 Generate_Range_Check
1152 (Expression (N), Typ, CE_Overflow_Check_Failed);
1154 -- For other types, we enable overflow checking on the conversion,
1155 -- after setting the node as analyzed to prevent recursive attempts
1156 -- to expand the conversion node.
1159 Set_Analyzed (Opnd, True);
1160 Enable_Overflow_Check (Opnd);
1165 when RE_Not_Available =>
1168 end Apply_Arithmetic_Overflow_Strict;
1170 ----------------------------------------------------
1171 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1172 ----------------------------------------------------
1174 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
1175 pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
1177 Loc : constant Source_Ptr := Sloc (Op);
1178 P : constant Node_Id := Parent (Op);
1180 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
1181 -- Operands and results are of this type when we convert
1183 Result_Type : constant Entity_Id := Etype (Op);
1184 -- Original result type
1186 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1187 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
1190 -- Ranges of values for result
1193 -- Nothing to do if our parent is one of the following:
1195 -- Another signed integer arithmetic op
1196 -- A membership operation
1197 -- A comparison operation
1199 -- In all these cases, we will process at the higher level (and then
1200 -- this node will be processed during the downwards recursion that
1201 -- is part of the processing in Minimize_Eliminate_Overflows).
1203 if Is_Signed_Integer_Arithmetic_Op (P)
1204 or else Nkind (P) in N_Membership_Test
1205 or else Nkind (P) in N_Op_Compare
1207 -- This is also true for an alternative in a case expression
1209 or else Nkind (P) = N_Case_Expression_Alternative
1211 -- This is also true for a range operand in a membership test
1213 or else (Nkind (P) = N_Range
1214 and then Nkind (Parent (P)) in N_Membership_Test)
1219 -- Otherwise, we have a top level arithmetic operation node, and this
1220 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1221 -- modes. This is the case where we tell the machinery not to move into
1222 -- Bignum mode at this top level (of course the top level operation
1223 -- will still be in Bignum mode if either of its operands are of type
1226 Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
1228 -- That call may but does not necessarily change the result type of Op.
1229 -- It is the job of this routine to undo such changes, so that at the
1230 -- top level, we have the proper type. This "undoing" is a point at
1231 -- which a final overflow check may be applied.
1233 -- If the result type was not fiddled we are all set. We go to base
1234 -- types here because things may have been rewritten to generate the
1235 -- base type of the operand types.
1237 if Base_Type (Etype (Op)) = Base_Type (Result_Type) then
1242 elsif Is_RTE (Etype (Op), RE_Bignum) then
1244 -- We need a sequence that looks like:
1246 -- Rnn : Result_Type;
1249 -- M : Mark_Id := SS_Mark;
1251 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1255 -- This block is inserted (using Insert_Actions), and then the node
1256 -- is replaced with a reference to Rnn.
1258 -- A special case arises if our parent is a conversion node. In this
1259 -- case no point in generating a conversion to Result_Type, we will
1260 -- let the parent handle this. Note that this special case is not
1261 -- just about optimization. Consider
1265 -- X := Long_Long_Integer'Base (A * (B ** C));
1267 -- Now the product may fit in Long_Long_Integer but not in Integer.
1268 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1269 -- overflow exception for this intermediate value.
1272 Blk : constant Node_Id := Make_Bignum_Block (Loc);
1273 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
1279 RHS := Convert_From_Bignum (Op);
1281 if Nkind (P) /= N_Type_Conversion then
1282 Convert_To_And_Rewrite (Result_Type, RHS);
1283 Rtype := Result_Type;
1285 -- Interesting question, do we need a check on that conversion
1286 -- operation. Answer, not if we know the result is in range.
1287 -- At the moment we are not taking advantage of this. To be
1288 -- looked at later ???
1295 (First (Statements (Handled_Statement_Sequence (Blk))),
1296 Make_Assignment_Statement (Loc,
1297 Name => New_Occurrence_Of (Rnn, Loc),
1298 Expression => RHS));
1300 Insert_Actions (Op, New_List (
1301 Make_Object_Declaration (Loc,
1302 Defining_Identifier => Rnn,
1303 Object_Definition => New_Occurrence_Of (Rtype, Loc)),
1306 Rewrite (Op, New_Occurrence_Of (Rnn, Loc));
1307 Analyze_And_Resolve (Op);
1310 -- Here we know the result is Long_Long_Integer'Base, of that it has
1311 -- been rewritten because the parent operation is a conversion. See
1312 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1316 (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion);
1318 -- All we need to do here is to convert the result to the proper
1319 -- result type. As explained above for the Bignum case, we can
1320 -- omit this if our parent is a type conversion.
1322 if Nkind (P) /= N_Type_Conversion then
1323 Convert_To_And_Rewrite (Result_Type, Op);
1326 Analyze_And_Resolve (Op);
1328 end Apply_Arithmetic_Overflow_Minimized_Eliminated;
1330 ----------------------------
1331 -- Apply_Constraint_Check --
1332 ----------------------------
1334 procedure Apply_Constraint_Check
1337 No_Sliding : Boolean := False)
1339 Desig_Typ : Entity_Id;
1342 -- No checks inside a generic (check the instantiations)
1344 if Inside_A_Generic then
1348 -- Apply required constraint checks
1350 if Is_Scalar_Type (Typ) then
1351 Apply_Scalar_Range_Check (N, Typ);
1353 elsif Is_Array_Type (Typ) then
1355 -- A useful optimization: an aggregate with only an others clause
1356 -- always has the right bounds.
1358 if Nkind (N) = N_Aggregate
1359 and then No (Expressions (N))
1361 (First (Choices (First (Component_Associations (N)))))
1367 if Is_Constrained (Typ) then
1368 Apply_Length_Check (N, Typ);
1371 Apply_Range_Check (N, Typ);
1374 Apply_Range_Check (N, Typ);
1377 elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
1378 and then Has_Discriminants (Base_Type (Typ))
1379 and then Is_Constrained (Typ)
1381 Apply_Discriminant_Check (N, Typ);
1383 elsif Is_Access_Type (Typ) then
1385 Desig_Typ := Designated_Type (Typ);
1387 -- No checks necessary if expression statically null
1389 if Known_Null (N) then
1390 if Can_Never_Be_Null (Typ) then
1391 Install_Null_Excluding_Check (N);
1394 -- No sliding possible on access to arrays
1396 elsif Is_Array_Type (Desig_Typ) then
1397 if Is_Constrained (Desig_Typ) then
1398 Apply_Length_Check (N, Typ);
1401 Apply_Range_Check (N, Typ);
1403 elsif Has_Discriminants (Base_Type (Desig_Typ))
1404 and then Is_Constrained (Desig_Typ)
1406 Apply_Discriminant_Check (N, Typ);
1409 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1410 -- this check if the constraint node is illegal, as shown by having
1411 -- an error posted. This additional guard prevents cascaded errors
1412 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1414 if Can_Never_Be_Null (Typ)
1415 and then not Can_Never_Be_Null (Etype (N))
1416 and then not Error_Posted (N)
1418 Install_Null_Excluding_Check (N);
1421 end Apply_Constraint_Check;
1423 ------------------------------
1424 -- Apply_Discriminant_Check --
1425 ------------------------------
1427 procedure Apply_Discriminant_Check
1430 Lhs : Node_Id := Empty)
1432 Loc : constant Source_Ptr := Sloc (N);
1433 Do_Access : constant Boolean := Is_Access_Type (Typ);
1434 S_Typ : Entity_Id := Etype (N);
1438 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
1439 -- A heap object with an indefinite subtype is constrained by its
1440 -- initial value, and assigning to it requires a constraint_check.
1441 -- The target may be an explicit dereference, or a renaming of one.
1443 function Is_Aliased_Unconstrained_Component return Boolean;
1444 -- It is possible for an aliased component to have a nominal
1445 -- unconstrained subtype (through instantiation). If this is a
1446 -- discriminated component assigned in the expansion of an aggregate
1447 -- in an initialization, the check must be suppressed. This unusual
1448 -- situation requires a predicate of its own.
1450 ----------------------------------
1451 -- Denotes_Explicit_Dereference --
1452 ----------------------------------
1454 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
1457 Nkind (Obj) = N_Explicit_Dereference
1459 (Is_Entity_Name (Obj)
1460 and then Present (Renamed_Object (Entity (Obj)))
1461 and then Nkind (Renamed_Object (Entity (Obj))) =
1462 N_Explicit_Dereference);
1463 end Denotes_Explicit_Dereference;
1465 ----------------------------------------
1466 -- Is_Aliased_Unconstrained_Component --
1467 ----------------------------------------
1469 function Is_Aliased_Unconstrained_Component return Boolean is
1474 if Nkind (Lhs) /= N_Selected_Component then
1477 Comp := Entity (Selector_Name (Lhs));
1478 Pref := Prefix (Lhs);
1481 if Ekind (Comp) /= E_Component
1482 or else not Is_Aliased (Comp)
1487 return not Comes_From_Source (Pref)
1488 and then In_Instance
1489 and then not Is_Constrained (Etype (Comp));
1490 end Is_Aliased_Unconstrained_Component;
1492 -- Start of processing for Apply_Discriminant_Check
1496 T_Typ := Designated_Type (Typ);
1501 -- Nothing to do if discriminant checks are suppressed or else no code
1502 -- is to be generated
1504 if not Expander_Active
1505 or else Discriminant_Checks_Suppressed (T_Typ)
1510 -- No discriminant checks necessary for an access when expression is
1511 -- statically Null. This is not only an optimization, it is fundamental
1512 -- because otherwise discriminant checks may be generated in init procs
1513 -- for types containing an access to a not-yet-frozen record, causing a
1514 -- deadly forward reference.
1516 -- Also, if the expression is of an access type whose designated type is
1517 -- incomplete, then the access value must be null and we suppress the
1520 if Known_Null (N) then
1523 elsif Is_Access_Type (S_Typ) then
1524 S_Typ := Designated_Type (S_Typ);
1526 if Ekind (S_Typ) = E_Incomplete_Type then
1531 -- If an assignment target is present, then we need to generate the
1532 -- actual subtype if the target is a parameter or aliased object with
1533 -- an unconstrained nominal subtype.
1535 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1536 -- subtype to the parameter and dereference cases, since other aliased
1537 -- objects are unconstrained (unless the nominal subtype is explicitly
1541 and then (Present (Param_Entity (Lhs))
1542 or else (Ada_Version < Ada_2005
1543 and then not Is_Constrained (T_Typ)
1544 and then Is_Aliased_View (Lhs)
1545 and then not Is_Aliased_Unconstrained_Component)
1546 or else (Ada_Version >= Ada_2005
1547 and then not Is_Constrained (T_Typ)
1548 and then Denotes_Explicit_Dereference (Lhs)
1549 and then Nkind (Original_Node (Lhs)) /=
1552 T_Typ := Get_Actual_Subtype (Lhs);
1555 -- Nothing to do if the type is unconstrained (this is the case where
1556 -- the actual subtype in the RM sense of N is unconstrained and no check
1559 if not Is_Constrained (T_Typ) then
1562 -- Ada 2005: nothing to do if the type is one for which there is a
1563 -- partial view that is constrained.
1565 elsif Ada_Version >= Ada_2005
1566 and then Object_Type_Has_Constrained_Partial_View
1567 (Typ => Base_Type (T_Typ),
1568 Scop => Current_Scope)
1573 -- Nothing to do if the type is an Unchecked_Union
1575 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1579 -- Suppress checks if the subtypes are the same. The check must be
1580 -- preserved in an assignment to a formal, because the constraint is
1581 -- given by the actual.
1583 if Nkind (Original_Node (N)) /= N_Allocator
1585 or else not Is_Entity_Name (Lhs)
1586 or else No (Param_Entity (Lhs)))
1589 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1590 and then not Is_Aliased_View (Lhs)
1595 -- We can also eliminate checks on allocators with a subtype mark that
1596 -- coincides with the context type. The context type may be a subtype
1597 -- without a constraint (common case, a generic actual).
1599 elsif Nkind (Original_Node (N)) = N_Allocator
1600 and then Is_Entity_Name (Expression (Original_Node (N)))
1603 Alloc_Typ : constant Entity_Id :=
1604 Entity (Expression (Original_Node (N)));
1607 if Alloc_Typ = T_Typ
1608 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1609 and then Is_Entity_Name (
1610 Subtype_Indication (Parent (T_Typ)))
1611 and then Alloc_Typ = Base_Type (T_Typ))
1619 -- See if we have a case where the types are both constrained, and all
1620 -- the constraints are constants. In this case, we can do the check
1621 -- successfully at compile time.
1623 -- We skip this check for the case where the node is rewritten as
1624 -- an allocator, because it already carries the context subtype,
1625 -- and extracting the discriminants from the aggregate is messy.
1627 if Is_Constrained (S_Typ)
1628 and then Nkind (Original_Node (N)) /= N_Allocator
1638 -- S_Typ may not have discriminants in the case where it is a
1639 -- private type completed by a default discriminated type. In that
1640 -- case, we need to get the constraints from the underlying type.
1641 -- If the underlying type is unconstrained (i.e. has no default
1642 -- discriminants) no check is needed.
1644 if Has_Discriminants (S_Typ) then
1645 Discr := First_Discriminant (S_Typ);
1646 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1649 Discr := First_Discriminant (Underlying_Type (S_Typ));
1652 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1658 -- A further optimization: if T_Typ is derived from S_Typ
1659 -- without imposing a constraint, no check is needed.
1661 if Nkind (Original_Node (Parent (T_Typ))) =
1662 N_Full_Type_Declaration
1665 Type_Def : constant Node_Id :=
1666 Type_Definition (Original_Node (Parent (T_Typ)));
1668 if Nkind (Type_Def) = N_Derived_Type_Definition
1669 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1670 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1678 -- Constraint may appear in full view of type
1680 if Ekind (T_Typ) = E_Private_Subtype
1681 and then Present (Full_View (T_Typ))
1684 First_Elmt (Discriminant_Constraint (Full_View (T_Typ)));
1687 First_Elmt (Discriminant_Constraint (T_Typ));
1690 while Present (Discr) loop
1691 ItemS := Node (DconS);
1692 ItemT := Node (DconT);
1694 -- For a discriminated component type constrained by the
1695 -- current instance of an enclosing type, there is no
1696 -- applicable discriminant check.
1698 if Nkind (ItemT) = N_Attribute_Reference
1699 and then Is_Access_Type (Etype (ItemT))
1700 and then Is_Entity_Name (Prefix (ItemT))
1701 and then Is_Type (Entity (Prefix (ItemT)))
1706 -- If the expressions for the discriminants are identical
1707 -- and it is side-effect free (for now just an entity),
1708 -- this may be a shared constraint, e.g. from a subtype
1709 -- without a constraint introduced as a generic actual.
1710 -- Examine other discriminants if any.
1713 and then Is_Entity_Name (ItemS)
1717 elsif not Is_OK_Static_Expression (ItemS)
1718 or else not Is_OK_Static_Expression (ItemT)
1722 elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
1723 if Do_Access then -- needs run-time check.
1726 Apply_Compile_Time_Constraint_Error
1727 (N, "incorrect value for discriminant&??",
1728 CE_Discriminant_Check_Failed, Ent => Discr);
1735 Next_Discriminant (Discr);
1744 -- Here we need a discriminant check. First build the expression
1745 -- for the comparisons of the discriminants:
1747 -- (n.disc1 /= typ.disc1) or else
1748 -- (n.disc2 /= typ.disc2) or else
1750 -- (n.discn /= typ.discn)
1752 Cond := Build_Discriminant_Checks (N, T_Typ);
1754 -- If Lhs is set and is a parameter, then the condition is guarded by:
1755 -- lhs'constrained and then (condition built above)
1757 if Present (Param_Entity (Lhs)) then
1761 Make_Attribute_Reference (Loc,
1762 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1763 Attribute_Name => Name_Constrained),
1764 Right_Opnd => Cond);
1768 Cond := Guard_Access (Cond, Loc, N);
1772 Make_Raise_Constraint_Error (Loc,
1774 Reason => CE_Discriminant_Check_Failed));
1775 end Apply_Discriminant_Check;
1777 -------------------------
1778 -- Apply_Divide_Checks --
1779 -------------------------
1781 procedure Apply_Divide_Checks (N : Node_Id) is
1782 Loc : constant Source_Ptr := Sloc (N);
1783 Typ : constant Entity_Id := Etype (N);
1784 Left : constant Node_Id := Left_Opnd (N);
1785 Right : constant Node_Id := Right_Opnd (N);
1787 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1788 -- Current overflow checking mode
1798 pragma Warnings (Off, Lhi);
1799 -- Don't actually use this value
1802 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1803 -- operating on signed integer types, then the only thing this routine
1804 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1805 -- procedure will (possibly later on during recursive downward calls),
1806 -- ensure that any needed overflow/division checks are properly applied.
1808 if Mode in Minimized_Or_Eliminated
1809 and then Is_Signed_Integer_Type (Typ)
1811 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
1815 -- Proceed here in SUPPRESSED or CHECKED modes
1818 and then not Backend_Divide_Checks_On_Target
1819 and then Check_Needed (Right, Division_Check)
1821 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
1823 -- Deal with division check
1825 if Do_Division_Check (N)
1826 and then not Division_Checks_Suppressed (Typ)
1828 Apply_Division_Check (N, Rlo, Rhi, ROK);
1831 -- Deal with overflow check
1833 if Do_Overflow_Check (N)
1834 and then not Overflow_Checks_Suppressed (Etype (N))
1836 Set_Do_Overflow_Check (N, False);
1838 -- Test for extremely annoying case of xxx'First divided by -1
1839 -- for division of signed integer types (only overflow case).
1841 if Nkind (N) = N_Op_Divide
1842 and then Is_Signed_Integer_Type (Typ)
1844 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
1845 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1847 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1849 ((not LOK) or else (Llo = LLB))
1852 Make_Raise_Constraint_Error (Loc,
1858 Duplicate_Subexpr_Move_Checks (Left),
1859 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1863 Left_Opnd => Duplicate_Subexpr (Right),
1864 Right_Opnd => Make_Integer_Literal (Loc, -1))),
1866 Reason => CE_Overflow_Check_Failed));
1871 end Apply_Divide_Checks;
1873 --------------------------
1874 -- Apply_Division_Check --
1875 --------------------------
1877 procedure Apply_Division_Check
1883 pragma Assert (Do_Division_Check (N));
1885 Loc : constant Source_Ptr := Sloc (N);
1886 Right : constant Node_Id := Right_Opnd (N);
1890 and then not Backend_Divide_Checks_On_Target
1891 and then Check_Needed (Right, Division_Check)
1893 -- See if division by zero possible, and if so generate test. This
1894 -- part of the test is not controlled by the -gnato switch, since
1895 -- it is a Division_Check and not an Overflow_Check.
1897 if Do_Division_Check (N) then
1898 Set_Do_Division_Check (N, False);
1900 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1902 Make_Raise_Constraint_Error (Loc,
1905 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1906 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1907 Reason => CE_Divide_By_Zero));
1911 end Apply_Division_Check;
1913 ----------------------------------
1914 -- Apply_Float_Conversion_Check --
1915 ----------------------------------
1917 -- Let F and I be the source and target types of the conversion. The RM
1918 -- specifies that a floating-point value X is rounded to the nearest
1919 -- integer, with halfway cases being rounded away from zero. The rounded
1920 -- value of X is checked against I'Range.
1922 -- The catch in the above paragraph is that there is no good way to know
1923 -- whether the round-to-integer operation resulted in overflow. A remedy is
1924 -- to perform a range check in the floating-point domain instead, however:
1926 -- (1) The bounds may not be known at compile time
1927 -- (2) The check must take into account rounding or truncation.
1928 -- (3) The range of type I may not be exactly representable in F.
1929 -- (4) For the rounding case, The end-points I'First - 0.5 and
1930 -- I'Last + 0.5 may or may not be in range, depending on the
1931 -- sign of I'First and I'Last.
1932 -- (5) X may be a NaN, which will fail any comparison
1934 -- The following steps correctly convert X with rounding:
1936 -- (1) If either I'First or I'Last is not known at compile time, use
1937 -- I'Base instead of I in the next three steps and perform a
1938 -- regular range check against I'Range after conversion.
1939 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1940 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1941 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1942 -- In other words, take one of the closest floating-point numbers
1943 -- (which is an integer value) to I'First, and see if it is in
1945 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1946 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1947 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1948 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1949 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1951 -- For the truncating case, replace steps (2) and (3) as follows:
1952 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1953 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1955 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1956 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1959 procedure Apply_Float_Conversion_Check
1961 Target_Typ : Entity_Id)
1963 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1964 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1965 Loc : constant Source_Ptr := Sloc (Ck_Node);
1966 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1967 Target_Base : constant Entity_Id :=
1968 Implementation_Base_Type (Target_Typ);
1970 Par : constant Node_Id := Parent (Ck_Node);
1971 pragma Assert (Nkind (Par) = N_Type_Conversion);
1972 -- Parent of check node, must be a type conversion
1974 Truncate : constant Boolean := Float_Truncate (Par);
1975 Max_Bound : constant Uint :=
1977 (Machine_Radix_Value (Expr_Type),
1978 Machine_Mantissa_Value (Expr_Type) - 1) - 1;
1980 -- Largest bound, so bound plus or minus half is a machine number of F
1982 Ifirst, Ilast : Uint;
1983 -- Bounds of integer type
1986 -- Bounds to check in floating-point domain
1988 Lo_OK, Hi_OK : Boolean;
1989 -- True iff Lo resp. Hi belongs to I'Range
1991 Lo_Chk, Hi_Chk : Node_Id;
1992 -- Expressions that are False iff check fails
1994 Reason : RT_Exception_Code;
1997 -- We do not need checks if we are not generating code (i.e. the full
1998 -- expander is not active). In SPARK mode, we specifically don't want
1999 -- the frontend to expand these checks, which are dealt with directly
2000 -- in the formal verification backend.
2002 if not Expander_Active then
2006 if not Compile_Time_Known_Value (LB)
2007 or not Compile_Time_Known_Value (HB)
2010 -- First check that the value falls in the range of the base type,
2011 -- to prevent overflow during conversion and then perform a
2012 -- regular range check against the (dynamic) bounds.
2014 pragma Assert (Target_Base /= Target_Typ);
2016 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
2019 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
2020 Set_Etype (Temp, Target_Base);
2022 Insert_Action (Parent (Par),
2023 Make_Object_Declaration (Loc,
2024 Defining_Identifier => Temp,
2025 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
2026 Expression => New_Copy_Tree (Par)),
2027 Suppress => All_Checks);
2030 Make_Raise_Constraint_Error (Loc,
2033 Left_Opnd => New_Occurrence_Of (Temp, Loc),
2034 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
2035 Reason => CE_Range_Check_Failed));
2036 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
2042 -- Get the (static) bounds of the target type
2044 Ifirst := Expr_Value (LB);
2045 Ilast := Expr_Value (HB);
2047 -- A simple optimization: if the expression is a universal literal,
2048 -- we can do the comparison with the bounds and the conversion to
2049 -- an integer type statically. The range checks are unchanged.
2051 if Nkind (Ck_Node) = N_Real_Literal
2052 and then Etype (Ck_Node) = Universal_Real
2053 and then Is_Integer_Type (Target_Typ)
2054 and then Nkind (Parent (Ck_Node)) = N_Type_Conversion
2057 Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
2060 if Int_Val <= Ilast and then Int_Val >= Ifirst then
2062 -- Conversion is safe
2064 Rewrite (Parent (Ck_Node),
2065 Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
2066 Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
2072 -- Check against lower bound
2074 if Truncate and then Ifirst > 0 then
2075 Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
2079 Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
2082 elsif abs (Ifirst) < Max_Bound then
2083 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
2084 Lo_OK := (Ifirst > 0);
2087 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
2088 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
2093 -- Lo_Chk := (X >= Lo)
2095 Lo_Chk := Make_Op_Ge (Loc,
2096 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2097 Right_Opnd => Make_Real_Literal (Loc, Lo));
2100 -- Lo_Chk := (X > Lo)
2102 Lo_Chk := Make_Op_Gt (Loc,
2103 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2104 Right_Opnd => Make_Real_Literal (Loc, Lo));
2107 -- Check against higher bound
2109 if Truncate and then Ilast < 0 then
2110 Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
2114 Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
2117 elsif abs (Ilast) < Max_Bound then
2118 Hi := UR_From_Uint (Ilast) + Ureal_Half;
2119 Hi_OK := (Ilast < 0);
2121 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
2122 Hi_OK := (Hi <= UR_From_Uint (Ilast));
2127 -- Hi_Chk := (X <= Hi)
2129 Hi_Chk := Make_Op_Le (Loc,
2130 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2131 Right_Opnd => Make_Real_Literal (Loc, Hi));
2134 -- Hi_Chk := (X < Hi)
2136 Hi_Chk := Make_Op_Lt (Loc,
2137 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2138 Right_Opnd => Make_Real_Literal (Loc, Hi));
2141 -- If the bounds of the target type are the same as those of the base
2142 -- type, the check is an overflow check as a range check is not
2143 -- performed in these cases.
2145 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
2146 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
2148 Reason := CE_Overflow_Check_Failed;
2150 Reason := CE_Range_Check_Failed;
2153 -- Raise CE if either conditions does not hold
2155 Insert_Action (Ck_Node,
2156 Make_Raise_Constraint_Error (Loc,
2157 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
2159 end Apply_Float_Conversion_Check;
2161 ------------------------
2162 -- Apply_Length_Check --
2163 ------------------------
2165 procedure Apply_Length_Check
2167 Target_Typ : Entity_Id;
2168 Source_Typ : Entity_Id := Empty)
2171 Apply_Selected_Length_Checks
2172 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2173 end Apply_Length_Check;
2175 -------------------------------------
2176 -- Apply_Parameter_Aliasing_Checks --
2177 -------------------------------------
2179 procedure Apply_Parameter_Aliasing_Checks
2183 Loc : constant Source_Ptr := Sloc (Call);
2185 function May_Cause_Aliasing
2186 (Formal_1 : Entity_Id;
2187 Formal_2 : Entity_Id) return Boolean;
2188 -- Determine whether two formal parameters can alias each other
2189 -- depending on their modes.
2191 function Original_Actual (N : Node_Id) return Node_Id;
2192 -- The expander may replace an actual with a temporary for the sake of
2193 -- side effect removal. The temporary may hide a potential aliasing as
2194 -- it does not share the address of the actual. This routine attempts
2195 -- to retrieve the original actual.
2197 procedure Overlap_Check
2198 (Actual_1 : Node_Id;
2200 Formal_1 : Entity_Id;
2201 Formal_2 : Entity_Id;
2202 Check : in out Node_Id);
2203 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2204 -- If detailed exception messages are enabled, the check is augmented to
2205 -- provide information about the names of the corresponding formals. See
2206 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2207 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2208 -- Check contains all and-ed simple tests generated so far or remains
2209 -- unchanged in the case of detailed exception messaged.
2211 ------------------------
2212 -- May_Cause_Aliasing --
2213 ------------------------
2215 function May_Cause_Aliasing
2216 (Formal_1 : Entity_Id;
2217 Formal_2 : Entity_Id) return Boolean
2220 -- The following combination cannot lead to aliasing
2222 -- Formal 1 Formal 2
2225 if Ekind (Formal_1) = E_In_Parameter
2227 Ekind (Formal_2) = E_In_Parameter
2231 -- The following combinations may lead to aliasing
2233 -- Formal 1 Formal 2
2243 end May_Cause_Aliasing;
2245 ---------------------
2246 -- Original_Actual --
2247 ---------------------
2249 function Original_Actual (N : Node_Id) return Node_Id is
2251 if Nkind (N) = N_Type_Conversion then
2252 return Expression (N);
2254 -- The expander created a temporary to capture the result of a type
2255 -- conversion where the expression is the real actual.
2257 elsif Nkind (N) = N_Identifier
2258 and then Present (Original_Node (N))
2259 and then Nkind (Original_Node (N)) = N_Type_Conversion
2261 return Expression (Original_Node (N));
2265 end Original_Actual;
2271 procedure Overlap_Check
2272 (Actual_1 : Node_Id;
2274 Formal_1 : Entity_Id;
2275 Formal_2 : Entity_Id;
2276 Check : in out Node_Id)
2279 ID_Casing : constant Casing_Type :=
2280 Identifier_Casing (Source_Index (Current_Sem_Unit));
2284 -- Actual_1'Overlaps_Storage (Actual_2)
2287 Make_Attribute_Reference (Loc,
2288 Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
2289 Attribute_Name => Name_Overlaps_Storage,
2291 New_List (New_Copy_Tree (Original_Actual (Actual_2))));
2293 -- Generate the following check when detailed exception messages are
2296 -- if Actual_1'Overlaps_Storage (Actual_2) then
2297 -- raise Program_Error with <detailed message>;
2300 if Exception_Extra_Info then
2303 -- Do not generate location information for internal calls
2305 if Comes_From_Source (Call) then
2306 Store_String_Chars (Build_Location_String (Loc));
2307 Store_String_Char (' ');
2310 Store_String_Chars ("aliased parameters, actuals for """);
2312 Get_Name_String (Chars (Formal_1));
2313 Set_Casing (ID_Casing);
2314 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2316 Store_String_Chars (""" and """);
2318 Get_Name_String (Chars (Formal_2));
2319 Set_Casing (ID_Casing);
2320 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2322 Store_String_Chars (""" overlap");
2324 Insert_Action (Call,
2325 Make_If_Statement (Loc,
2327 Then_Statements => New_List (
2328 Make_Raise_Statement (Loc,
2330 New_Occurrence_Of (Standard_Program_Error, Loc),
2331 Expression => Make_String_Literal (Loc, End_String)))));
2333 -- Create a sequence of overlapping checks by and-ing them all
2343 Right_Opnd => Cond);
2353 Formal_1 : Entity_Id;
2354 Formal_2 : Entity_Id;
2356 -- Start of processing for Apply_Parameter_Aliasing_Checks
2361 Actual_1 := First_Actual (Call);
2362 Formal_1 := First_Formal (Subp);
2363 while Present (Actual_1) and then Present (Formal_1) loop
2365 -- Ensure that the actual is an object that is not passed by value.
2366 -- Elementary types are always passed by value, therefore actuals of
2367 -- such types cannot lead to aliasing.
2369 if Is_Object_Reference (Original_Actual (Actual_1))
2370 and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
2372 Actual_2 := Next_Actual (Actual_1);
2373 Formal_2 := Next_Formal (Formal_1);
2374 while Present (Actual_2) and then Present (Formal_2) loop
2376 -- The other actual we are testing against must also denote
2377 -- a non pass-by-value object. Generate the check only when
2378 -- the mode of the two formals may lead to aliasing.
2380 if Is_Object_Reference (Original_Actual (Actual_2))
2382 Is_Elementary_Type (Etype (Original_Actual (Actual_2)))
2383 and then May_Cause_Aliasing (Formal_1, Formal_2)
2386 (Actual_1 => Actual_1,
2387 Actual_2 => Actual_2,
2388 Formal_1 => Formal_1,
2389 Formal_2 => Formal_2,
2393 Next_Actual (Actual_2);
2394 Next_Formal (Formal_2);
2398 Next_Actual (Actual_1);
2399 Next_Formal (Formal_1);
2402 -- Place a simple check right before the call
2404 if Present (Check) and then not Exception_Extra_Info then
2405 Insert_Action (Call,
2406 Make_Raise_Program_Error (Loc,
2408 Reason => PE_Aliased_Parameters));
2410 end Apply_Parameter_Aliasing_Checks;
2412 -------------------------------------
2413 -- Apply_Parameter_Validity_Checks --
2414 -------------------------------------
2416 procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
2417 Subp_Decl : Node_Id;
2419 procedure Add_Validity_Check
2420 (Context : Entity_Id;
2422 For_Result : Boolean := False);
2423 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2424 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2425 -- Set flag For_Result when to verify the result of a function.
2427 procedure Build_PPC_Pragma (PPC_Nam : Name_Id; Check : Node_Id);
2428 -- Create a pre or post condition pragma with name PPC_Nam which
2429 -- tests expression Check.
2431 ------------------------
2432 -- Add_Validity_Check --
2433 ------------------------
2435 procedure Add_Validity_Check
2436 (Context : Entity_Id;
2438 For_Result : Boolean := False)
2440 Loc : constant Source_Ptr := Sloc (Subp);
2441 Typ : constant Entity_Id := Etype (Context);
2446 -- For scalars, generate 'Valid test
2448 if Is_Scalar_Type (Typ) then
2451 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2453 elsif Scalar_Part_Present (Typ) then
2454 Nam := Name_Valid_Scalars;
2456 -- No test needed for other cases (no scalars to test)
2462 -- Step 1: Create the expression to verify the validity of the
2465 Check := New_Occurrence_Of (Context, Loc);
2467 -- When processing a function result, use 'Result. Generate
2472 Make_Attribute_Reference (Loc,
2474 Attribute_Name => Name_Result);
2478 -- Context['Result]'Valid[_Scalars]
2481 Make_Attribute_Reference (Loc,
2483 Attribute_Name => Nam);
2485 -- Step 2: Create a pre or post condition pragma
2487 Build_PPC_Pragma (PPC_Nam, Check);
2488 end Add_Validity_Check;
2490 ----------------------
2491 -- Build_PPC_Pragma --
2492 ----------------------
2494 procedure Build_PPC_Pragma (PPC_Nam : Name_Id; Check : Node_Id) is
2495 Loc : constant Source_Ptr := Sloc (Subp);
2502 Pragma_Identifier => Make_Identifier (Loc, PPC_Nam),
2503 Pragma_Argument_Associations => New_List (
2504 Make_Pragma_Argument_Association (Loc,
2505 Chars => Name_Check,
2506 Expression => Check)));
2508 -- Add a message unless exception messages are suppressed
2510 if not Exception_Locations_Suppressed then
2511 Append_To (Pragma_Argument_Associations (Prag),
2512 Make_Pragma_Argument_Association (Loc,
2513 Chars => Name_Message,
2515 Make_String_Literal (Loc,
2516 Strval => "failed " & Get_Name_String (PPC_Nam) &
2517 " from " & Build_Location_String (Loc))));
2520 -- Insert the pragma in the tree
2522 if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then
2523 Add_Global_Declaration (Prag);
2526 -- PPC pragmas associated with subprogram bodies must be inserted in
2527 -- the declarative part of the body.
2529 elsif Nkind (Subp_Decl) = N_Subprogram_Body then
2530 Decls := Declarations (Subp_Decl);
2534 Set_Declarations (Subp_Decl, Decls);
2537 Prepend_To (Decls, Prag);
2539 -- Ensure the proper visibility of the subprogram body and its
2546 -- For subprogram declarations insert the PPC pragma right after the
2547 -- declarative node.
2550 Insert_After_And_Analyze (Subp_Decl, Prag);
2552 end Build_PPC_Pragma;
2557 Subp_Spec : Node_Id;
2559 -- Start of processing for Apply_Parameter_Validity_Checks
2562 -- Extract the subprogram specification and declaration nodes
2564 Subp_Spec := Parent (Subp);
2566 if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
2567 Subp_Spec := Parent (Subp_Spec);
2570 Subp_Decl := Parent (Subp_Spec);
2572 if not Comes_From_Source (Subp)
2574 -- Do not process formal subprograms because the corresponding actual
2575 -- will receive the proper checks when the instance is analyzed.
2577 or else Is_Formal_Subprogram (Subp)
2579 -- Do not process imported subprograms since pre and post conditions
2580 -- are never verified on routines coming from a different language.
2582 or else Is_Imported (Subp)
2583 or else Is_Intrinsic_Subprogram (Subp)
2585 -- The PPC pragmas generated by this routine do not correspond to
2586 -- source aspects, therefore they cannot be applied to abstract
2589 or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
2591 -- Do not consider subprogram renaminds because the renamed entity
2592 -- already has the proper PPC pragmas.
2594 or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
2596 -- Do not process null procedures because there is no benefit of
2597 -- adding the checks to a no action routine.
2599 or else (Nkind (Subp_Spec) = N_Procedure_Specification
2600 and then Null_Present (Subp_Spec))
2605 -- Inspect all the formals applying aliasing and scalar initialization
2606 -- checks where applicable.
2608 Formal := First_Formal (Subp);
2609 while Present (Formal) loop
2611 -- Generate the following scalar initialization checks for each
2612 -- formal parameter:
2614 -- mode IN - Pre => Formal'Valid[_Scalars]
2615 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2616 -- mode OUT - Post => Formal'Valid[_Scalars]
2618 if Check_Validity_Of_Parameters then
2619 if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
2620 Add_Validity_Check (Formal, Name_Precondition, False);
2623 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
2624 Add_Validity_Check (Formal, Name_Postcondition, False);
2628 Next_Formal (Formal);
2631 -- Generate following scalar initialization check for function result:
2633 -- Post => Subp'Result'Valid[_Scalars]
2635 if Check_Validity_Of_Parameters and then Ekind (Subp) = E_Function then
2636 Add_Validity_Check (Subp, Name_Postcondition, True);
2638 end Apply_Parameter_Validity_Checks;
2640 ---------------------------
2641 -- Apply_Predicate_Check --
2642 ---------------------------
2644 procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
2648 if Present (Predicate_Function (Typ)) then
2651 while Present (S) and then not Is_Subprogram (S) loop
2655 -- A predicate check does not apply within internally generated
2656 -- subprograms, such as TSS functions.
2658 if Within_Internal_Subprogram then
2661 -- If the check appears within the predicate function itself, it
2662 -- means that the user specified a check whose formal is the
2663 -- predicated subtype itself, rather than some covering type. This
2664 -- is likely to be a common error, and thus deserves a warning.
2666 elsif Present (S) and then S = Predicate_Function (Typ) then
2668 ("predicate check includes a function call that "
2669 & "requires a predicate check??", Parent (N));
2671 ("\this will result in infinite recursion??", Parent (N));
2673 Make_Raise_Storage_Error (Sloc (N),
2674 Reason => SE_Infinite_Recursion));
2676 -- Here for normal case of predicate active
2679 -- If the type has a static predicate and the expression is known
2680 -- at compile time, see if the expression satisfies the predicate.
2682 Check_Expression_Against_Static_Predicate (N, Typ);
2685 Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
2688 end Apply_Predicate_Check;
2690 -----------------------
2691 -- Apply_Range_Check --
2692 -----------------------
2694 procedure Apply_Range_Check
2696 Target_Typ : Entity_Id;
2697 Source_Typ : Entity_Id := Empty)
2700 Apply_Selected_Range_Checks
2701 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2702 end Apply_Range_Check;
2704 ------------------------------
2705 -- Apply_Scalar_Range_Check --
2706 ------------------------------
2708 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2709 -- off if it is already set on.
2711 procedure Apply_Scalar_Range_Check
2713 Target_Typ : Entity_Id;
2714 Source_Typ : Entity_Id := Empty;
2715 Fixed_Int : Boolean := False)
2717 Parnt : constant Node_Id := Parent (Expr);
2719 Arr : Node_Id := Empty; -- initialize to prevent warning
2720 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
2723 Is_Subscr_Ref : Boolean;
2724 -- Set true if Expr is a subscript
2726 Is_Unconstrained_Subscr_Ref : Boolean;
2727 -- Set true if Expr is a subscript of an unconstrained array. In this
2728 -- case we do not attempt to do an analysis of the value against the
2729 -- range of the subscript, since we don't know the actual subtype.
2732 -- Set to True if Expr should be regarded as a real value even though
2733 -- the type of Expr might be discrete.
2735 procedure Bad_Value;
2736 -- Procedure called if value is determined to be out of range
2742 procedure Bad_Value is
2744 Apply_Compile_Time_Constraint_Error
2745 (Expr, "value not in range of}??", CE_Range_Check_Failed,
2750 -- Start of processing for Apply_Scalar_Range_Check
2753 -- Return if check obviously not needed
2756 -- Not needed inside generic
2760 -- Not needed if previous error
2762 or else Target_Typ = Any_Type
2763 or else Nkind (Expr) = N_Error
2765 -- Not needed for non-scalar type
2767 or else not Is_Scalar_Type (Target_Typ)
2769 -- Not needed if we know node raises CE already
2771 or else Raises_Constraint_Error (Expr)
2776 -- Now, see if checks are suppressed
2779 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
2781 if Is_Subscr_Ref then
2782 Arr := Prefix (Parnt);
2783 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
2785 if Is_Access_Type (Arr_Typ) then
2786 Arr_Typ := Designated_Type (Arr_Typ);
2790 if not Do_Range_Check (Expr) then
2792 -- Subscript reference. Check for Index_Checks suppressed
2794 if Is_Subscr_Ref then
2796 -- Check array type and its base type
2798 if Index_Checks_Suppressed (Arr_Typ)
2799 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
2803 -- Check array itself if it is an entity name
2805 elsif Is_Entity_Name (Arr)
2806 and then Index_Checks_Suppressed (Entity (Arr))
2810 -- Check expression itself if it is an entity name
2812 elsif Is_Entity_Name (Expr)
2813 and then Index_Checks_Suppressed (Entity (Expr))
2818 -- All other cases, check for Range_Checks suppressed
2821 -- Check target type and its base type
2823 if Range_Checks_Suppressed (Target_Typ)
2824 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
2828 -- Check expression itself if it is an entity name
2830 elsif Is_Entity_Name (Expr)
2831 and then Range_Checks_Suppressed (Entity (Expr))
2835 -- If Expr is part of an assignment statement, then check left
2836 -- side of assignment if it is an entity name.
2838 elsif Nkind (Parnt) = N_Assignment_Statement
2839 and then Is_Entity_Name (Name (Parnt))
2840 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
2847 -- Do not set range checks if they are killed
2849 if Nkind (Expr) = N_Unchecked_Type_Conversion
2850 and then Kill_Range_Check (Expr)
2855 -- Do not set range checks for any values from System.Scalar_Values
2856 -- since the whole idea of such values is to avoid checking them.
2858 if Is_Entity_Name (Expr)
2859 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
2864 -- Now see if we need a check
2866 if No (Source_Typ) then
2867 S_Typ := Etype (Expr);
2869 S_Typ := Source_Typ;
2872 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
2876 Is_Unconstrained_Subscr_Ref :=
2877 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
2879 -- Special checks for floating-point type
2881 if Is_Floating_Point_Type (S_Typ) then
2883 -- Always do a range check if the source type includes infinities and
2884 -- the target type does not include infinities. We do not do this if
2885 -- range checks are killed.
2887 if Has_Infinities (S_Typ)
2888 and then not Has_Infinities (Target_Typ)
2890 Enable_Range_Check (Expr);
2894 -- Return if we know expression is definitely in the range of the target
2895 -- type as determined by Determine_Range. Right now we only do this for
2896 -- discrete types, and not fixed-point or floating-point types.
2898 -- The additional less-precise tests below catch these cases
2900 -- Note: skip this if we are given a source_typ, since the point of
2901 -- supplying a Source_Typ is to stop us looking at the expression.
2902 -- We could sharpen this test to be out parameters only ???
2904 if Is_Discrete_Type (Target_Typ)
2905 and then Is_Discrete_Type (Etype (Expr))
2906 and then not Is_Unconstrained_Subscr_Ref
2907 and then No (Source_Typ)
2910 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
2911 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
2916 if Compile_Time_Known_Value (Tlo)
2917 and then Compile_Time_Known_Value (Thi)
2920 Lov : constant Uint := Expr_Value (Tlo);
2921 Hiv : constant Uint := Expr_Value (Thi);
2924 -- If range is null, we for sure have a constraint error
2925 -- (we don't even need to look at the value involved,
2926 -- since all possible values will raise CE).
2933 -- Otherwise determine range of value
2935 Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True);
2939 -- If definitely in range, all OK
2941 if Lo >= Lov and then Hi <= Hiv then
2944 -- If definitely not in range, warn
2946 elsif Lov > Hi or else Hiv < Lo then
2950 -- Otherwise we don't know
2962 Is_Floating_Point_Type (S_Typ)
2963 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
2965 -- Check if we can determine at compile time whether Expr is in the
2966 -- range of the target type. Note that if S_Typ is within the bounds
2967 -- of Target_Typ then this must be the case. This check is meaningful
2968 -- only if this is not a conversion between integer and real types.
2970 if not Is_Unconstrained_Subscr_Ref
2971 and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
2973 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
2975 -- Also check if the expression itself is in the range of the
2976 -- target type if it is a known at compile time value. We skip
2977 -- this test if S_Typ is set since for OUT and IN OUT parameters
2978 -- the Expr itself is not relevant to the checking.
2982 and then Is_In_Range (Expr, Target_Typ,
2983 Assume_Valid => True,
2984 Fixed_Int => Fixed_Int,
2985 Int_Real => Int_Real)))
2989 elsif Is_Out_Of_Range (Expr, Target_Typ,
2990 Assume_Valid => True,
2991 Fixed_Int => Fixed_Int,
2992 Int_Real => Int_Real)
2997 -- Floating-point case
2998 -- In the floating-point case, we only do range checks if the type is
2999 -- constrained. We definitely do NOT want range checks for unconstrained
3000 -- types, since we want to have infinities
3002 elsif Is_Floating_Point_Type (S_Typ) then
3004 -- Normally, we only do range checks if the type is constrained. We do
3005 -- NOT want range checks for unconstrained types, since we want to have
3008 if Is_Constrained (S_Typ) then
3009 Enable_Range_Check (Expr);
3012 -- For all other cases we enable a range check unconditionally
3015 Enable_Range_Check (Expr);
3018 end Apply_Scalar_Range_Check;
3020 ----------------------------------
3021 -- Apply_Selected_Length_Checks --
3022 ----------------------------------
3024 procedure Apply_Selected_Length_Checks
3026 Target_Typ : Entity_Id;
3027 Source_Typ : Entity_Id;
3028 Do_Static : Boolean)
3031 R_Result : Check_Result;
3034 Loc : constant Source_Ptr := Sloc (Ck_Node);
3035 Checks_On : constant Boolean :=
3036 (not Index_Checks_Suppressed (Target_Typ))
3037 or else (not Length_Checks_Suppressed (Target_Typ));
3040 -- Note: this means that we lose some useful warnings if the expander
3041 -- is not active, and we also lose these warnings in SPARK mode ???
3043 if not Expander_Active then
3048 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3050 for J in 1 .. 2 loop
3051 R_Cno := R_Result (J);
3052 exit when No (R_Cno);
3054 -- A length check may mention an Itype which is attached to a
3055 -- subsequent node. At the top level in a package this can cause
3056 -- an order-of-elaboration problem, so we make sure that the itype
3057 -- is referenced now.
3059 if Ekind (Current_Scope) = E_Package
3060 and then Is_Compilation_Unit (Current_Scope)
3062 Ensure_Defined (Target_Typ, Ck_Node);
3064 if Present (Source_Typ) then
3065 Ensure_Defined (Source_Typ, Ck_Node);
3067 elsif Is_Itype (Etype (Ck_Node)) then
3068 Ensure_Defined (Etype (Ck_Node), Ck_Node);
3072 -- If the item is a conditional raise of constraint error, then have
3073 -- a look at what check is being performed and ???
3075 if Nkind (R_Cno) = N_Raise_Constraint_Error
3076 and then Present (Condition (R_Cno))
3078 Cond := Condition (R_Cno);
3080 -- Case where node does not now have a dynamic check
3082 if not Has_Dynamic_Length_Check (Ck_Node) then
3084 -- If checks are on, just insert the check
3087 Insert_Action (Ck_Node, R_Cno);
3089 if not Do_Static then
3090 Set_Has_Dynamic_Length_Check (Ck_Node);
3093 -- If checks are off, then analyze the length check after
3094 -- temporarily attaching it to the tree in case the relevant
3095 -- condition can be evaluated at compile time. We still want a
3096 -- compile time warning in this case.
3099 Set_Parent (R_Cno, Ck_Node);
3104 -- Output a warning if the condition is known to be True
3106 if Is_Entity_Name (Cond)
3107 and then Entity (Cond) = Standard_True
3109 Apply_Compile_Time_Constraint_Error
3110 (Ck_Node, "wrong length for array of}??",
3111 CE_Length_Check_Failed,
3115 -- If we were only doing a static check, or if checks are not
3116 -- on, then we want to delete the check, since it is not needed.
3117 -- We do this by replacing the if statement by a null statement
3119 elsif Do_Static or else not Checks_On then
3120 Remove_Warning_Messages (R_Cno);
3121 Rewrite (R_Cno, Make_Null_Statement (Loc));
3125 Install_Static_Check (R_Cno, Loc);
3128 end Apply_Selected_Length_Checks;
3130 ---------------------------------
3131 -- Apply_Selected_Range_Checks --
3132 ---------------------------------
3134 procedure Apply_Selected_Range_Checks
3136 Target_Typ : Entity_Id;
3137 Source_Typ : Entity_Id;
3138 Do_Static : Boolean)
3140 Loc : constant Source_Ptr := Sloc (Ck_Node);
3141 Checks_On : constant Boolean :=
3142 not Index_Checks_Suppressed (Target_Typ)
3144 not Range_Checks_Suppressed (Target_Typ);
3148 R_Result : Check_Result;
3151 if not Expander_Active or not Checks_On then
3156 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3158 for J in 1 .. 2 loop
3159 R_Cno := R_Result (J);
3160 exit when No (R_Cno);
3162 -- The range check requires runtime evaluation. Depending on what its
3163 -- triggering condition is, the check may be converted into a compile
3164 -- time constraint check.
3166 if Nkind (R_Cno) = N_Raise_Constraint_Error
3167 and then Present (Condition (R_Cno))
3169 Cond := Condition (R_Cno);
3171 -- Insert the range check before the related context. Note that
3172 -- this action analyses the triggering condition.
3174 Insert_Action (Ck_Node, R_Cno);
3176 -- This old code doesn't make sense, why is the context flagged as
3177 -- requiring dynamic range checks now in the middle of generating
3180 if not Do_Static then
3181 Set_Has_Dynamic_Range_Check (Ck_Node);
3184 -- The triggering condition evaluates to True, the range check
3185 -- can be converted into a compile time constraint check.
3187 if Is_Entity_Name (Cond)
3188 and then Entity (Cond) = Standard_True
3190 -- Since an N_Range is technically not an expression, we have
3191 -- to set one of the bounds to C_E and then just flag the
3192 -- N_Range. The warning message will point to the lower bound
3193 -- and complain about a range, which seems OK.
3195 if Nkind (Ck_Node) = N_Range then
3196 Apply_Compile_Time_Constraint_Error
3197 (Low_Bound (Ck_Node),
3198 "static range out of bounds of}??",
3199 CE_Range_Check_Failed,
3203 Set_Raises_Constraint_Error (Ck_Node);
3206 Apply_Compile_Time_Constraint_Error
3208 "static value out of range of}??",
3209 CE_Range_Check_Failed,
3214 -- If we were only doing a static check, or if checks are not
3215 -- on, then we want to delete the check, since it is not needed.
3216 -- We do this by replacing the if statement by a null statement
3218 -- Why are we even generating checks if checks are turned off ???
3220 elsif Do_Static or else not Checks_On then
3221 Remove_Warning_Messages (R_Cno);
3222 Rewrite (R_Cno, Make_Null_Statement (Loc));
3225 -- The range check raises Constrant_Error explicitly
3228 Install_Static_Check (R_Cno, Loc);
3231 end Apply_Selected_Range_Checks;
3233 -------------------------------
3234 -- Apply_Static_Length_Check --
3235 -------------------------------
3237 procedure Apply_Static_Length_Check
3239 Target_Typ : Entity_Id;
3240 Source_Typ : Entity_Id := Empty)
3243 Apply_Selected_Length_Checks
3244 (Expr, Target_Typ, Source_Typ, Do_Static => True);
3245 end Apply_Static_Length_Check;
3247 -------------------------------------
3248 -- Apply_Subscript_Validity_Checks --
3249 -------------------------------------
3251 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
3255 pragma Assert (Nkind (Expr) = N_Indexed_Component);
3257 -- Loop through subscripts
3259 Sub := First (Expressions (Expr));
3260 while Present (Sub) loop
3262 -- Check one subscript. Note that we do not worry about enumeration
3263 -- type with holes, since we will convert the value to a Pos value
3264 -- for the subscript, and that convert will do the necessary validity
3267 Ensure_Valid (Sub, Holes_OK => True);
3269 -- Move to next subscript
3273 end Apply_Subscript_Validity_Checks;
3275 ----------------------------------
3276 -- Apply_Type_Conversion_Checks --
3277 ----------------------------------
3279 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
3280 Target_Type : constant Entity_Id := Etype (N);
3281 Target_Base : constant Entity_Id := Base_Type (Target_Type);
3282 Expr : constant Node_Id := Expression (N);
3284 Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
3285 -- Note: if Etype (Expr) is a private type without discriminants, its
3286 -- full view might have discriminants with defaults, so we need the
3287 -- full view here to retrieve the constraints.
3290 if Inside_A_Generic then
3293 -- Skip these checks if serious errors detected, there are some nasty
3294 -- situations of incomplete trees that blow things up.
3296 elsif Serious_Errors_Detected > 0 then
3299 -- Never generate discriminant checks for Unchecked_Union types
3301 elsif Present (Expr_Type)
3302 and then Is_Unchecked_Union (Expr_Type)
3306 -- Scalar type conversions of the form Target_Type (Expr) require a
3307 -- range check if we cannot be sure that Expr is in the base type of
3308 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3309 -- are not quite the same condition from an implementation point of
3310 -- view, but clearly the second includes the first.
3312 elsif Is_Scalar_Type (Target_Type) then
3314 Conv_OK : constant Boolean := Conversion_OK (N);
3315 -- If the Conversion_OK flag on the type conversion is set and no
3316 -- floating-point type is involved in the type conversion then
3317 -- fixed-point values must be read as integral values.
3319 Float_To_Int : constant Boolean :=
3320 Is_Floating_Point_Type (Expr_Type)
3321 and then Is_Integer_Type (Target_Type);
3324 if not Overflow_Checks_Suppressed (Target_Base)
3325 and then not Overflow_Checks_Suppressed (Target_Type)
3327 In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
3328 and then not Float_To_Int
3330 Activate_Overflow_Check (N);
3333 if not Range_Checks_Suppressed (Target_Type)
3334 and then not Range_Checks_Suppressed (Expr_Type)
3336 if Float_To_Int then
3337 Apply_Float_Conversion_Check (Expr, Target_Type);
3339 Apply_Scalar_Range_Check
3340 (Expr, Target_Type, Fixed_Int => Conv_OK);
3342 -- If the target type has predicates, we need to indicate
3343 -- the need for a check, even if Determine_Range finds that
3344 -- the value is within bounds. This may be the case e.g for
3345 -- a division with a constant denominator.
3347 if Has_Predicates (Target_Type) then
3348 Enable_Range_Check (Expr);
3354 elsif Comes_From_Source (N)
3355 and then not Discriminant_Checks_Suppressed (Target_Type)
3356 and then Is_Record_Type (Target_Type)
3357 and then Is_Derived_Type (Target_Type)
3358 and then not Is_Tagged_Type (Target_Type)
3359 and then not Is_Constrained (Target_Type)
3360 and then Present (Stored_Constraint (Target_Type))
3362 -- An unconstrained derived type may have inherited discriminant.
3363 -- Build an actual discriminant constraint list using the stored
3364 -- constraint, to verify that the expression of the parent type
3365 -- satisfies the constraints imposed by the (unconstrained) derived
3366 -- type. This applies to value conversions, not to view conversions
3370 Loc : constant Source_Ptr := Sloc (N);
3372 Constraint : Elmt_Id;
3373 Discr_Value : Node_Id;
3376 New_Constraints : constant Elist_Id := New_Elmt_List;
3377 Old_Constraints : constant Elist_Id :=
3378 Discriminant_Constraint (Expr_Type);
3381 Constraint := First_Elmt (Stored_Constraint (Target_Type));
3382 while Present (Constraint) loop
3383 Discr_Value := Node (Constraint);
3385 if Is_Entity_Name (Discr_Value)
3386 and then Ekind (Entity (Discr_Value)) = E_Discriminant
3388 Discr := Corresponding_Discriminant (Entity (Discr_Value));
3391 and then Scope (Discr) = Base_Type (Expr_Type)
3393 -- Parent is constrained by new discriminant. Obtain
3394 -- Value of original discriminant in expression. If the
3395 -- new discriminant has been used to constrain more than
3396 -- one of the stored discriminants, this will provide the
3397 -- required consistency check.
3400 (Make_Selected_Component (Loc,
3402 Duplicate_Subexpr_No_Checks
3403 (Expr, Name_Req => True),
3405 Make_Identifier (Loc, Chars (Discr))),
3409 -- Discriminant of more remote ancestor ???
3414 -- Derived type definition has an explicit value for this
3415 -- stored discriminant.
3419 (Duplicate_Subexpr_No_Checks (Discr_Value),
3423 Next_Elmt (Constraint);
3426 -- Use the unconstrained expression type to retrieve the
3427 -- discriminants of the parent, and apply momentarily the
3428 -- discriminant constraint synthesized above.
3430 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
3431 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
3432 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
3435 Make_Raise_Constraint_Error (Loc,
3437 Reason => CE_Discriminant_Check_Failed));
3440 -- For arrays, checks are set now, but conversions are applied during
3441 -- expansion, to take into accounts changes of representation. The
3442 -- checks become range checks on the base type or length checks on the
3443 -- subtype, depending on whether the target type is unconstrained or
3444 -- constrained. Note that the range check is put on the expression of a
3445 -- type conversion, while the length check is put on the type conversion
3448 elsif Is_Array_Type (Target_Type) then
3449 if Is_Constrained (Target_Type) then
3450 Set_Do_Length_Check (N);
3452 Set_Do_Range_Check (Expr);
3455 end Apply_Type_Conversion_Checks;
3457 ----------------------------------------------
3458 -- Apply_Universal_Integer_Attribute_Checks --
3459 ----------------------------------------------
3461 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
3462 Loc : constant Source_Ptr := Sloc (N);
3463 Typ : constant Entity_Id := Etype (N);
3466 if Inside_A_Generic then
3469 -- Nothing to do if checks are suppressed
3471 elsif Range_Checks_Suppressed (Typ)
3472 and then Overflow_Checks_Suppressed (Typ)
3476 -- Nothing to do if the attribute does not come from source. The
3477 -- internal attributes we generate of this type do not need checks,
3478 -- and furthermore the attempt to check them causes some circular
3479 -- elaboration orders when dealing with packed types.
3481 elsif not Comes_From_Source (N) then
3484 -- If the prefix is a selected component that depends on a discriminant
3485 -- the check may improperly expose a discriminant instead of using
3486 -- the bounds of the object itself. Set the type of the attribute to
3487 -- the base type of the context, so that a check will be imposed when
3488 -- needed (e.g. if the node appears as an index).
3490 elsif Nkind (Prefix (N)) = N_Selected_Component
3491 and then Ekind (Typ) = E_Signed_Integer_Subtype
3492 and then Depends_On_Discriminant (Scalar_Range (Typ))
3494 Set_Etype (N, Base_Type (Typ));
3496 -- Otherwise, replace the attribute node with a type conversion node
3497 -- whose expression is the attribute, retyped to universal integer, and
3498 -- whose subtype mark is the target type. The call to analyze this
3499 -- conversion will set range and overflow checks as required for proper
3500 -- detection of an out of range value.
3503 Set_Etype (N, Universal_Integer);
3504 Set_Analyzed (N, True);
3507 Make_Type_Conversion (Loc,
3508 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
3509 Expression => Relocate_Node (N)));
3511 Analyze_And_Resolve (N, Typ);
3514 end Apply_Universal_Integer_Attribute_Checks;
3516 -------------------------------------
3517 -- Atomic_Synchronization_Disabled --
3518 -------------------------------------
3520 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3521 -- using a bogus check called Atomic_Synchronization. This is to make it
3522 -- more convenient to get exactly the same semantics as [Un]Suppress.
3524 function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
3526 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3527 -- looks enabled, since it is never disabled.
3529 if Debug_Flag_Dot_E then
3532 -- If debug flag d.d is set then always return True, i.e. all atomic
3533 -- sync looks disabled, since it always tests True.
3535 elsif Debug_Flag_Dot_D then
3538 -- If entity present, then check result for that entity
3540 elsif Present (E) and then Checks_May_Be_Suppressed (E) then
3541 return Is_Check_Suppressed (E, Atomic_Synchronization);
3543 -- Otherwise result depends on current scope setting
3546 return Scope_Suppress.Suppress (Atomic_Synchronization);
3548 end Atomic_Synchronization_Disabled;
3550 -------------------------------
3551 -- Build_Discriminant_Checks --
3552 -------------------------------
3554 function Build_Discriminant_Checks
3556 T_Typ : Entity_Id) return Node_Id
3558 Loc : constant Source_Ptr := Sloc (N);
3561 Disc_Ent : Entity_Id;
3565 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
3567 ----------------------------------
3568 -- Aggregate_Discriminant_Value --
3569 ----------------------------------
3571 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
3575 -- The aggregate has been normalized with named associations. We use
3576 -- the Chars field to locate the discriminant to take into account
3577 -- discriminants in derived types, which carry the same name as those
3580 Assoc := First (Component_Associations (N));
3581 while Present (Assoc) loop
3582 if Chars (First (Choices (Assoc))) = Chars (Disc) then
3583 return Expression (Assoc);
3589 -- Discriminant must have been found in the loop above
3591 raise Program_Error;
3592 end Aggregate_Discriminant_Val;
3594 -- Start of processing for Build_Discriminant_Checks
3597 -- Loop through discriminants evolving the condition
3600 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
3602 -- For a fully private type, use the discriminants of the parent type
3604 if Is_Private_Type (T_Typ)
3605 and then No (Full_View (T_Typ))
3607 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
3609 Disc_Ent := First_Discriminant (T_Typ);
3612 while Present (Disc) loop
3613 Dval := Node (Disc);
3615 if Nkind (Dval) = N_Identifier
3616 and then Ekind (Entity (Dval)) = E_Discriminant
3618 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
3620 Dval := Duplicate_Subexpr_No_Checks (Dval);
3623 -- If we have an Unchecked_Union node, we can infer the discriminants
3626 if Is_Unchecked_Union (Base_Type (T_Typ)) then
3628 Get_Discriminant_Value (
3629 First_Discriminant (T_Typ),
3631 Stored_Constraint (T_Typ)));
3633 elsif Nkind (N) = N_Aggregate then
3635 Duplicate_Subexpr_No_Checks
3636 (Aggregate_Discriminant_Val (Disc_Ent));
3640 Make_Selected_Component (Loc,
3642 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
3643 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
3645 Set_Is_In_Discriminant_Check (Dref);
3648 Evolve_Or_Else (Cond,
3651 Right_Opnd => Dval));
3654 Next_Discriminant (Disc_Ent);
3658 end Build_Discriminant_Checks;
3664 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
3671 function Left_Expression (Op : Node_Id) return Node_Id;
3672 -- Return the relevant expression from the left operand of the given
3673 -- short circuit form: this is LO itself, except if LO is a qualified
3674 -- expression, a type conversion, or an expression with actions, in
3675 -- which case this is Left_Expression (Expression (LO)).
3677 ---------------------
3678 -- Left_Expression --
3679 ---------------------
3681 function Left_Expression (Op : Node_Id) return Node_Id is
3682 LE : Node_Id := Left_Opnd (Op);
3684 while Nkind_In (LE, N_Qualified_Expression,
3686 N_Expression_With_Actions)
3688 LE := Expression (LE);
3692 end Left_Expression;
3694 -- Start of processing for Check_Needed
3697 -- Always check if not simple entity
3699 if Nkind (Nod) not in N_Has_Entity
3700 or else not Comes_From_Source (Nod)
3705 -- Look up tree for short circuit
3712 -- Done if out of subexpression (note that we allow generated stuff
3713 -- such as itype declarations in this context, to keep the loop going
3714 -- since we may well have generated such stuff in complex situations.
3715 -- Also done if no parent (probably an error condition, but no point
3716 -- in behaving nasty if we find it).
3719 or else (K not in N_Subexpr and then Comes_From_Source (P))
3723 -- Or/Or Else case, where test is part of the right operand, or is
3724 -- part of one of the actions associated with the right operand, and
3725 -- the left operand is an equality test.
3727 elsif K = N_Op_Or then
3728 exit when N = Right_Opnd (P)
3729 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3731 elsif K = N_Or_Else then
3732 exit when (N = Right_Opnd (P)
3735 and then List_Containing (N) = Actions (P)))
3736 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3738 -- Similar test for the And/And then case, where the left operand
3739 -- is an inequality test.
3741 elsif K = N_Op_And then
3742 exit when N = Right_Opnd (P)
3743 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3745 elsif K = N_And_Then then
3746 exit when (N = Right_Opnd (P)
3749 and then List_Containing (N) = Actions (P)))
3750 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3756 -- If we fall through the loop, then we have a conditional with an
3757 -- appropriate test as its left operand, so look further.
3759 L := Left_Expression (P);
3761 -- L is an "=" or "/=" operator: extract its operands
3763 R := Right_Opnd (L);
3766 -- Left operand of test must match original variable
3768 if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
3772 -- Right operand of test must be key value (zero or null)
3775 when Access_Check =>
3776 if not Known_Null (R) then
3780 when Division_Check =>
3781 if not Compile_Time_Known_Value (R)
3782 or else Expr_Value (R) /= Uint_0
3788 raise Program_Error;
3791 -- Here we have the optimizable case, warn if not short-circuited
3793 if K = N_Op_And or else K = N_Op_Or then
3794 Error_Msg_Warn := SPARK_Mode /= On;
3797 when Access_Check =>
3798 if GNATprove_Mode then
3800 ("Constraint_Error might have been raised (access check)",
3804 ("Constraint_Error may be raised (access check)??",
3808 when Division_Check =>
3809 if GNATprove_Mode then
3811 ("Constraint_Error might have been raised (zero divide)",
3815 ("Constraint_Error may be raised (zero divide)??",
3820 raise Program_Error;
3823 if K = N_Op_And then
3824 Error_Msg_N -- CODEFIX
3825 ("use `AND THEN` instead of AND??", P);
3827 Error_Msg_N -- CODEFIX
3828 ("use `OR ELSE` instead of OR??", P);
3831 -- If not short-circuited, we need the check
3835 -- If short-circuited, we can omit the check
3842 -----------------------------------
3843 -- Check_Valid_Lvalue_Subscripts --
3844 -----------------------------------
3846 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
3848 -- Skip this if range checks are suppressed
3850 if Range_Checks_Suppressed (Etype (Expr)) then
3853 -- Only do this check for expressions that come from source. We assume
3854 -- that expander generated assignments explicitly include any necessary
3855 -- checks. Note that this is not just an optimization, it avoids
3856 -- infinite recursions.
3858 elsif not Comes_From_Source (Expr) then
3861 -- For a selected component, check the prefix
3863 elsif Nkind (Expr) = N_Selected_Component then
3864 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3867 -- Case of indexed component
3869 elsif Nkind (Expr) = N_Indexed_Component then
3870 Apply_Subscript_Validity_Checks (Expr);
3872 -- Prefix may itself be or contain an indexed component, and these
3873 -- subscripts need checking as well.
3875 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3877 end Check_Valid_Lvalue_Subscripts;
3879 ----------------------------------
3880 -- Null_Exclusion_Static_Checks --
3881 ----------------------------------
3883 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
3884 Error_Node : Node_Id;
3886 Has_Null : constant Boolean := Has_Null_Exclusion (N);
3887 K : constant Node_Kind := Nkind (N);
3892 (Nkind_In (K, N_Component_Declaration,
3893 N_Discriminant_Specification,
3894 N_Function_Specification,
3895 N_Object_Declaration,
3896 N_Parameter_Specification));
3898 if K = N_Function_Specification then
3899 Typ := Etype (Defining_Entity (N));
3901 Typ := Etype (Defining_Identifier (N));
3905 when N_Component_Declaration =>
3906 if Present (Access_Definition (Component_Definition (N))) then
3907 Error_Node := Component_Definition (N);
3909 Error_Node := Subtype_Indication (Component_Definition (N));
3912 when N_Discriminant_Specification =>
3913 Error_Node := Discriminant_Type (N);
3915 when N_Function_Specification =>
3916 Error_Node := Result_Definition (N);
3918 when N_Object_Declaration =>
3919 Error_Node := Object_Definition (N);
3921 when N_Parameter_Specification =>
3922 Error_Node := Parameter_Type (N);
3925 raise Program_Error;
3930 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3931 -- applied to an access [sub]type.
3933 if not Is_Access_Type (Typ) then
3935 ("`NOT NULL` allowed only for an access type", Error_Node);
3937 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3938 -- be applied to a [sub]type that does not exclude null already.
3940 elsif Can_Never_Be_Null (Typ)
3941 and then Comes_From_Source (Typ)
3944 ("`NOT NULL` not allowed (& already excludes null)",
3949 -- Check that null-excluding objects are always initialized, except for
3950 -- deferred constants, for which the expression will appear in the full
3953 if K = N_Object_Declaration
3954 and then No (Expression (N))
3955 and then not Constant_Present (N)
3956 and then not No_Initialization (N)
3958 -- Add an expression that assigns null. This node is needed by
3959 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3960 -- a Constraint_Error node.
3962 Set_Expression (N, Make_Null (Sloc (N)));
3963 Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
3965 Apply_Compile_Time_Constraint_Error
3966 (N => Expression (N),
3968 "(Ada 2005) null-excluding objects must be initialized??",
3969 Reason => CE_Null_Not_Allowed);
3972 -- Check that a null-excluding component, formal or object is not being
3973 -- assigned a null value. Otherwise generate a warning message and
3974 -- replace Expression (N) by an N_Constraint_Error node.
3976 if K /= N_Function_Specification then
3977 Expr := Expression (N);
3979 if Present (Expr) and then Known_Null (Expr) then
3981 when N_Component_Declaration |
3982 N_Discriminant_Specification =>
3983 Apply_Compile_Time_Constraint_Error
3985 Msg => "(Ada 2005) null not allowed "
3986 & "in null-excluding components??",
3987 Reason => CE_Null_Not_Allowed);
3989 when N_Object_Declaration =>
3990 Apply_Compile_Time_Constraint_Error
3992 Msg => "(Ada 2005) null not allowed "
3993 & "in null-excluding objects??",
3994 Reason => CE_Null_Not_Allowed);
3996 when N_Parameter_Specification =>
3997 Apply_Compile_Time_Constraint_Error
3999 Msg => "(Ada 2005) null not allowed "
4000 & "in null-excluding formals??",
4001 Reason => CE_Null_Not_Allowed);
4008 end Null_Exclusion_Static_Checks;
4010 ----------------------------------
4011 -- Conditional_Statements_Begin --
4012 ----------------------------------
4014 procedure Conditional_Statements_Begin is
4016 Saved_Checks_TOS := Saved_Checks_TOS + 1;
4018 -- If stack overflows, kill all checks, that way we know to simply reset
4019 -- the number of saved checks to zero on return. This should never occur
4022 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4025 -- In the normal case, we just make a new stack entry saving the current
4026 -- number of saved checks for a later restore.
4029 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
4031 if Debug_Flag_CC then
4032 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
4036 end Conditional_Statements_Begin;
4038 --------------------------------
4039 -- Conditional_Statements_End --
4040 --------------------------------
4042 procedure Conditional_Statements_End is
4044 pragma Assert (Saved_Checks_TOS > 0);
4046 -- If the saved checks stack overflowed, then we killed all checks, so
4047 -- setting the number of saved checks back to zero is correct. This
4048 -- should never occur in practice.
4050 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4051 Num_Saved_Checks := 0;
4053 -- In the normal case, restore the number of saved checks from the top
4057 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
4059 if Debug_Flag_CC then
4060 w ("Conditional_Statements_End: Num_Saved_Checks = ",
4065 Saved_Checks_TOS := Saved_Checks_TOS - 1;
4066 end Conditional_Statements_End;
4068 -------------------------
4069 -- Convert_From_Bignum --
4070 -------------------------
4072 function Convert_From_Bignum (N : Node_Id) return Node_Id is
4073 Loc : constant Source_Ptr := Sloc (N);
4076 pragma Assert (Is_RTE (Etype (N), RE_Bignum));
4078 -- Construct call From Bignum
4081 Make_Function_Call (Loc,
4083 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4084 Parameter_Associations => New_List (Relocate_Node (N)));
4085 end Convert_From_Bignum;
4087 -----------------------
4088 -- Convert_To_Bignum --
4089 -----------------------
4091 function Convert_To_Bignum (N : Node_Id) return Node_Id is
4092 Loc : constant Source_Ptr := Sloc (N);
4095 -- Nothing to do if Bignum already except call Relocate_Node
4097 if Is_RTE (Etype (N), RE_Bignum) then
4098 return Relocate_Node (N);
4100 -- Otherwise construct call to To_Bignum, converting the operand to the
4101 -- required Long_Long_Integer form.
4104 pragma Assert (Is_Signed_Integer_Type (Etype (N)));
4106 Make_Function_Call (Loc,
4108 New_Occurrence_Of (RTE (RE_To_Bignum), Loc),
4109 Parameter_Associations => New_List (
4110 Convert_To (Standard_Long_Long_Integer, Relocate_Node (N))));
4112 end Convert_To_Bignum;
4114 ---------------------
4115 -- Determine_Range --
4116 ---------------------
4118 Cache_Size : constant := 2 ** 10;
4119 type Cache_Index is range 0 .. Cache_Size - 1;
4120 -- Determine size of below cache (power of 2 is more efficient)
4122 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
4123 Determine_Range_Cache_V : array (Cache_Index) of Boolean;
4124 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
4125 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
4126 Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
4127 Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
4128 -- The above arrays are used to implement a small direct cache for
4129 -- Determine_Range and Determine_Range_R calls. Because of the way these
4130 -- subprograms recursively traces subexpressions, and because overflow
4131 -- checking calls the routine on the way up the tree, a quadratic behavior
4132 -- can otherwise be encountered in large expressions. The cache entry for
4133 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4134 -- by checking the actual node value stored there. The Range_Cache_V array
4135 -- records the setting of Assume_Valid for the cache entry.
4137 procedure Determine_Range
4142 Assume_Valid : Boolean := False)
4144 Typ : Entity_Id := Etype (N);
4145 -- Type to use, may get reset to base type for possibly invalid entity
4149 -- Lo and Hi bounds of left operand
4153 -- Lo and Hi bounds of right (or only) operand
4156 -- Temp variable used to hold a bound node
4159 -- High bound of base type of expression
4163 -- Refined values for low and high bounds, after tightening
4166 -- Used in lower level calls to indicate if call succeeded
4168 Cindex : Cache_Index;
4169 -- Used to search cache
4174 function OK_Operands return Boolean;
4175 -- Used for binary operators. Determines the ranges of the left and
4176 -- right operands, and if they are both OK, returns True, and puts
4177 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4183 function OK_Operands return Boolean is
4186 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4193 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4197 -- Start of processing for Determine_Range
4200 -- Prevent junk warnings by initializing range variables
4207 -- For temporary constants internally generated to remove side effects
4208 -- we must use the corresponding expression to determine the range of
4209 -- the expression. But note that the expander can also generate
4210 -- constants in other cases, including deferred constants.
4212 if Is_Entity_Name (N)
4213 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4214 and then Ekind (Entity (N)) = E_Constant
4215 and then Is_Internal_Name (Chars (Entity (N)))
4217 if Present (Expression (Parent (Entity (N)))) then
4219 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4221 elsif Present (Full_View (Entity (N))) then
4223 (Expression (Parent (Full_View (Entity (N)))),
4224 OK, Lo, Hi, Assume_Valid);
4232 -- If type is not defined, we can't determine its range
4236 -- We don't deal with anything except discrete types
4238 or else not Is_Discrete_Type (Typ)
4240 -- Ignore type for which an error has been posted, since range in
4241 -- this case may well be a bogosity deriving from the error. Also
4242 -- ignore if error posted on the reference node.
4244 or else Error_Posted (N) or else Error_Posted (Typ)
4250 -- For all other cases, we can determine the range
4254 -- If value is compile time known, then the possible range is the one
4255 -- value that we know this expression definitely has.
4257 if Compile_Time_Known_Value (N) then
4258 Lo := Expr_Value (N);
4263 -- Return if already in the cache
4265 Cindex := Cache_Index (N mod Cache_Size);
4267 if Determine_Range_Cache_N (Cindex) = N
4269 Determine_Range_Cache_V (Cindex) = Assume_Valid
4271 Lo := Determine_Range_Cache_Lo (Cindex);
4272 Hi := Determine_Range_Cache_Hi (Cindex);
4276 -- Otherwise, start by finding the bounds of the type of the expression,
4277 -- the value cannot be outside this range (if it is, then we have an
4278 -- overflow situation, which is a separate check, we are talking here
4279 -- only about the expression value).
4281 -- First a check, never try to find the bounds of a generic type, since
4282 -- these bounds are always junk values, and it is only valid to look at
4283 -- the bounds in an instance.
4285 if Is_Generic_Type (Typ) then
4290 -- First step, change to use base type unless we know the value is valid
4292 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4293 or else Assume_No_Invalid_Values
4294 or else Assume_Valid
4298 Typ := Underlying_Type (Base_Type (Typ));
4301 -- Retrieve the base type. Handle the case where the base type is a
4302 -- private enumeration type.
4304 Btyp := Base_Type (Typ);
4306 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4307 Btyp := Full_View (Btyp);
4310 -- We use the actual bound unless it is dynamic, in which case use the
4311 -- corresponding base type bound if possible. If we can't get a bound
4312 -- then we figure we can't determine the range (a peculiar case, that
4313 -- perhaps cannot happen, but there is no point in bombing in this
4314 -- optimization circuit.
4316 -- First the low bound
4318 Bound := Type_Low_Bound (Typ);
4320 if Compile_Time_Known_Value (Bound) then
4321 Lo := Expr_Value (Bound);
4323 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4324 Lo := Expr_Value (Type_Low_Bound (Btyp));
4331 -- Now the high bound
4333 Bound := Type_High_Bound (Typ);
4335 -- We need the high bound of the base type later on, and this should
4336 -- always be compile time known. Again, it is not clear that this
4337 -- can ever be false, but no point in bombing.
4339 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4340 Hbound := Expr_Value (Type_High_Bound (Btyp));
4348 -- If we have a static subtype, then that may have a tighter bound so
4349 -- use the upper bound of the subtype instead in this case.
4351 if Compile_Time_Known_Value (Bound) then
4352 Hi := Expr_Value (Bound);
4355 -- We may be able to refine this value in certain situations. If any
4356 -- refinement is possible, then Lor and Hir are set to possibly tighter
4357 -- bounds, and OK1 is set to True.
4361 -- For unary plus, result is limited by range of operand
4365 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4367 -- For unary minus, determine range of operand, and negate it
4371 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4378 -- For binary addition, get range of each operand and do the
4379 -- addition to get the result range.
4383 Lor := Lo_Left + Lo_Right;
4384 Hir := Hi_Left + Hi_Right;
4387 -- Division is tricky. The only case we consider is where the right
4388 -- operand is a positive constant, and in this case we simply divide
4389 -- the bounds of the left operand
4393 if Lo_Right = Hi_Right
4394 and then Lo_Right > 0
4396 Lor := Lo_Left / Lo_Right;
4397 Hir := Hi_Left / Lo_Right;
4403 -- For binary subtraction, get range of each operand and do the worst
4404 -- case subtraction to get the result range.
4406 when N_Op_Subtract =>
4408 Lor := Lo_Left - Hi_Right;
4409 Hir := Hi_Left - Lo_Right;
4412 -- For MOD, if right operand is a positive constant, then result must
4413 -- be in the allowable range of mod results.
4417 if Lo_Right = Hi_Right
4418 and then Lo_Right /= 0
4420 if Lo_Right > 0 then
4422 Hir := Lo_Right - 1;
4424 else -- Lo_Right < 0
4425 Lor := Lo_Right + 1;
4434 -- For REM, if right operand is a positive constant, then result must
4435 -- be in the allowable range of mod results.
4439 if Lo_Right = Hi_Right
4440 and then Lo_Right /= 0
4443 Dval : constant Uint := (abs Lo_Right) - 1;
4446 -- The sign of the result depends on the sign of the
4447 -- dividend (but not on the sign of the divisor, hence
4448 -- the abs operation above).
4468 -- Attribute reference cases
4470 when N_Attribute_Reference =>
4471 case Attribute_Name (N) is
4473 -- For Pos/Val attributes, we can refine the range using the
4474 -- possible range of values of the attribute expression.
4476 when Name_Pos | Name_Val =>
4478 (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
4480 -- For Length attribute, use the bounds of the corresponding
4481 -- index type to refine the range.
4485 Atyp : Entity_Id := Etype (Prefix (N));
4493 if Is_Access_Type (Atyp) then
4494 Atyp := Designated_Type (Atyp);
4497 -- For string literal, we know exact value
4499 if Ekind (Atyp) = E_String_Literal_Subtype then
4501 Lo := String_Literal_Length (Atyp);
4502 Hi := String_Literal_Length (Atyp);
4506 -- Otherwise check for expression given
4508 if No (Expressions (N)) then
4512 UI_To_Int (Expr_Value (First (Expressions (N))));
4515 Indx := First_Index (Atyp);
4516 for J in 2 .. Inum loop
4517 Indx := Next_Index (Indx);
4520 -- If the index type is a formal type or derived from
4521 -- one, the bounds are not static.
4523 if Is_Generic_Type (Root_Type (Etype (Indx))) then
4529 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
4534 (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
4539 -- The maximum value for Length is the biggest
4540 -- possible gap between the values of the bounds.
4541 -- But of course, this value cannot be negative.
4543 Hir := UI_Max (Uint_0, UU - LL + 1);
4545 -- For constrained arrays, the minimum value for
4546 -- Length is taken from the actual value of the
4547 -- bounds, since the index will be exactly of this
4550 if Is_Constrained (Atyp) then
4551 Lor := UI_Max (Uint_0, UL - LU + 1);
4553 -- For an unconstrained array, the minimum value
4554 -- for length is always zero.
4563 -- No special handling for other attributes
4564 -- Probably more opportunities exist here???
4571 -- For type conversion from one discrete type to another, we can
4572 -- refine the range using the converted value.
4574 when N_Type_Conversion =>
4575 Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
4577 -- Nothing special to do for all other expression kinds
4585 -- At this stage, if OK1 is true, then we know that the actual result of
4586 -- the computed expression is in the range Lor .. Hir. We can use this
4587 -- to restrict the possible range of results.
4591 -- If the refined value of the low bound is greater than the type
4592 -- low bound, then reset it to the more restrictive value. However,
4593 -- we do NOT do this for the case of a modular type where the
4594 -- possible upper bound on the value is above the base type high
4595 -- bound, because that means the result could wrap.
4598 and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound)
4603 -- Similarly, if the refined value of the high bound is less than the
4604 -- value so far, then reset it to the more restrictive value. Again,
4605 -- we do not do this if the refined low bound is negative for a
4606 -- modular type, since this would wrap.
4609 and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0)
4615 -- Set cache entry for future call and we are all done
4617 Determine_Range_Cache_N (Cindex) := N;
4618 Determine_Range_Cache_V (Cindex) := Assume_Valid;
4619 Determine_Range_Cache_Lo (Cindex) := Lo;
4620 Determine_Range_Cache_Hi (Cindex) := Hi;
4623 -- If any exception occurs, it means that we have some bug in the compiler,
4624 -- possibly triggered by a previous error, or by some unforeseen peculiar
4625 -- occurrence. However, this is only an optimization attempt, so there is
4626 -- really no point in crashing the compiler. Instead we just decide, too
4627 -- bad, we can't figure out a range in this case after all.
4632 -- Debug flag K disables this behavior (useful for debugging)
4634 if Debug_Flag_K then
4642 end Determine_Range;
4644 -----------------------
4645 -- Determine_Range_R --
4646 -----------------------
4648 procedure Determine_Range_R
4653 Assume_Valid : Boolean := False)
4655 Typ : Entity_Id := Etype (N);
4656 -- Type to use, may get reset to base type for possibly invalid entity
4660 -- Lo and Hi bounds of left operand
4664 -- Lo and Hi bounds of right (or only) operand
4667 -- Temp variable used to hold a bound node
4670 -- High bound of base type of expression
4674 -- Refined values for low and high bounds, after tightening
4677 -- Used in lower level calls to indicate if call succeeded
4679 Cindex : Cache_Index;
4680 -- Used to search cache
4685 function OK_Operands return Boolean;
4686 -- Used for binary operators. Determines the ranges of the left and
4687 -- right operands, and if they are both OK, returns True, and puts
4688 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4690 function Round_Machine (B : Ureal) return Ureal;
4691 -- B is a real bound. Round it using mode Round_Even.
4697 function OK_Operands return Boolean is
4700 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4707 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4715 function Round_Machine (B : Ureal) return Ureal is
4717 return Machine (Typ, B, Round_Even, N);
4720 -- Start of processing for Determine_Range_R
4723 -- Prevent junk warnings by initializing range variables
4730 -- For temporary constants internally generated to remove side effects
4731 -- we must use the corresponding expression to determine the range of
4732 -- the expression. But note that the expander can also generate
4733 -- constants in other cases, including deferred constants.
4735 if Is_Entity_Name (N)
4736 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4737 and then Ekind (Entity (N)) = E_Constant
4738 and then Is_Internal_Name (Chars (Entity (N)))
4740 if Present (Expression (Parent (Entity (N)))) then
4742 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4744 elsif Present (Full_View (Entity (N))) then
4746 (Expression (Parent (Full_View (Entity (N)))),
4747 OK, Lo, Hi, Assume_Valid);
4756 -- If type is not defined, we can't determine its range
4760 -- We don't deal with anything except IEEE floating-point types
4762 or else not Is_Floating_Point_Type (Typ)
4763 or else Float_Rep (Typ) /= IEEE_Binary
4765 -- Ignore type for which an error has been posted, since range in
4766 -- this case may well be a bogosity deriving from the error. Also
4767 -- ignore if error posted on the reference node.
4769 or else Error_Posted (N) or else Error_Posted (Typ)
4775 -- For all other cases, we can determine the range
4779 -- If value is compile time known, then the possible range is the one
4780 -- value that we know this expression definitely has.
4782 if Compile_Time_Known_Value (N) then
4783 Lo := Expr_Value_R (N);
4788 -- Return if already in the cache
4790 Cindex := Cache_Index (N mod Cache_Size);
4792 if Determine_Range_Cache_N (Cindex) = N
4794 Determine_Range_Cache_V (Cindex) = Assume_Valid
4796 Lo := Determine_Range_Cache_Lo_R (Cindex);
4797 Hi := Determine_Range_Cache_Hi_R (Cindex);
4801 -- Otherwise, start by finding the bounds of the type of the expression,
4802 -- the value cannot be outside this range (if it is, then we have an
4803 -- overflow situation, which is a separate check, we are talking here
4804 -- only about the expression value).
4806 -- First a check, never try to find the bounds of a generic type, since
4807 -- these bounds are always junk values, and it is only valid to look at
4808 -- the bounds in an instance.
4810 if Is_Generic_Type (Typ) then
4815 -- First step, change to use base type unless we know the value is valid
4817 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4818 or else Assume_No_Invalid_Values
4819 or else Assume_Valid
4823 Typ := Underlying_Type (Base_Type (Typ));
4826 -- Retrieve the base type. Handle the case where the base type is a
4829 Btyp := Base_Type (Typ);
4831 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4832 Btyp := Full_View (Btyp);
4835 -- We use the actual bound unless it is dynamic, in which case use the
4836 -- corresponding base type bound if possible. If we can't get a bound
4837 -- then we figure we can't determine the range (a peculiar case, that
4838 -- perhaps cannot happen, but there is no point in bombing in this
4839 -- optimization circuit).
4841 -- First the low bound
4843 Bound := Type_Low_Bound (Typ);
4845 if Compile_Time_Known_Value (Bound) then
4846 Lo := Expr_Value_R (Bound);
4848 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4849 Lo := Expr_Value_R (Type_Low_Bound (Btyp));
4856 -- Now the high bound
4858 Bound := Type_High_Bound (Typ);
4860 -- We need the high bound of the base type later on, and this should
4861 -- always be compile time known. Again, it is not clear that this
4862 -- can ever be false, but no point in bombing.
4864 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4865 Hbound := Expr_Value_R (Type_High_Bound (Btyp));
4873 -- If we have a static subtype, then that may have a tighter bound so
4874 -- use the upper bound of the subtype instead in this case.
4876 if Compile_Time_Known_Value (Bound) then
4877 Hi := Expr_Value_R (Bound);
4880 -- We may be able to refine this value in certain situations. If any
4881 -- refinement is possible, then Lor and Hir are set to possibly tighter
4882 -- bounds, and OK1 is set to True.
4886 -- For unary plus, result is limited by range of operand
4890 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4892 -- For unary minus, determine range of operand, and negate it
4896 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4903 -- For binary addition, get range of each operand and do the
4904 -- addition to get the result range.
4908 Lor := Round_Machine (Lo_Left + Lo_Right);
4909 Hir := Round_Machine (Hi_Left + Hi_Right);
4912 -- For binary subtraction, get range of each operand and do the worst
4913 -- case subtraction to get the result range.
4915 when N_Op_Subtract =>
4917 Lor := Round_Machine (Lo_Left - Hi_Right);
4918 Hir := Round_Machine (Hi_Left - Lo_Right);
4921 -- For multiplication, get range of each operand and do the
4922 -- four multiplications to get the result range.
4924 when N_Op_Multiply =>
4927 M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
4928 M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
4929 M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
4930 M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
4932 Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
4933 Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
4937 -- For division, consider separately the cases where the right
4938 -- operand is positive or negative. Otherwise, the right operand
4939 -- can be arbitrarily close to zero, so the result is likely to
4940 -- be unbounded in one direction, do not attempt to compute it.
4945 -- Right operand is positive
4947 if Lo_Right > Ureal_0 then
4949 -- If the low bound of the left operand is negative, obtain
4950 -- the overall low bound by dividing it by the smallest
4951 -- value of the right operand, and otherwise by the largest
4952 -- value of the right operand.
4954 if Lo_Left < Ureal_0 then
4955 Lor := Round_Machine (Lo_Left / Lo_Right);
4957 Lor := Round_Machine (Lo_Left / Hi_Right);
4960 -- If the high bound of the left operand is negative, obtain
4961 -- the overall high bound by dividing it by the largest
4962 -- value of the right operand, and otherwise by the
4963 -- smallest value of the right operand.
4965 if Hi_Left < Ureal_0 then
4966 Hir := Round_Machine (Hi_Left / Hi_Right);
4968 Hir := Round_Machine (Hi_Left / Lo_Right);
4971 -- Right operand is negative
4973 elsif Hi_Right < Ureal_0 then
4975 -- If the low bound of the left operand is negative, obtain
4976 -- the overall low bound by dividing it by the largest
4977 -- value of the right operand, and otherwise by the smallest
4978 -- value of the right operand.
4980 if Lo_Left < Ureal_0 then
4981 Lor := Round_Machine (Lo_Left / Hi_Right);
4983 Lor := Round_Machine (Lo_Left / Lo_Right);
4986 -- If the high bound of the left operand is negative, obtain
4987 -- the overall high bound by dividing it by the smallest
4988 -- value of the right operand, and otherwise by the
4989 -- largest value of the right operand.
4991 if Hi_Left < Ureal_0 then
4992 Hir := Round_Machine (Hi_Left / Lo_Right);
4994 Hir := Round_Machine (Hi_Left / Hi_Right);
5002 -- For type conversion from one floating-point type to another, we
5003 -- can refine the range using the converted value.
5005 when N_Type_Conversion =>
5006 Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
5008 -- Nothing special to do for all other expression kinds
5016 -- At this stage, if OK1 is true, then we know that the actual result of
5017 -- the computed expression is in the range Lor .. Hir. We can use this
5018 -- to restrict the possible range of results.
5022 -- If the refined value of the low bound is greater than the type
5023 -- low bound, then reset it to the more restrictive value.
5029 -- Similarly, if the refined value of the high bound is less than the
5030 -- value so far, then reset it to the more restrictive value.
5037 -- Set cache entry for future call and we are all done
5039 Determine_Range_Cache_N (Cindex) := N;
5040 Determine_Range_Cache_V (Cindex) := Assume_Valid;
5041 Determine_Range_Cache_Lo_R (Cindex) := Lo;
5042 Determine_Range_Cache_Hi_R (Cindex) := Hi;
5045 -- If any exception occurs, it means that we have some bug in the compiler,
5046 -- possibly triggered by a previous error, or by some unforeseen peculiar
5047 -- occurrence. However, this is only an optimization attempt, so there is
5048 -- really no point in crashing the compiler. Instead we just decide, too
5049 -- bad, we can't figure out a range in this case after all.
5054 -- Debug flag K disables this behavior (useful for debugging)
5056 if Debug_Flag_K then
5064 end Determine_Range_R;
5066 ------------------------------------
5067 -- Discriminant_Checks_Suppressed --
5068 ------------------------------------
5070 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
5073 if Is_Unchecked_Union (E) then
5075 elsif Checks_May_Be_Suppressed (E) then
5076 return Is_Check_Suppressed (E, Discriminant_Check);
5080 return Scope_Suppress.Suppress (Discriminant_Check);
5081 end Discriminant_Checks_Suppressed;
5083 --------------------------------
5084 -- Division_Checks_Suppressed --
5085 --------------------------------
5087 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
5089 if Present (E) and then Checks_May_Be_Suppressed (E) then
5090 return Is_Check_Suppressed (E, Division_Check);
5092 return Scope_Suppress.Suppress (Division_Check);
5094 end Division_Checks_Suppressed;
5096 --------------------------------------
5097 -- Duplicated_Tag_Checks_Suppressed --
5098 --------------------------------------
5100 function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
5102 if Present (E) and then Checks_May_Be_Suppressed (E) then
5103 return Is_Check_Suppressed (E, Duplicated_Tag_Check);
5105 return Scope_Suppress.Suppress (Duplicated_Tag_Check);
5107 end Duplicated_Tag_Checks_Suppressed;
5109 -----------------------------------
5110 -- Elaboration_Checks_Suppressed --
5111 -----------------------------------
5113 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
5115 -- The complication in this routine is that if we are in the dynamic
5116 -- model of elaboration, we also check All_Checks, since All_Checks
5117 -- does not set Elaboration_Check explicitly.
5120 if Kill_Elaboration_Checks (E) then
5123 elsif Checks_May_Be_Suppressed (E) then
5124 if Is_Check_Suppressed (E, Elaboration_Check) then
5126 elsif Dynamic_Elaboration_Checks then
5127 return Is_Check_Suppressed (E, All_Checks);
5134 if Scope_Suppress.Suppress (Elaboration_Check) then
5136 elsif Dynamic_Elaboration_Checks then
5137 return Scope_Suppress.Suppress (All_Checks);
5141 end Elaboration_Checks_Suppressed;
5143 ---------------------------
5144 -- Enable_Overflow_Check --
5145 ---------------------------
5147 procedure Enable_Overflow_Check (N : Node_Id) is
5148 Typ : constant Entity_Id := Base_Type (Etype (N));
5149 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
5157 Do_Ovflow_Check : Boolean;
5160 if Debug_Flag_CC then
5161 w ("Enable_Overflow_Check for node ", Int (N));
5162 Write_Str (" Source location = ");
5167 -- No check if overflow checks suppressed for type of node
5169 if Overflow_Checks_Suppressed (Etype (N)) then
5172 -- Nothing to do for unsigned integer types, which do not overflow
5174 elsif Is_Modular_Integer_Type (Typ) then
5178 -- This is the point at which processing for STRICT mode diverges
5179 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5180 -- probably more extreme that it needs to be, but what is going on here
5181 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5182 -- to leave the processing for STRICT mode untouched. There were
5183 -- two reasons for this. First it avoided any incompatible change of
5184 -- behavior. Second, it guaranteed that STRICT mode continued to be
5187 -- The big difference is that in STRICT mode there is a fair amount of
5188 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5189 -- know that no check is needed. We skip all that in the two new modes,
5190 -- since really overflow checking happens over a whole subtree, and we
5191 -- do the corresponding optimizations later on when applying the checks.
5193 if Mode in Minimized_Or_Eliminated then
5194 if not (Overflow_Checks_Suppressed (Etype (N)))
5195 and then not (Is_Entity_Name (N)
5196 and then Overflow_Checks_Suppressed (Entity (N)))
5198 Activate_Overflow_Check (N);
5201 if Debug_Flag_CC then
5202 w ("Minimized/Eliminated mode");
5208 -- Remainder of processing is for STRICT case, and is unchanged from
5209 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5211 -- Nothing to do if the range of the result is known OK. We skip this
5212 -- for conversions, since the caller already did the check, and in any
5213 -- case the condition for deleting the check for a type conversion is
5216 if Nkind (N) /= N_Type_Conversion then
5217 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
5219 -- Note in the test below that we assume that the range is not OK
5220 -- if a bound of the range is equal to that of the type. That's not
5221 -- quite accurate but we do this for the following reasons:
5223 -- a) The way that Determine_Range works, it will typically report
5224 -- the bounds of the value as being equal to the bounds of the
5225 -- type, because it either can't tell anything more precise, or
5226 -- does not think it is worth the effort to be more precise.
5228 -- b) It is very unusual to have a situation in which this would
5229 -- generate an unnecessary overflow check (an example would be
5230 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5231 -- literal value one is added).
5233 -- c) The alternative is a lot of special casing in this routine
5234 -- which would partially duplicate Determine_Range processing.
5237 Do_Ovflow_Check := True;
5239 -- Note that the following checks are quite deliberately > and <
5240 -- rather than >= and <= as explained above.
5242 if Lo > Expr_Value (Type_Low_Bound (Typ))
5244 Hi < Expr_Value (Type_High_Bound (Typ))
5246 Do_Ovflow_Check := False;
5248 -- Despite the comments above, it is worth dealing specially with
5249 -- division specially. The only case where integer division can
5250 -- overflow is (largest negative number) / (-1). So we will do
5251 -- an extra range analysis to see if this is possible.
5253 elsif Nkind (N) = N_Op_Divide then
5255 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5257 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then
5258 Do_Ovflow_Check := False;
5262 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5264 if OK and then (Lo > Uint_Minus_1
5268 Do_Ovflow_Check := False;
5273 -- If no overflow check required, we are done
5275 if not Do_Ovflow_Check then
5276 if Debug_Flag_CC then
5277 w ("No overflow check required");
5285 -- If not in optimizing mode, set flag and we are done. We are also done
5286 -- (and just set the flag) if the type is not a discrete type, since it
5287 -- is not worth the effort to eliminate checks for other than discrete
5288 -- types. In addition, we take this same path if we have stored the
5289 -- maximum number of checks possible already (a very unlikely situation,
5290 -- but we do not want to blow up).
5292 if Optimization_Level = 0
5293 or else not Is_Discrete_Type (Etype (N))
5294 or else Num_Saved_Checks = Saved_Checks'Last
5296 Activate_Overflow_Check (N);
5298 if Debug_Flag_CC then
5299 w ("Optimization off");
5305 -- Otherwise evaluate and check the expression
5310 Target_Type => Empty,
5316 if Debug_Flag_CC then
5317 w ("Called Find_Check");
5321 w (" Check_Num = ", Chk);
5322 w (" Ent = ", Int (Ent));
5323 Write_Str (" Ofs = ");
5328 -- If check is not of form to optimize, then set flag and we are done
5331 Activate_Overflow_Check (N);
5335 -- If check is already performed, then return without setting flag
5338 if Debug_Flag_CC then
5339 w ("Check suppressed!");
5345 -- Here we will make a new entry for the new check
5347 Activate_Overflow_Check (N);
5348 Num_Saved_Checks := Num_Saved_Checks + 1;
5349 Saved_Checks (Num_Saved_Checks) :=
5354 Target_Type => Empty);
5356 if Debug_Flag_CC then
5357 w ("Make new entry, check number = ", Num_Saved_Checks);
5358 w (" Entity = ", Int (Ent));
5359 Write_Str (" Offset = ");
5361 w (" Check_Type = O");
5362 w (" Target_Type = Empty");
5365 -- If we get an exception, then something went wrong, probably because of
5366 -- an error in the structure of the tree due to an incorrect program. Or
5367 -- it may be a bug in the optimization circuit. In either case the safest
5368 -- thing is simply to set the check flag unconditionally.
5372 Activate_Overflow_Check (N);
5374 if Debug_Flag_CC then
5375 w (" exception occurred, overflow flag set");
5379 end Enable_Overflow_Check;
5381 ------------------------
5382 -- Enable_Range_Check --
5383 ------------------------
5385 procedure Enable_Range_Check (N : Node_Id) is
5394 -- Return if unchecked type conversion with range check killed. In this
5395 -- case we never set the flag (that's what Kill_Range_Check is about).
5397 if Nkind (N) = N_Unchecked_Type_Conversion
5398 and then Kill_Range_Check (N)
5403 -- Do not set range check flag if parent is assignment statement or
5404 -- object declaration with Suppress_Assignment_Checks flag set
5406 if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
5407 and then Suppress_Assignment_Checks (Parent (N))
5412 -- Check for various cases where we should suppress the range check
5414 -- No check if range checks suppressed for type of node
5416 if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then
5419 -- No check if node is an entity name, and range checks are suppressed
5420 -- for this entity, or for the type of this entity.
5422 elsif Is_Entity_Name (N)
5423 and then (Range_Checks_Suppressed (Entity (N))
5424 or else Range_Checks_Suppressed (Etype (Entity (N))))
5428 -- No checks if index of array, and index checks are suppressed for
5429 -- the array object or the type of the array.
5431 elsif Nkind (Parent (N)) = N_Indexed_Component then
5433 Pref : constant Node_Id := Prefix (Parent (N));
5435 if Is_Entity_Name (Pref)
5436 and then Index_Checks_Suppressed (Entity (Pref))
5439 elsif Index_Checks_Suppressed (Etype (Pref)) then
5445 -- Debug trace output
5447 if Debug_Flag_CC then
5448 w ("Enable_Range_Check for node ", Int (N));
5449 Write_Str (" Source location = ");
5454 -- If not in optimizing mode, set flag and we are done. We are also done
5455 -- (and just set the flag) if the type is not a discrete type, since it
5456 -- is not worth the effort to eliminate checks for other than discrete
5457 -- types. In addition, we take this same path if we have stored the
5458 -- maximum number of checks possible already (a very unlikely situation,
5459 -- but we do not want to blow up).
5461 if Optimization_Level = 0
5462 or else No (Etype (N))
5463 or else not Is_Discrete_Type (Etype (N))
5464 or else Num_Saved_Checks = Saved_Checks'Last
5466 Activate_Range_Check (N);
5468 if Debug_Flag_CC then
5469 w ("Optimization off");
5475 -- Otherwise find out the target type
5479 -- For assignment, use left side subtype
5481 if Nkind (P) = N_Assignment_Statement
5482 and then Expression (P) = N
5484 Ttyp := Etype (Name (P));
5486 -- For indexed component, use subscript subtype
5488 elsif Nkind (P) = N_Indexed_Component then
5495 Atyp := Etype (Prefix (P));
5497 if Is_Access_Type (Atyp) then
5498 Atyp := Designated_Type (Atyp);
5500 -- If the prefix is an access to an unconstrained array,
5501 -- perform check unconditionally: it depends on the bounds of
5502 -- an object and we cannot currently recognize whether the test
5503 -- may be redundant.
5505 if not Is_Constrained (Atyp) then
5506 Activate_Range_Check (N);
5510 -- Ditto if the prefix is an explicit dereference whose designated
5511 -- type is unconstrained.
5513 elsif Nkind (Prefix (P)) = N_Explicit_Dereference
5514 and then not Is_Constrained (Atyp)
5516 Activate_Range_Check (N);
5520 Indx := First_Index (Atyp);
5521 Subs := First (Expressions (P));
5524 Ttyp := Etype (Indx);
5533 -- For now, ignore all other cases, they are not so interesting
5536 if Debug_Flag_CC then
5537 w (" target type not found, flag set");
5540 Activate_Range_Check (N);
5544 -- Evaluate and check the expression
5549 Target_Type => Ttyp,
5555 if Debug_Flag_CC then
5556 w ("Called Find_Check");
5557 w ("Target_Typ = ", Int (Ttyp));
5561 w (" Check_Num = ", Chk);
5562 w (" Ent = ", Int (Ent));
5563 Write_Str (" Ofs = ");
5568 -- If check is not of form to optimize, then set flag and we are done
5571 if Debug_Flag_CC then
5572 w (" expression not of optimizable type, flag set");
5575 Activate_Range_Check (N);
5579 -- If check is already performed, then return without setting flag
5582 if Debug_Flag_CC then
5583 w ("Check suppressed!");
5589 -- Here we will make a new entry for the new check
5591 Activate_Range_Check (N);
5592 Num_Saved_Checks := Num_Saved_Checks + 1;
5593 Saved_Checks (Num_Saved_Checks) :=
5598 Target_Type => Ttyp);
5600 if Debug_Flag_CC then
5601 w ("Make new entry, check number = ", Num_Saved_Checks);
5602 w (" Entity = ", Int (Ent));
5603 Write_Str (" Offset = ");
5605 w (" Check_Type = R");
5606 w (" Target_Type = ", Int (Ttyp));
5607 pg (Union_Id (Ttyp));
5610 -- If we get an exception, then something went wrong, probably because of
5611 -- an error in the structure of the tree due to an incorrect program. Or
5612 -- it may be a bug in the optimization circuit. In either case the safest
5613 -- thing is simply to set the check flag unconditionally.
5617 Activate_Range_Check (N);
5619 if Debug_Flag_CC then
5620 w (" exception occurred, range flag set");
5624 end Enable_Range_Check;
5630 procedure Ensure_Valid
5632 Holes_OK : Boolean := False;
5633 Related_Id : Entity_Id := Empty;
5634 Is_Low_Bound : Boolean := False;
5635 Is_High_Bound : Boolean := False)
5637 Typ : constant Entity_Id := Etype (Expr);
5640 -- Ignore call if we are not doing any validity checking
5642 if not Validity_Checks_On then
5645 -- Ignore call if range or validity checks suppressed on entity or type
5647 elsif Range_Or_Validity_Checks_Suppressed (Expr) then
5650 -- No check required if expression is from the expander, we assume the
5651 -- expander will generate whatever checks are needed. Note that this is
5652 -- not just an optimization, it avoids infinite recursions.
5654 -- Unchecked conversions must be checked, unless they are initialized
5655 -- scalar values, as in a component assignment in an init proc.
5657 -- In addition, we force a check if Force_Validity_Checks is set
5659 elsif not Comes_From_Source (Expr)
5660 and then not Force_Validity_Checks
5661 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
5662 or else Kill_Range_Check (Expr))
5666 -- No check required if expression is known to have valid value
5668 elsif Expr_Known_Valid (Expr) then
5671 -- Ignore case of enumeration with holes where the flag is set not to
5672 -- worry about holes, since no special validity check is needed
5674 elsif Is_Enumeration_Type (Typ)
5675 and then Has_Non_Standard_Rep (Typ)
5680 -- No check required on the left-hand side of an assignment
5682 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
5683 and then Expr = Name (Parent (Expr))
5687 -- No check on a universal real constant. The context will eventually
5688 -- convert it to a machine number for some target type, or report an
5691 elsif Nkind (Expr) = N_Real_Literal
5692 and then Etype (Expr) = Universal_Real
5696 -- If the expression denotes a component of a packed boolean array,
5697 -- no possible check applies. We ignore the old ACATS chestnuts that
5698 -- involve Boolean range True..True.
5700 -- Note: validity checks are generated for expressions that yield a
5701 -- scalar type, when it is possible to create a value that is outside of
5702 -- the type. If this is a one-bit boolean no such value exists. This is
5703 -- an optimization, and it also prevents compiler blowing up during the
5704 -- elaboration of improperly expanded packed array references.
5706 elsif Nkind (Expr) = N_Indexed_Component
5707 and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
5708 and then Root_Type (Etype (Expr)) = Standard_Boolean
5712 -- For an expression with actions, we want to insert the validity check
5713 -- on the final Expression.
5715 elsif Nkind (Expr) = N_Expression_With_Actions then
5716 Ensure_Valid (Expression (Expr));
5719 -- An annoying special case. If this is an out parameter of a scalar
5720 -- type, then the value is not going to be accessed, therefore it is
5721 -- inappropriate to do any validity check at the call site.
5724 -- Only need to worry about scalar types
5726 if Is_Scalar_Type (Typ) then
5736 -- Find actual argument (which may be a parameter association)
5737 -- and the parent of the actual argument (the call statement)
5742 if Nkind (P) = N_Parameter_Association then
5747 -- Only need to worry if we are argument of a procedure call
5748 -- since functions don't have out parameters. If this is an
5749 -- indirect or dispatching call, get signature from the
5752 if Nkind (P) = N_Procedure_Call_Statement then
5753 L := Parameter_Associations (P);
5755 if Is_Entity_Name (Name (P)) then
5756 E := Entity (Name (P));
5758 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
5759 E := Etype (Name (P));
5762 -- Only need to worry if there are indeed actuals, and if
5763 -- this could be a procedure call, otherwise we cannot get a
5764 -- match (either we are not an argument, or the mode of the
5765 -- formal is not OUT). This test also filters out the
5768 if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
5770 -- This is the loop through parameters, looking for an
5771 -- OUT parameter for which we are the argument.
5773 F := First_Formal (E);
5775 while Present (F) loop
5776 if Ekind (F) = E_Out_Parameter and then A = N then
5789 -- If this is a boolean expression, only its elementary operands need
5790 -- checking: if they are valid, a boolean or short-circuit operation
5791 -- with them will be valid as well.
5793 if Base_Type (Typ) = Standard_Boolean
5795 (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit)
5800 -- If we fall through, a validity check is required
5802 Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound);
5804 if Is_Entity_Name (Expr)
5805 and then Safe_To_Capture_Value (Expr, Entity (Expr))
5807 Set_Is_Known_Valid (Entity (Expr));
5811 ----------------------
5812 -- Expr_Known_Valid --
5813 ----------------------
5815 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
5816 Typ : constant Entity_Id := Etype (Expr);
5819 -- Non-scalar types are always considered valid, since they never give
5820 -- rise to the issues of erroneous or bounded error behavior that are
5821 -- the concern. In formal reference manual terms the notion of validity
5822 -- only applies to scalar types. Note that even when packed arrays are
5823 -- represented using modular types, they are still arrays semantically,
5824 -- so they are also always valid (in particular, the unused bits can be
5825 -- random rubbish without affecting the validity of the array value).
5827 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then
5830 -- If no validity checking, then everything is considered valid
5832 elsif not Validity_Checks_On then
5835 -- Floating-point types are considered valid unless floating-point
5836 -- validity checks have been specifically turned on.
5838 elsif Is_Floating_Point_Type (Typ)
5839 and then not Validity_Check_Floating_Point
5843 -- If the expression is the value of an object that is known to be
5844 -- valid, then clearly the expression value itself is valid.
5846 elsif Is_Entity_Name (Expr)
5847 and then Is_Known_Valid (Entity (Expr))
5849 -- Exclude volatile variables
5851 and then not Treat_As_Volatile (Entity (Expr))
5855 -- References to discriminants are always considered valid. The value
5856 -- of a discriminant gets checked when the object is built. Within the
5857 -- record, we consider it valid, and it is important to do so, since
5858 -- otherwise we can try to generate bogus validity checks which
5859 -- reference discriminants out of scope. Discriminants of concurrent
5860 -- types are excluded for the same reason.
5862 elsif Is_Entity_Name (Expr)
5863 and then Denotes_Discriminant (Expr, Check_Concurrent => True)
5867 -- If the type is one for which all values are known valid, then we are
5868 -- sure that the value is valid except in the slightly odd case where
5869 -- the expression is a reference to a variable whose size has been
5870 -- explicitly set to a value greater than the object size.
5872 elsif Is_Known_Valid (Typ) then
5873 if Is_Entity_Name (Expr)
5874 and then Ekind (Entity (Expr)) = E_Variable
5875 and then Esize (Entity (Expr)) > Esize (Typ)
5882 -- Integer and character literals always have valid values, where
5883 -- appropriate these will be range checked in any case.
5885 elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
5888 -- Real literals are assumed to be valid in VM targets
5890 elsif VM_Target /= No_VM and then Nkind (Expr) = N_Real_Literal then
5893 -- If we have a type conversion or a qualification of a known valid
5894 -- value, then the result will always be valid.
5896 elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
5897 return Expr_Known_Valid (Expression (Expr));
5899 -- Case of expression is a non-floating-point operator. In this case we
5900 -- can assume the result is valid the generated code for the operator
5901 -- will include whatever checks are needed (e.g. range checks) to ensure
5902 -- validity. This assumption does not hold for the floating-point case,
5903 -- since floating-point operators can generate Infinite or NaN results
5904 -- which are considered invalid.
5906 -- Historical note: in older versions, the exemption of floating-point
5907 -- types from this assumption was done only in cases where the parent
5908 -- was an assignment, function call or parameter association. Presumably
5909 -- the idea was that in other contexts, the result would be checked
5910 -- elsewhere, but this list of cases was missing tests (at least the
5911 -- N_Object_Declaration case, as shown by a reported missing validity
5912 -- check), and it is not clear why function calls but not procedure
5913 -- calls were tested for. It really seems more accurate and much
5914 -- safer to recognize that expressions which are the result of a
5915 -- floating-point operator can never be assumed to be valid.
5917 elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then
5920 -- The result of a membership test is always valid, since it is true or
5921 -- false, there are no other possibilities.
5923 elsif Nkind (Expr) in N_Membership_Test then
5926 -- For all other cases, we do not know the expression is valid
5931 end Expr_Known_Valid;
5937 procedure Find_Check
5939 Check_Type : Character;
5940 Target_Type : Entity_Id;
5941 Entry_OK : out Boolean;
5942 Check_Num : out Nat;
5943 Ent : out Entity_Id;
5946 function Within_Range_Of
5947 (Target_Type : Entity_Id;
5948 Check_Type : Entity_Id) return Boolean;
5949 -- Given a requirement for checking a range against Target_Type, and
5950 -- and a range Check_Type against which a check has already been made,
5951 -- determines if the check against check type is sufficient to ensure
5952 -- that no check against Target_Type is required.
5954 ---------------------
5955 -- Within_Range_Of --
5956 ---------------------
5958 function Within_Range_Of
5959 (Target_Type : Entity_Id;
5960 Check_Type : Entity_Id) return Boolean
5963 if Target_Type = Check_Type then
5968 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
5969 Thi : constant Node_Id := Type_High_Bound (Target_Type);
5970 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
5971 Chi : constant Node_Id := Type_High_Bound (Check_Type);
5975 or else (Compile_Time_Known_Value (Tlo)
5977 Compile_Time_Known_Value (Clo)
5979 Expr_Value (Clo) >= Expr_Value (Tlo)))
5982 or else (Compile_Time_Known_Value (Thi)
5984 Compile_Time_Known_Value (Chi)
5986 Expr_Value (Chi) <= Expr_Value (Clo)))
5994 end Within_Range_Of;
5996 -- Start of processing for Find_Check
5999 -- Establish default, in case no entry is found
6003 -- Case of expression is simple entity reference
6005 if Is_Entity_Name (Expr) then
6006 Ent := Entity (Expr);
6009 -- Case of expression is entity + known constant
6011 elsif Nkind (Expr) = N_Op_Add
6012 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6013 and then Is_Entity_Name (Left_Opnd (Expr))
6015 Ent := Entity (Left_Opnd (Expr));
6016 Ofs := Expr_Value (Right_Opnd (Expr));
6018 -- Case of expression is entity - known constant
6020 elsif Nkind (Expr) = N_Op_Subtract
6021 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6022 and then Is_Entity_Name (Left_Opnd (Expr))
6024 Ent := Entity (Left_Opnd (Expr));
6025 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
6027 -- Any other expression is not of the right form
6036 -- Come here with expression of appropriate form, check if entity is an
6037 -- appropriate one for our purposes.
6039 if (Ekind (Ent) = E_Variable
6040 or else Is_Constant_Object (Ent))
6041 and then not Is_Library_Level_Entity (Ent)
6049 -- See if there is matching check already
6051 for J in reverse 1 .. Num_Saved_Checks loop
6053 SC : Saved_Check renames Saved_Checks (J);
6055 if SC.Killed = False
6056 and then SC.Entity = Ent
6057 and then SC.Offset = Ofs
6058 and then SC.Check_Type = Check_Type
6059 and then Within_Range_Of (Target_Type, SC.Target_Type)
6067 -- If we fall through entry was not found
6072 ---------------------------------
6073 -- Generate_Discriminant_Check --
6074 ---------------------------------
6076 -- Note: the code for this procedure is derived from the
6077 -- Emit_Discriminant_Check Routine in trans.c.
6079 procedure Generate_Discriminant_Check (N : Node_Id) is
6080 Loc : constant Source_Ptr := Sloc (N);
6081 Pref : constant Node_Id := Prefix (N);
6082 Sel : constant Node_Id := Selector_Name (N);
6084 Orig_Comp : constant Entity_Id :=
6085 Original_Record_Component (Entity (Sel));
6086 -- The original component to be checked
6088 Discr_Fct : constant Entity_Id :=
6089 Discriminant_Checking_Func (Orig_Comp);
6090 -- The discriminant checking function
6093 -- One discriminant to be checked in the type
6095 Real_Discr : Entity_Id;
6096 -- Actual discriminant in the call
6098 Pref_Type : Entity_Id;
6099 -- Type of relevant prefix (ignoring private/access stuff)
6102 -- List of arguments for function call
6105 -- Keep track of the formal corresponding to the actual we build for
6106 -- each discriminant, in order to be able to perform the necessary type
6110 -- Selected component reference for checking function argument
6113 Pref_Type := Etype (Pref);
6115 -- Force evaluation of the prefix, so that it does not get evaluated
6116 -- twice (once for the check, once for the actual reference). Such a
6117 -- double evaluation is always a potential source of inefficiency, and
6118 -- is functionally incorrect in the volatile case, or when the prefix
6119 -- may have side-effects. A non-volatile entity or a component of a
6120 -- non-volatile entity requires no evaluation.
6122 if Is_Entity_Name (Pref) then
6123 if Treat_As_Volatile (Entity (Pref)) then
6124 Force_Evaluation (Pref, Name_Req => True);
6127 elsif Treat_As_Volatile (Etype (Pref)) then
6128 Force_Evaluation (Pref, Name_Req => True);
6130 elsif Nkind (Pref) = N_Selected_Component
6131 and then Is_Entity_Name (Prefix (Pref))
6136 Force_Evaluation (Pref, Name_Req => True);
6139 -- For a tagged type, use the scope of the original component to
6140 -- obtain the type, because ???
6142 if Is_Tagged_Type (Scope (Orig_Comp)) then
6143 Pref_Type := Scope (Orig_Comp);
6145 -- For an untagged derived type, use the discriminants of the parent
6146 -- which have been renamed in the derivation, possibly by a one-to-many
6147 -- discriminant constraint. For untagged type, initially get the Etype
6151 if Is_Derived_Type (Pref_Type)
6152 and then Number_Discriminants (Pref_Type) /=
6153 Number_Discriminants (Etype (Base_Type (Pref_Type)))
6155 Pref_Type := Etype (Base_Type (Pref_Type));
6159 -- We definitely should have a checking function, This routine should
6160 -- not be called if no discriminant checking function is present.
6162 pragma Assert (Present (Discr_Fct));
6164 -- Create the list of the actual parameters for the call. This list
6165 -- is the list of the discriminant fields of the record expression to
6166 -- be discriminant checked.
6169 Formal := First_Formal (Discr_Fct);
6170 Discr := First_Discriminant (Pref_Type);
6171 while Present (Discr) loop
6173 -- If we have a corresponding discriminant field, and a parent
6174 -- subtype is present, then we want to use the corresponding
6175 -- discriminant since this is the one with the useful value.
6177 if Present (Corresponding_Discriminant (Discr))
6178 and then Ekind (Pref_Type) = E_Record_Type
6179 and then Present (Parent_Subtype (Pref_Type))
6181 Real_Discr := Corresponding_Discriminant (Discr);
6183 Real_Discr := Discr;
6186 -- Construct the reference to the discriminant
6189 Make_Selected_Component (Loc,
6191 Unchecked_Convert_To (Pref_Type,
6192 Duplicate_Subexpr (Pref)),
6193 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
6195 -- Manually analyze and resolve this selected component. We really
6196 -- want it just as it appears above, and do not want the expander
6197 -- playing discriminal games etc with this reference. Then we append
6198 -- the argument to the list we are gathering.
6200 Set_Etype (Scomp, Etype (Real_Discr));
6201 Set_Analyzed (Scomp, True);
6202 Append_To (Args, Convert_To (Etype (Formal), Scomp));
6204 Next_Formal_With_Extras (Formal);
6205 Next_Discriminant (Discr);
6208 -- Now build and insert the call
6211 Make_Raise_Constraint_Error (Loc,
6213 Make_Function_Call (Loc,
6214 Name => New_Occurrence_Of (Discr_Fct, Loc),
6215 Parameter_Associations => Args),
6216 Reason => CE_Discriminant_Check_Failed));
6217 end Generate_Discriminant_Check;
6219 ---------------------------
6220 -- Generate_Index_Checks --
6221 ---------------------------
6223 procedure Generate_Index_Checks (N : Node_Id) is
6225 function Entity_Of_Prefix return Entity_Id;
6226 -- Returns the entity of the prefix of N (or Empty if not found)
6228 ----------------------
6229 -- Entity_Of_Prefix --
6230 ----------------------
6232 function Entity_Of_Prefix return Entity_Id is
6237 while not Is_Entity_Name (P) loop
6238 if not Nkind_In (P, N_Selected_Component,
6239 N_Indexed_Component)
6248 end Entity_Of_Prefix;
6252 Loc : constant Source_Ptr := Sloc (N);
6253 A : constant Node_Id := Prefix (N);
6254 A_Ent : constant Entity_Id := Entity_Of_Prefix;
6257 -- Start of processing for Generate_Index_Checks
6260 -- Ignore call if the prefix is not an array since we have a serious
6261 -- error in the sources. Ignore it also if index checks are suppressed
6262 -- for array object or type.
6264 if not Is_Array_Type (Etype (A))
6265 or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent))
6266 or else Index_Checks_Suppressed (Etype (A))
6270 -- The indexed component we are dealing with contains 'Loop_Entry in its
6271 -- prefix. This case arises when analysis has determined that constructs
6274 -- Prefix'Loop_Entry (Expr)
6275 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6277 -- require rewriting for error detection purposes. A side effect of this
6278 -- action is the generation of index checks that mention 'Loop_Entry.
6279 -- Delay the generation of the check until 'Loop_Entry has been properly
6280 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6282 elsif Nkind (Prefix (N)) = N_Attribute_Reference
6283 and then Attribute_Name (Prefix (N)) = Name_Loop_Entry
6288 -- Generate a raise of constraint error with the appropriate reason and
6289 -- a condition of the form:
6291 -- Base_Type (Sub) not in Array'Range (Subscript)
6293 -- Note that the reason we generate the conversion to the base type here
6294 -- is that we definitely want the range check to take place, even if it
6295 -- looks like the subtype is OK. Optimization considerations that allow
6296 -- us to omit the check have already been taken into account in the
6297 -- setting of the Do_Range_Check flag earlier on.
6299 Sub := First (Expressions (N));
6301 -- Handle string literals
6303 if Ekind (Etype (A)) = E_String_Literal_Subtype then
6304 if Do_Range_Check (Sub) then
6305 Set_Do_Range_Check (Sub, False);
6307 -- For string literals we obtain the bounds of the string from the
6308 -- associated subtype.
6311 Make_Raise_Constraint_Error (Loc,
6315 Convert_To (Base_Type (Etype (Sub)),
6316 Duplicate_Subexpr_Move_Checks (Sub)),
6318 Make_Attribute_Reference (Loc,
6319 Prefix => New_Occurrence_Of (Etype (A), Loc),
6320 Attribute_Name => Name_Range)),
6321 Reason => CE_Index_Check_Failed));
6328 A_Idx : Node_Id := Empty;
6335 A_Idx := First_Index (Etype (A));
6337 while Present (Sub) loop
6338 if Do_Range_Check (Sub) then
6339 Set_Do_Range_Check (Sub, False);
6341 -- Force evaluation except for the case of a simple name of
6342 -- a non-volatile entity.
6344 if not Is_Entity_Name (Sub)
6345 or else Treat_As_Volatile (Entity (Sub))
6347 Force_Evaluation (Sub);
6350 if Nkind (A_Idx) = N_Range then
6353 elsif Nkind (A_Idx) = N_Identifier
6354 or else Nkind (A_Idx) = N_Expanded_Name
6356 A_Range := Scalar_Range (Entity (A_Idx));
6358 else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication);
6359 A_Range := Range_Expression (Constraint (A_Idx));
6362 -- For array objects with constant bounds we can generate
6363 -- the index check using the bounds of the type of the index
6366 and then Ekind (A_Ent) = E_Variable
6367 and then Is_Constant_Bound (Low_Bound (A_Range))
6368 and then Is_Constant_Bound (High_Bound (A_Range))
6371 Make_Attribute_Reference (Loc,
6373 New_Occurrence_Of (Etype (A_Idx), Loc),
6374 Attribute_Name => Name_Range);
6376 -- For arrays with non-constant bounds we cannot generate
6377 -- the index check using the bounds of the type of the index
6378 -- since it may reference discriminants of some enclosing
6379 -- type. We obtain the bounds directly from the prefix
6386 Num := New_List (Make_Integer_Literal (Loc, Ind));
6390 Make_Attribute_Reference (Loc,
6392 Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
6393 Attribute_Name => Name_Range,
6394 Expressions => Num);
6398 Make_Raise_Constraint_Error (Loc,
6402 Convert_To (Base_Type (Etype (Sub)),
6403 Duplicate_Subexpr_Move_Checks (Sub)),
6404 Right_Opnd => Range_N),
6405 Reason => CE_Index_Check_Failed));
6408 A_Idx := Next_Index (A_Idx);
6414 end Generate_Index_Checks;
6416 --------------------------
6417 -- Generate_Range_Check --
6418 --------------------------
6420 procedure Generate_Range_Check
6422 Target_Type : Entity_Id;
6423 Reason : RT_Exception_Code)
6425 Loc : constant Source_Ptr := Sloc (N);
6426 Source_Type : constant Entity_Id := Etype (N);
6427 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
6428 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
6430 procedure Convert_And_Check_Range;
6431 -- Convert the conversion operand to the target base type and save in
6432 -- a temporary. Then check the converted value against the range of the
6435 -----------------------------
6436 -- Convert_And_Check_Range --
6437 -----------------------------
6439 procedure Convert_And_Check_Range is
6440 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6443 -- We make a temporary to hold the value of the converted value
6444 -- (converted to the base type), and then do the test against this
6445 -- temporary. The conversion itself is replaced by an occurrence of
6446 -- Tnn and followed by the explicit range check. Note that checks
6447 -- are suppressed for this code, since we don't want a recursive
6448 -- range check popping up.
6450 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6451 -- [constraint_error when Tnn not in Target_Type]
6453 Insert_Actions (N, New_List (
6454 Make_Object_Declaration (Loc,
6455 Defining_Identifier => Tnn,
6456 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
6457 Constant_Present => True,
6459 Make_Type_Conversion (Loc,
6460 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
6461 Expression => Duplicate_Subexpr (N))),
6463 Make_Raise_Constraint_Error (Loc,
6466 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6467 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6469 Suppress => All_Checks);
6471 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6473 -- Set the type of N, because the declaration for Tnn might not
6474 -- be analyzed yet, as is the case if N appears within a record
6475 -- declaration, as a discriminant constraint or expression.
6477 Set_Etype (N, Target_Base_Type);
6478 end Convert_And_Check_Range;
6480 -- Start of processing for Generate_Range_Check
6483 -- First special case, if the source type is already within the range
6484 -- of the target type, then no check is needed (probably we should have
6485 -- stopped Do_Range_Check from being set in the first place, but better
6486 -- late than never in preventing junk code and junk flag settings.
6488 if In_Subrange_Of (Source_Type, Target_Type)
6490 -- We do NOT apply this if the source node is a literal, since in this
6491 -- case the literal has already been labeled as having the subtype of
6495 (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal)
6498 and then Ekind (Entity (N)) = E_Enumeration_Literal))
6500 Set_Do_Range_Check (N, False);
6504 -- Here a check is needed. If the expander is not active, or if we are
6505 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6506 -- are done. In both these cases, we just want to see the range check
6507 -- flag set, we do not want to generate the explicit range check code.
6509 if GNATprove_Mode or else not Expander_Active then
6510 Set_Do_Range_Check (N, True);
6514 -- Here we will generate an explicit range check, so we don't want to
6515 -- set the Do_Range check flag, since the range check is taken care of
6516 -- by the code we will generate.
6518 Set_Do_Range_Check (N, False);
6520 -- Force evaluation of the node, so that it does not get evaluated twice
6521 -- (once for the check, once for the actual reference). Such a double
6522 -- evaluation is always a potential source of inefficiency, and is
6523 -- functionally incorrect in the volatile case.
6525 if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then
6526 Force_Evaluation (N);
6529 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6530 -- the same since in this case we can simply do a direct check of the
6531 -- value of N against the bounds of Target_Type.
6533 -- [constraint_error when N not in Target_Type]
6535 -- Note: this is by far the most common case, for example all cases of
6536 -- checks on the RHS of assignments are in this category, but not all
6537 -- cases are like this. Notably conversions can involve two types.
6539 if Source_Base_Type = Target_Base_Type then
6541 -- Insert the explicit range check. Note that we suppress checks for
6542 -- this code, since we don't want a recursive range check popping up.
6545 Make_Raise_Constraint_Error (Loc,
6548 Left_Opnd => Duplicate_Subexpr (N),
6549 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6551 Suppress => All_Checks);
6553 -- Next test for the case where the target type is within the bounds
6554 -- of the base type of the source type, since in this case we can
6555 -- simply convert these bounds to the base type of T to do the test.
6557 -- [constraint_error when N not in
6558 -- Source_Base_Type (Target_Type'First)
6560 -- Source_Base_Type(Target_Type'Last))]
6562 -- The conversions will always work and need no check
6564 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6565 -- of converting from an enumeration value to an integer type, such as
6566 -- occurs for the case of generating a range check on Enum'Val(Exp)
6567 -- (which used to be handled by gigi). This is OK, since the conversion
6568 -- itself does not require a check.
6570 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
6572 -- Insert the explicit range check. Note that we suppress checks for
6573 -- this code, since we don't want a recursive range check popping up.
6575 if Is_Discrete_Type (Source_Base_Type)
6577 Is_Discrete_Type (Target_Base_Type)
6580 Make_Raise_Constraint_Error (Loc,
6583 Left_Opnd => Duplicate_Subexpr (N),
6588 Unchecked_Convert_To (Source_Base_Type,
6589 Make_Attribute_Reference (Loc,
6591 New_Occurrence_Of (Target_Type, Loc),
6592 Attribute_Name => Name_First)),
6595 Unchecked_Convert_To (Source_Base_Type,
6596 Make_Attribute_Reference (Loc,
6598 New_Occurrence_Of (Target_Type, Loc),
6599 Attribute_Name => Name_Last)))),
6601 Suppress => All_Checks);
6603 -- For conversions involving at least one type that is not discrete,
6604 -- first convert to target type and then generate the range check.
6605 -- This avoids problems with values that are close to a bound of the
6606 -- target type that would fail a range check when done in a larger
6607 -- source type before converting but would pass if converted with
6608 -- rounding and then checked (such as in float-to-float conversions).
6611 Convert_And_Check_Range;
6614 -- Note that at this stage we now that the Target_Base_Type is not in
6615 -- the range of the Source_Base_Type (since even the Target_Type itself
6616 -- is not in this range). It could still be the case that Source_Type is
6617 -- in range of the target base type since we have not checked that case.
6619 -- If that is the case, we can freely convert the source to the target,
6620 -- and then test the target result against the bounds.
6622 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
6623 Convert_And_Check_Range;
6625 -- At this stage, we know that we have two scalar types, which are
6626 -- directly convertible, and where neither scalar type has a base
6627 -- range that is in the range of the other scalar type.
6629 -- The only way this can happen is with a signed and unsigned type.
6630 -- So test for these two cases:
6633 -- Case of the source is unsigned and the target is signed
6635 if Is_Unsigned_Type (Source_Base_Type)
6636 and then not Is_Unsigned_Type (Target_Base_Type)
6638 -- If the source is unsigned and the target is signed, then we
6639 -- know that the source is not shorter than the target (otherwise
6640 -- the source base type would be in the target base type range).
6642 -- In other words, the unsigned type is either the same size as
6643 -- the target, or it is larger. It cannot be smaller.
6646 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
6648 -- We only need to check the low bound if the low bound of the
6649 -- target type is non-negative. If the low bound of the target
6650 -- type is negative, then we know that we will fit fine.
6652 -- If the high bound of the target type is negative, then we
6653 -- know we have a constraint error, since we can't possibly
6654 -- have a negative source.
6656 -- With these two checks out of the way, we can do the check
6657 -- using the source type safely
6659 -- This is definitely the most annoying case.
6661 -- [constraint_error
6662 -- when (Target_Type'First >= 0
6664 -- N < Source_Base_Type (Target_Type'First))
6665 -- or else Target_Type'Last < 0
6666 -- or else N > Source_Base_Type (Target_Type'Last)];
6668 -- We turn off all checks since we know that the conversions
6669 -- will work fine, given the guards for negative values.
6672 Make_Raise_Constraint_Error (Loc,
6678 Left_Opnd => Make_Op_Ge (Loc,
6680 Make_Attribute_Reference (Loc,
6682 New_Occurrence_Of (Target_Type, Loc),
6683 Attribute_Name => Name_First),
6684 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6688 Left_Opnd => Duplicate_Subexpr (N),
6690 Convert_To (Source_Base_Type,
6691 Make_Attribute_Reference (Loc,
6693 New_Occurrence_Of (Target_Type, Loc),
6694 Attribute_Name => Name_First)))),
6699 Make_Attribute_Reference (Loc,
6700 Prefix => New_Occurrence_Of (Target_Type, Loc),
6701 Attribute_Name => Name_Last),
6702 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
6706 Left_Opnd => Duplicate_Subexpr (N),
6708 Convert_To (Source_Base_Type,
6709 Make_Attribute_Reference (Loc,
6710 Prefix => New_Occurrence_Of (Target_Type, Loc),
6711 Attribute_Name => Name_Last)))),
6714 Suppress => All_Checks);
6716 -- Only remaining possibility is that the source is signed and
6717 -- the target is unsigned.
6720 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
6721 and then Is_Unsigned_Type (Target_Base_Type));
6723 -- If the source is signed and the target is unsigned, then we
6724 -- know that the target is not shorter than the source (otherwise
6725 -- the target base type would be in the source base type range).
6727 -- In other words, the unsigned type is either the same size as
6728 -- the target, or it is larger. It cannot be smaller.
6730 -- Clearly we have an error if the source value is negative since
6731 -- no unsigned type can have negative values. If the source type
6732 -- is non-negative, then the check can be done using the target
6735 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6737 -- [constraint_error
6738 -- when N < 0 or else Tnn not in Target_Type];
6740 -- We turn off all checks for the conversion of N to the target
6741 -- base type, since we generate the explicit check to ensure that
6742 -- the value is non-negative
6745 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6748 Insert_Actions (N, New_List (
6749 Make_Object_Declaration (Loc,
6750 Defining_Identifier => Tnn,
6751 Object_Definition =>
6752 New_Occurrence_Of (Target_Base_Type, Loc),
6753 Constant_Present => True,
6755 Make_Unchecked_Type_Conversion (Loc,
6757 New_Occurrence_Of (Target_Base_Type, Loc),
6758 Expression => Duplicate_Subexpr (N))),
6760 Make_Raise_Constraint_Error (Loc,
6765 Left_Opnd => Duplicate_Subexpr (N),
6766 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6770 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6772 New_Occurrence_Of (Target_Type, Loc))),
6775 Suppress => All_Checks);
6777 -- Set the Etype explicitly, because Insert_Actions may have
6778 -- placed the declaration in the freeze list for an enclosing
6779 -- construct, and thus it is not analyzed yet.
6781 Set_Etype (Tnn, Target_Base_Type);
6782 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6786 end Generate_Range_Check;
6792 function Get_Check_Id (N : Name_Id) return Check_Id is
6794 -- For standard check name, we can do a direct computation
6796 if N in First_Check_Name .. Last_Check_Name then
6797 return Check_Id (N - (First_Check_Name - 1));
6799 -- For non-standard names added by pragma Check_Name, search table
6802 for J in All_Checks + 1 .. Check_Names.Last loop
6803 if Check_Names.Table (J) = N then
6809 -- No matching name found
6814 ---------------------
6815 -- Get_Discriminal --
6816 ---------------------
6818 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
6819 Loc : constant Source_Ptr := Sloc (E);
6824 -- The bound can be a bona fide parameter of a protected operation,
6825 -- rather than a prival encoded as an in-parameter.
6827 if No (Discriminal_Link (Entity (Bound))) then
6831 -- Climb the scope stack looking for an enclosing protected type. If
6832 -- we run out of scopes, return the bound itself.
6835 while Present (Sc) loop
6836 if Sc = Standard_Standard then
6838 elsif Ekind (Sc) = E_Protected_Type then
6845 D := First_Discriminant (Sc);
6846 while Present (D) loop
6847 if Chars (D) = Chars (Bound) then
6848 return New_Occurrence_Of (Discriminal (D), Loc);
6851 Next_Discriminant (D);
6855 end Get_Discriminal;
6857 ----------------------
6858 -- Get_Range_Checks --
6859 ----------------------
6861 function Get_Range_Checks
6863 Target_Typ : Entity_Id;
6864 Source_Typ : Entity_Id := Empty;
6865 Warn_Node : Node_Id := Empty) return Check_Result
6869 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
6870 end Get_Range_Checks;
6876 function Guard_Access
6879 Ck_Node : Node_Id) return Node_Id
6882 if Nkind (Cond) = N_Or_Else then
6883 Set_Paren_Count (Cond, 1);
6886 if Nkind (Ck_Node) = N_Allocator then
6894 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
6895 Right_Opnd => Make_Null (Loc)),
6896 Right_Opnd => Cond);
6900 -----------------------------
6901 -- Index_Checks_Suppressed --
6902 -----------------------------
6904 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
6906 if Present (E) and then Checks_May_Be_Suppressed (E) then
6907 return Is_Check_Suppressed (E, Index_Check);
6909 return Scope_Suppress.Suppress (Index_Check);
6911 end Index_Checks_Suppressed;
6917 procedure Initialize is
6919 for J in Determine_Range_Cache_N'Range loop
6920 Determine_Range_Cache_N (J) := Empty;
6925 for J in Int range 1 .. All_Checks loop
6926 Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
6930 -------------------------
6931 -- Insert_Range_Checks --
6932 -------------------------
6934 procedure Insert_Range_Checks
6935 (Checks : Check_Result;
6937 Suppress_Typ : Entity_Id;
6938 Static_Sloc : Source_Ptr := No_Location;
6939 Flag_Node : Node_Id := Empty;
6940 Do_Before : Boolean := False)
6942 Internal_Flag_Node : Node_Id := Flag_Node;
6943 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
6945 Check_Node : Node_Id;
6946 Checks_On : constant Boolean :=
6947 (not Index_Checks_Suppressed (Suppress_Typ))
6948 or else (not Range_Checks_Suppressed (Suppress_Typ));
6951 -- For now we just return if Checks_On is false, however this should be
6952 -- enhanced to check for an always True value in the condition and to
6953 -- generate a compilation warning???
6955 if not Expander_Active or not Checks_On then
6959 if Static_Sloc = No_Location then
6960 Internal_Static_Sloc := Sloc (Node);
6963 if No (Flag_Node) then
6964 Internal_Flag_Node := Node;
6967 for J in 1 .. 2 loop
6968 exit when No (Checks (J));
6970 if Nkind (Checks (J)) = N_Raise_Constraint_Error
6971 and then Present (Condition (Checks (J)))
6973 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
6974 Check_Node := Checks (J);
6975 Mark_Rewrite_Insertion (Check_Node);
6978 Insert_Before_And_Analyze (Node, Check_Node);
6980 Insert_After_And_Analyze (Node, Check_Node);
6983 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
6988 Make_Raise_Constraint_Error (Internal_Static_Sloc,
6989 Reason => CE_Range_Check_Failed);
6990 Mark_Rewrite_Insertion (Check_Node);
6993 Insert_Before_And_Analyze (Node, Check_Node);
6995 Insert_After_And_Analyze (Node, Check_Node);
6999 end Insert_Range_Checks;
7001 ------------------------
7002 -- Insert_Valid_Check --
7003 ------------------------
7005 procedure Insert_Valid_Check
7007 Related_Id : Entity_Id := Empty;
7008 Is_Low_Bound : Boolean := False;
7009 Is_High_Bound : Boolean := False)
7011 Loc : constant Source_Ptr := Sloc (Expr);
7012 Typ : constant Entity_Id := Etype (Expr);
7016 -- Do not insert if checks off, or if not checking validity or if
7017 -- expression is known to be valid.
7019 if not Validity_Checks_On
7020 or else Range_Or_Validity_Checks_Suppressed (Expr)
7021 or else Expr_Known_Valid (Expr)
7026 -- Do not insert checks within a predicate function. This will arise
7027 -- if the current unit and the predicate function are being compiled
7028 -- with validity checks enabled.
7030 if Present (Predicate_Function (Typ))
7031 and then Current_Scope = Predicate_Function (Typ)
7036 -- If the expression is a packed component of a modular type of the
7037 -- right size, the data is always valid.
7039 if Nkind (Expr) = N_Selected_Component
7040 and then Present (Component_Clause (Entity (Selector_Name (Expr))))
7041 and then Is_Modular_Integer_Type (Typ)
7042 and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr)))
7047 -- If we have a checked conversion, then validity check applies to
7048 -- the expression inside the conversion, not the result, since if
7049 -- the expression inside is valid, then so is the conversion result.
7052 while Nkind (Exp) = N_Type_Conversion loop
7053 Exp := Expression (Exp);
7056 -- We are about to insert the validity check for Exp. We save and
7057 -- reset the Do_Range_Check flag over this validity check, and then
7058 -- put it back for the final original reference (Exp may be rewritten).
7061 DRC : constant Boolean := Do_Range_Check (Exp);
7066 Set_Do_Range_Check (Exp, False);
7068 -- Force evaluation to avoid multiple reads for atomic/volatile
7070 -- Note: we set Name_Req to False. We used to set it to True, with
7071 -- the thinking that a name is required as the prefix of the 'Valid
7072 -- call, but in fact the check that the prefix of an attribute is
7073 -- a name is in the parser, and we just don't require it here.
7074 -- Moreover, when we set Name_Req to True, that interfered with the
7075 -- checking for Volatile, since we couldn't just capture the value.
7077 if Is_Entity_Name (Exp)
7078 and then Is_Volatile (Entity (Exp))
7080 -- Same reasoning as above for setting Name_Req to False
7082 Force_Evaluation (Exp, Name_Req => False);
7085 -- Build the prefix for the 'Valid call
7088 Duplicate_Subexpr_No_Checks
7091 Related_Id => Related_Id,
7092 Is_Low_Bound => Is_Low_Bound,
7093 Is_High_Bound => Is_High_Bound);
7095 -- A rather specialized test. If PV is an analyzed expression which
7096 -- is an indexed component of a packed array that has not been
7097 -- properly expanded, turn off its Analyzed flag to make sure it
7098 -- gets properly reexpanded. If the prefix is an access value,
7099 -- the dereference will be added later.
7101 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7102 -- an analyze with the old parent pointer. This may point e.g. to
7103 -- a subprogram call, which deactivates this expansion.
7106 and then Nkind (PV) = N_Indexed_Component
7107 and then Is_Array_Type (Etype (Prefix (PV)))
7108 and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV))))
7110 Set_Analyzed (PV, False);
7113 -- Build the raise CE node to check for validity. We build a type
7114 -- qualification for the prefix, since it may not be of the form of
7115 -- a name, and we don't care in this context!
7118 Make_Raise_Constraint_Error (Loc,
7122 Make_Attribute_Reference (Loc,
7124 Attribute_Name => Name_Valid)),
7125 Reason => CE_Invalid_Data);
7127 -- Insert the validity check. Note that we do this with validity
7128 -- checks turned off, to avoid recursion, we do not want validity
7129 -- checks on the validity checking code itself.
7131 Insert_Action (Expr, CE, Suppress => Validity_Check);
7133 -- If the expression is a reference to an element of a bit-packed
7134 -- array, then it is rewritten as a renaming declaration. If the
7135 -- expression is an actual in a call, it has not been expanded,
7136 -- waiting for the proper point at which to do it. The same happens
7137 -- with renamings, so that we have to force the expansion now. This
7138 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7141 if Is_Entity_Name (Exp)
7142 and then Nkind (Parent (Entity (Exp))) =
7143 N_Object_Renaming_Declaration
7146 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
7148 if Nkind (Old_Exp) = N_Indexed_Component
7149 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
7151 Expand_Packed_Element_Reference (Old_Exp);
7156 -- Put back the Do_Range_Check flag on the resulting (possibly
7157 -- rewritten) expression.
7159 -- Note: it might be thought that a validity check is not required
7160 -- when a range check is present, but that's not the case, because
7161 -- the back end is allowed to assume for the range check that the
7162 -- operand is within its declared range (an assumption that validity
7163 -- checking is all about NOT assuming).
7165 -- Note: no need to worry about Possible_Local_Raise here, it will
7166 -- already have been called if original node has Do_Range_Check set.
7168 Set_Do_Range_Check (Exp, DRC);
7170 end Insert_Valid_Check;
7172 -------------------------------------
7173 -- Is_Signed_Integer_Arithmetic_Op --
7174 -------------------------------------
7176 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
7179 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
7180 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
7181 N_Op_Rem | N_Op_Subtract =>
7182 return Is_Signed_Integer_Type (Etype (N));
7184 when N_If_Expression | N_Case_Expression =>
7185 return Is_Signed_Integer_Type (Etype (N));
7190 end Is_Signed_Integer_Arithmetic_Op;
7192 ----------------------------------
7193 -- Install_Null_Excluding_Check --
7194 ----------------------------------
7196 procedure Install_Null_Excluding_Check (N : Node_Id) is
7197 Loc : constant Source_Ptr := Sloc (Parent (N));
7198 Typ : constant Entity_Id := Etype (N);
7200 function Safe_To_Capture_In_Parameter_Value return Boolean;
7201 -- Determines if it is safe to capture Known_Non_Null status for an
7202 -- the entity referenced by node N. The caller ensures that N is indeed
7203 -- an entity name. It is safe to capture the non-null status for an IN
7204 -- parameter when the reference occurs within a declaration that is sure
7205 -- to be executed as part of the declarative region.
7207 procedure Mark_Non_Null;
7208 -- After installation of check, if the node in question is an entity
7209 -- name, then mark this entity as non-null if possible.
7211 function Safe_To_Capture_In_Parameter_Value return Boolean is
7212 E : constant Entity_Id := Entity (N);
7213 S : constant Entity_Id := Current_Scope;
7217 if Ekind (E) /= E_In_Parameter then
7221 -- Two initial context checks. We must be inside a subprogram body
7222 -- with declarations and reference must not appear in nested scopes.
7224 if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure)
7225 or else Scope (E) /= S
7230 S_Par := Parent (Parent (S));
7232 if Nkind (S_Par) /= N_Subprogram_Body
7233 or else No (Declarations (S_Par))
7243 -- Retrieve the declaration node of N (if any). Note that N
7244 -- may be a part of a complex initialization expression.
7248 while Present (P) loop
7250 -- If we have a short circuit form, and we are within the right
7251 -- hand expression, we return false, since the right hand side
7252 -- is not guaranteed to be elaborated.
7254 if Nkind (P) in N_Short_Circuit
7255 and then N = Right_Opnd (P)
7260 -- Similarly, if we are in an if expression and not part of the
7261 -- condition, then we return False, since neither the THEN or
7262 -- ELSE dependent expressions will always be elaborated.
7264 if Nkind (P) = N_If_Expression
7265 and then N /= First (Expressions (P))
7270 -- If within a case expression, and not part of the expression,
7271 -- then return False, since a particular dependent expression
7272 -- may not always be elaborated
7274 if Nkind (P) = N_Case_Expression
7275 and then N /= Expression (P)
7280 -- While traversing the parent chain, if node N belongs to a
7281 -- statement, then it may never appear in a declarative region.
7283 if Nkind (P) in N_Statement_Other_Than_Procedure_Call
7284 or else Nkind (P) = N_Procedure_Call_Statement
7289 -- If we are at a declaration, record it and exit
7291 if Nkind (P) in N_Declaration
7292 and then Nkind (P) not in N_Subprogram_Specification
7305 return List_Containing (N_Decl) = Declarations (S_Par);
7307 end Safe_To_Capture_In_Parameter_Value;
7313 procedure Mark_Non_Null is
7315 -- Only case of interest is if node N is an entity name
7317 if Is_Entity_Name (N) then
7319 -- For sure, we want to clear an indication that this is known to
7320 -- be null, since if we get past this check, it definitely is not.
7322 Set_Is_Known_Null (Entity (N), False);
7324 -- We can mark the entity as known to be non-null if either it is
7325 -- safe to capture the value, or in the case of an IN parameter,
7326 -- which is a constant, if the check we just installed is in the
7327 -- declarative region of the subprogram body. In this latter case,
7328 -- a check is decisive for the rest of the body if the expression
7329 -- is sure to be elaborated, since we know we have to elaborate
7330 -- all declarations before executing the body.
7332 -- Couldn't this always be part of Safe_To_Capture_Value ???
7334 if Safe_To_Capture_Value (N, Entity (N))
7335 or else Safe_To_Capture_In_Parameter_Value
7337 Set_Is_Known_Non_Null (Entity (N));
7342 -- Start of processing for Install_Null_Excluding_Check
7345 pragma Assert (Is_Access_Type (Typ));
7347 -- No check inside a generic, check will be emitted in instance
7349 if Inside_A_Generic then
7353 -- No check needed if known to be non-null
7355 if Known_Non_Null (N) then
7359 -- If known to be null, here is where we generate a compile time check
7361 if Known_Null (N) then
7363 -- Avoid generating warning message inside init procs. In SPARK mode
7364 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7365 -- since it will be turned into an error in any case.
7367 if (not Inside_Init_Proc or else SPARK_Mode = On)
7369 -- Do not emit the warning within a conditional expression,
7370 -- where the expression might not be evaluated, and the warning
7371 -- appear as extraneous noise.
7373 and then not Within_Case_Or_If_Expression (N)
7375 Apply_Compile_Time_Constraint_Error
7376 (N, "null value not allowed here??", CE_Access_Check_Failed);
7378 -- Remaining cases, where we silently insert the raise
7382 Make_Raise_Constraint_Error (Loc,
7383 Reason => CE_Access_Check_Failed));
7390 -- If entity is never assigned, for sure a warning is appropriate
7392 if Is_Entity_Name (N) then
7393 Check_Unset_Reference (N);
7396 -- No check needed if checks are suppressed on the range. Note that we
7397 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7398 -- so, since the program is erroneous, but we don't like to casually
7399 -- propagate such conclusions from erroneosity).
7401 if Access_Checks_Suppressed (Typ) then
7405 -- No check needed for access to concurrent record types generated by
7406 -- the expander. This is not just an optimization (though it does indeed
7407 -- remove junk checks). It also avoids generation of junk warnings.
7409 if Nkind (N) in N_Has_Chars
7410 and then Chars (N) = Name_uObject
7411 and then Is_Concurrent_Record_Type
7412 (Directly_Designated_Type (Etype (N)))
7417 -- No check needed in interface thunks since the runtime check is
7418 -- already performed at the caller side.
7420 if Is_Thunk (Current_Scope) then
7424 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7425 -- the expander within exception handlers, since we know that the value
7426 -- can never be null.
7428 -- Is this really the right way to do this? Normally we generate such
7429 -- code in the expander with checks off, and that's how we suppress this
7430 -- kind of junk check ???
7432 if Nkind (N) = N_Function_Call
7433 and then Nkind (Name (N)) = N_Explicit_Dereference
7434 and then Nkind (Prefix (Name (N))) = N_Identifier
7435 and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
7440 -- Otherwise install access check
7443 Make_Raise_Constraint_Error (Loc,
7446 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
7447 Right_Opnd => Make_Null (Loc)),
7448 Reason => CE_Access_Check_Failed));
7451 end Install_Null_Excluding_Check;
7453 --------------------------
7454 -- Install_Static_Check --
7455 --------------------------
7457 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
7458 Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
7459 Typ : constant Entity_Id := Etype (R_Cno);
7463 Make_Raise_Constraint_Error (Loc,
7464 Reason => CE_Range_Check_Failed));
7465 Set_Analyzed (R_Cno);
7466 Set_Etype (R_Cno, Typ);
7467 Set_Raises_Constraint_Error (R_Cno);
7468 Set_Is_Static_Expression (R_Cno, Stat);
7470 -- Now deal with possible local raise handling
7472 Possible_Local_Raise (R_Cno, Standard_Constraint_Error);
7473 end Install_Static_Check;
7475 -------------------------
7476 -- Is_Check_Suppressed --
7477 -------------------------
7479 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
7480 Ptr : Suppress_Stack_Entry_Ptr;
7483 -- First search the local entity suppress stack. We search this from the
7484 -- top of the stack down so that we get the innermost entry that applies
7485 -- to this case if there are nested entries.
7487 Ptr := Local_Suppress_Stack_Top;
7488 while Ptr /= null loop
7489 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7490 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7492 return Ptr.Suppress;
7498 -- Now search the global entity suppress table for a matching entry.
7499 -- We also search this from the top down so that if there are multiple
7500 -- pragmas for the same entity, the last one applies (not clear what
7501 -- or whether the RM specifies this handling, but it seems reasonable).
7503 Ptr := Global_Suppress_Stack_Top;
7504 while Ptr /= null loop
7505 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7506 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7508 return Ptr.Suppress;
7514 -- If we did not find a matching entry, then use the normal scope
7515 -- suppress value after all (actually this will be the global setting
7516 -- since it clearly was not overridden at any point). For a predefined
7517 -- check, we test the specific flag. For a user defined check, we check
7518 -- the All_Checks flag. The Overflow flag requires special handling to
7519 -- deal with the General vs Assertion case
7521 if C = Overflow_Check then
7522 return Overflow_Checks_Suppressed (Empty);
7523 elsif C in Predefined_Check_Id then
7524 return Scope_Suppress.Suppress (C);
7526 return Scope_Suppress.Suppress (All_Checks);
7528 end Is_Check_Suppressed;
7530 ---------------------
7531 -- Kill_All_Checks --
7532 ---------------------
7534 procedure Kill_All_Checks is
7536 if Debug_Flag_CC then
7537 w ("Kill_All_Checks");
7540 -- We reset the number of saved checks to zero, and also modify all
7541 -- stack entries for statement ranges to indicate that the number of
7542 -- checks at each level is now zero.
7544 Num_Saved_Checks := 0;
7546 -- Note: the Int'Min here avoids any possibility of J being out of
7547 -- range when called from e.g. Conditional_Statements_Begin.
7549 for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
7550 Saved_Checks_Stack (J) := 0;
7552 end Kill_All_Checks;
7558 procedure Kill_Checks (V : Entity_Id) is
7560 if Debug_Flag_CC then
7561 w ("Kill_Checks for entity", Int (V));
7564 for J in 1 .. Num_Saved_Checks loop
7565 if Saved_Checks (J).Entity = V then
7566 if Debug_Flag_CC then
7567 w (" Checks killed for saved check ", J);
7570 Saved_Checks (J).Killed := True;
7575 ------------------------------
7576 -- Length_Checks_Suppressed --
7577 ------------------------------
7579 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
7581 if Present (E) and then Checks_May_Be_Suppressed (E) then
7582 return Is_Check_Suppressed (E, Length_Check);
7584 return Scope_Suppress.Suppress (Length_Check);
7586 end Length_Checks_Suppressed;
7588 -----------------------
7589 -- Make_Bignum_Block --
7590 -----------------------
7592 function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is
7593 M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM);
7596 Make_Block_Statement (Loc,
7598 New_List (Build_SS_Mark_Call (Loc, M)),
7599 Handled_Statement_Sequence =>
7600 Make_Handled_Sequence_Of_Statements (Loc,
7601 Statements => New_List (Build_SS_Release_Call (Loc, M))));
7602 end Make_Bignum_Block;
7604 ----------------------------------
7605 -- Minimize_Eliminate_Overflows --
7606 ----------------------------------
7608 -- This is a recursive routine that is called at the top of an expression
7609 -- tree to properly process overflow checking for a whole subtree by making
7610 -- recursive calls to process operands. This processing may involve the use
7611 -- of bignum or long long integer arithmetic, which will change the types
7612 -- of operands and results. That's why we can't do this bottom up (since
7613 -- it would interfere with semantic analysis).
7615 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
7616 -- the operator expansion routines, as well as the expansion routines for
7617 -- if/case expression, do nothing (for the moment) except call the routine
7618 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
7619 -- routine does nothing for non top-level nodes, so at the point where the
7620 -- call is made for the top level node, the entire expression subtree has
7621 -- not been expanded, or processed for overflow. All that has to happen as
7622 -- a result of the top level call to this routine.
7624 -- As noted above, the overflow processing works by making recursive calls
7625 -- for the operands, and figuring out what to do, based on the processing
7626 -- of these operands (e.g. if a bignum operand appears, the parent op has
7627 -- to be done in bignum mode), and the determined ranges of the operands.
7629 -- After possible rewriting of a constituent subexpression node, a call is
7630 -- made to either reexpand the node (if nothing has changed) or reanalyze
7631 -- the node (if it has been modified by the overflow check processing). The
7632 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
7633 -- a recursive call into the whole overflow apparatus, an important rule
7634 -- for this call is that the overflow handling mode must be temporarily set
7637 procedure Minimize_Eliminate_Overflows
7641 Top_Level : Boolean)
7643 Rtyp : constant Entity_Id := Etype (N);
7644 pragma Assert (Is_Signed_Integer_Type (Rtyp));
7645 -- Result type, must be a signed integer type
7647 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
7648 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
7650 Loc : constant Source_Ptr := Sloc (N);
7653 -- Ranges of values for right operand (operator case)
7656 -- Ranges of values for left operand (operator case)
7658 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
7659 -- Operands and results are of this type when we convert
7661 LLLo : constant Uint := Intval (Type_Low_Bound (LLIB));
7662 LLHi : constant Uint := Intval (Type_High_Bound (LLIB));
7663 -- Bounds of Long_Long_Integer
7665 Binary : constant Boolean := Nkind (N) in N_Binary_Op;
7666 -- Indicates binary operator case
7669 -- Used in call to Determine_Range
7671 Bignum_Operands : Boolean;
7672 -- Set True if one or more operands is already of type Bignum, meaning
7673 -- that for sure (regardless of Top_Level setting) we are committed to
7674 -- doing the operation in Bignum mode (or in the case of a case or if
7675 -- expression, converting all the dependent expressions to Bignum).
7677 Long_Long_Integer_Operands : Boolean;
7678 -- Set True if one or more operands is already of type Long_Long_Integer
7679 -- which means that if the result is known to be in the result type
7680 -- range, then we must convert such operands back to the result type.
7682 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False);
7683 -- This is called when we have modified the node and we therefore need
7684 -- to reanalyze it. It is important that we reset the mode to STRICT for
7685 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7686 -- we would reenter this routine recursively which would not be good.
7687 -- The argument Suppress is set True if we also want to suppress
7688 -- overflow checking for the reexpansion (this is set when we know
7689 -- overflow is not possible). Typ is the type for the reanalysis.
7691 procedure Reexpand (Suppress : Boolean := False);
7692 -- This is like Reanalyze, but does not do the Analyze step, it only
7693 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7694 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7695 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7696 -- Note that skipping reanalysis is not just an optimization, testing
7697 -- has showed up several complex cases in which reanalyzing an already
7698 -- analyzed node causes incorrect behavior.
7700 function In_Result_Range return Boolean;
7701 -- Returns True iff Lo .. Hi are within range of the result type
7703 procedure Max (A : in out Uint; B : Uint);
7704 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7706 procedure Min (A : in out Uint; B : Uint);
7707 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7709 ---------------------
7710 -- In_Result_Range --
7711 ---------------------
7713 function In_Result_Range return Boolean is
7715 if Lo = No_Uint or else Hi = No_Uint then
7718 elsif Is_OK_Static_Subtype (Etype (N)) then
7719 return Lo >= Expr_Value (Type_Low_Bound (Rtyp))
7721 Hi <= Expr_Value (Type_High_Bound (Rtyp));
7724 return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp)))
7726 Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp)));
7728 end In_Result_Range;
7734 procedure Max (A : in out Uint; B : Uint) is
7736 if A = No_Uint or else B > A then
7745 procedure Min (A : in out Uint; B : Uint) is
7747 if A = No_Uint or else B < A then
7756 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is
7757 Svg : constant Overflow_Mode_Type :=
7758 Scope_Suppress.Overflow_Mode_General;
7759 Sva : constant Overflow_Mode_Type :=
7760 Scope_Suppress.Overflow_Mode_Assertions;
7761 Svo : constant Boolean :=
7762 Scope_Suppress.Suppress (Overflow_Check);
7765 Scope_Suppress.Overflow_Mode_General := Strict;
7766 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7769 Scope_Suppress.Suppress (Overflow_Check) := True;
7772 Analyze_And_Resolve (N, Typ);
7774 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7775 Scope_Suppress.Overflow_Mode_General := Svg;
7776 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7783 procedure Reexpand (Suppress : Boolean := False) is
7784 Svg : constant Overflow_Mode_Type :=
7785 Scope_Suppress.Overflow_Mode_General;
7786 Sva : constant Overflow_Mode_Type :=
7787 Scope_Suppress.Overflow_Mode_Assertions;
7788 Svo : constant Boolean :=
7789 Scope_Suppress.Suppress (Overflow_Check);
7792 Scope_Suppress.Overflow_Mode_General := Strict;
7793 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7794 Set_Analyzed (N, False);
7797 Scope_Suppress.Suppress (Overflow_Check) := True;
7802 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7803 Scope_Suppress.Overflow_Mode_General := Svg;
7804 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7807 -- Start of processing for Minimize_Eliminate_Overflows
7810 -- Case where we do not have a signed integer arithmetic operation
7812 if not Is_Signed_Integer_Arithmetic_Op (N) then
7814 -- Use the normal Determine_Range routine to get the range. We
7815 -- don't require operands to be valid, invalid values may result in
7816 -- rubbish results where the result has not been properly checked for
7817 -- overflow, that's fine.
7819 Determine_Range (N, OK, Lo, Hi, Assume_Valid => False);
7821 -- If Determine_Range did not work (can this in fact happen? Not
7822 -- clear but might as well protect), use type bounds.
7825 Lo := Intval (Type_Low_Bound (Base_Type (Etype (N))));
7826 Hi := Intval (Type_High_Bound (Base_Type (Etype (N))));
7829 -- If we don't have a binary operator, all we have to do is to set
7830 -- the Hi/Lo range, so we are done.
7834 -- Processing for if expression
7836 elsif Nkind (N) = N_If_Expression then
7838 Then_DE : constant Node_Id := Next (First (Expressions (N)));
7839 Else_DE : constant Node_Id := Next (Then_DE);
7842 Bignum_Operands := False;
7844 Minimize_Eliminate_Overflows
7845 (Then_DE, Lo, Hi, Top_Level => False);
7847 if Lo = No_Uint then
7848 Bignum_Operands := True;
7851 Minimize_Eliminate_Overflows
7852 (Else_DE, Rlo, Rhi, Top_Level => False);
7854 if Rlo = No_Uint then
7855 Bignum_Operands := True;
7857 Long_Long_Integer_Operands :=
7858 Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB;
7864 -- If at least one of our operands is now Bignum, we must rebuild
7865 -- the if expression to use Bignum operands. We will analyze the
7866 -- rebuilt if expression with overflow checks off, since once we
7867 -- are in bignum mode, we are all done with overflow checks.
7869 if Bignum_Operands then
7871 Make_If_Expression (Loc,
7872 Expressions => New_List (
7873 Remove_Head (Expressions (N)),
7874 Convert_To_Bignum (Then_DE),
7875 Convert_To_Bignum (Else_DE)),
7876 Is_Elsif => Is_Elsif (N)));
7878 Reanalyze (RTE (RE_Bignum), Suppress => True);
7880 -- If we have no Long_Long_Integer operands, then we are in result
7881 -- range, since it means that none of our operands felt the need
7882 -- to worry about overflow (otherwise it would have already been
7883 -- converted to long long integer or bignum). We reexpand to
7884 -- complete the expansion of the if expression (but we do not
7885 -- need to reanalyze).
7887 elsif not Long_Long_Integer_Operands then
7888 Set_Do_Overflow_Check (N, False);
7891 -- Otherwise convert us to long long integer mode. Note that we
7892 -- don't need any further overflow checking at this level.
7895 Convert_To_And_Rewrite (LLIB, Then_DE);
7896 Convert_To_And_Rewrite (LLIB, Else_DE);
7897 Set_Etype (N, LLIB);
7899 -- Now reanalyze with overflow checks off
7901 Set_Do_Overflow_Check (N, False);
7902 Reanalyze (LLIB, Suppress => True);
7908 -- Here for case expression
7910 elsif Nkind (N) = N_Case_Expression then
7911 Bignum_Operands := False;
7912 Long_Long_Integer_Operands := False;
7918 -- Loop through expressions applying recursive call
7920 Alt := First (Alternatives (N));
7921 while Present (Alt) loop
7923 Aexp : constant Node_Id := Expression (Alt);
7926 Minimize_Eliminate_Overflows
7927 (Aexp, Lo, Hi, Top_Level => False);
7929 if Lo = No_Uint then
7930 Bignum_Operands := True;
7931 elsif Etype (Aexp) = LLIB then
7932 Long_Long_Integer_Operands := True;
7939 -- If we have no bignum or long long integer operands, it means
7940 -- that none of our dependent expressions could raise overflow.
7941 -- In this case, we simply return with no changes except for
7942 -- resetting the overflow flag, since we are done with overflow
7943 -- checks for this node. We will reexpand to get the needed
7944 -- expansion for the case expression, but we do not need to
7945 -- reanalyze, since nothing has changed.
7947 if not (Bignum_Operands or Long_Long_Integer_Operands) then
7948 Set_Do_Overflow_Check (N, False);
7949 Reexpand (Suppress => True);
7951 -- Otherwise we are going to rebuild the case expression using
7952 -- either bignum or long long integer operands throughout.
7961 New_Alts := New_List;
7962 Alt := First (Alternatives (N));
7963 while Present (Alt) loop
7964 if Bignum_Operands then
7965 New_Exp := Convert_To_Bignum (Expression (Alt));
7966 Rtype := RTE (RE_Bignum);
7968 New_Exp := Convert_To (LLIB, Expression (Alt));
7972 Append_To (New_Alts,
7973 Make_Case_Expression_Alternative (Sloc (Alt),
7975 Discrete_Choices => Discrete_Choices (Alt),
7976 Expression => New_Exp));
7982 Make_Case_Expression (Loc,
7983 Expression => Expression (N),
7984 Alternatives => New_Alts));
7986 Reanalyze (Rtype, Suppress => True);
7994 -- If we have an arithmetic operator we make recursive calls on the
7995 -- operands to get the ranges (and to properly process the subtree
7996 -- that lies below us).
7998 Minimize_Eliminate_Overflows
7999 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
8002 Minimize_Eliminate_Overflows
8003 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
8006 -- Record if we have Long_Long_Integer operands
8008 Long_Long_Integer_Operands :=
8009 Etype (Right_Opnd (N)) = LLIB
8010 or else (Binary and then Etype (Left_Opnd (N)) = LLIB);
8012 -- If either operand is a bignum, then result will be a bignum and we
8013 -- don't need to do any range analysis. As previously discussed we could
8014 -- do range analysis in such cases, but it could mean working with giant
8015 -- numbers at compile time for very little gain (the number of cases
8016 -- in which we could slip back from bignum mode is small).
8018 if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
8021 Bignum_Operands := True;
8023 -- Otherwise compute result range
8026 Bignum_Operands := False;
8034 Hi := UI_Max (abs Rlo, abs Rhi);
8046 -- If the right operand can only be zero, set 0..0
8048 if Rlo = 0 and then Rhi = 0 then
8052 -- Possible bounds of division must come from dividing end
8053 -- values of the input ranges (four possibilities), provided
8054 -- zero is not included in the possible values of the right
8057 -- Otherwise, we just consider two intervals of values for
8058 -- the right operand: the interval of negative values (up to
8059 -- -1) and the interval of positive values (starting at 1).
8060 -- Since division by 1 is the identity, and division by -1
8061 -- is negation, we get all possible bounds of division in that
8062 -- case by considering:
8063 -- - all values from the division of end values of input
8065 -- - the end values of the left operand;
8066 -- - the negation of the end values of the left operand.
8070 Mrk : constant Uintp.Save_Mark := Mark;
8071 -- Mark so we can release the RR and Ev values
8079 -- Discard extreme values of zero for the divisor, since
8080 -- they will simply result in an exception in any case.
8088 -- Compute possible bounds coming from dividing end
8089 -- values of the input ranges.
8096 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8097 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8099 -- If the right operand can be both negative or positive,
8100 -- include the end values of the left operand in the
8101 -- extreme values, as well as their negation.
8103 if Rlo < 0 and then Rhi > 0 then
8110 UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
8112 UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
8115 -- Release the RR and Ev values
8117 Release_And_Save (Mrk, Lo, Hi);
8125 -- Discard negative values for the exponent, since they will
8126 -- simply result in an exception in any case.
8134 -- Estimate number of bits in result before we go computing
8135 -- giant useless bounds. Basically the number of bits in the
8136 -- result is the number of bits in the base multiplied by the
8137 -- value of the exponent. If this is big enough that the result
8138 -- definitely won't fit in Long_Long_Integer, switch to bignum
8139 -- mode immediately, and avoid computing giant bounds.
8141 -- The comparison here is approximate, but conservative, it
8142 -- only clicks on cases that are sure to exceed the bounds.
8144 if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
8148 -- If right operand is zero then result is 1
8155 -- High bound comes either from exponentiation of largest
8156 -- positive value to largest exponent value, or from
8157 -- the exponentiation of most negative value to an
8171 if Rhi mod 2 = 0 then
8174 Hi2 := Llo ** (Rhi - 1);
8180 Hi := UI_Max (Hi1, Hi2);
8183 -- Result can only be negative if base can be negative
8186 if Rhi mod 2 = 0 then
8187 Lo := Llo ** (Rhi - 1);
8192 -- Otherwise low bound is minimum ** minimum
8209 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8210 -- This is the maximum absolute value of the result
8216 -- The result depends only on the sign and magnitude of
8217 -- the right operand, it does not depend on the sign or
8218 -- magnitude of the left operand.
8231 when N_Op_Multiply =>
8233 -- Possible bounds of multiplication must come from multiplying
8234 -- end values of the input ranges (four possibilities).
8237 Mrk : constant Uintp.Save_Mark := Mark;
8238 -- Mark so we can release the Ev values
8240 Ev1 : constant Uint := Llo * Rlo;
8241 Ev2 : constant Uint := Llo * Rhi;
8242 Ev3 : constant Uint := Lhi * Rlo;
8243 Ev4 : constant Uint := Lhi * Rhi;
8246 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8247 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8249 -- Release the Ev values
8251 Release_And_Save (Mrk, Lo, Hi);
8254 -- Plus operator (affirmation)
8264 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8265 -- This is the maximum absolute value of the result. Note
8266 -- that the result range does not depend on the sign of the
8273 -- Case of left operand negative, which results in a range
8274 -- of -Maxabs .. 0 for those negative values. If there are
8275 -- no negative values then Lo value of result is always 0.
8281 -- Case of left operand positive
8290 when N_Op_Subtract =>
8294 -- Nothing else should be possible
8297 raise Program_Error;
8301 -- Here for the case where we have not rewritten anything (no bignum
8302 -- operands or long long integer operands), and we know the result.
8303 -- If we know we are in the result range, and we do not have Bignum
8304 -- operands or Long_Long_Integer operands, we can just reexpand with
8305 -- overflow checks turned off (since we know we cannot have overflow).
8306 -- As always the reexpansion is required to complete expansion of the
8307 -- operator, but we do not need to reanalyze, and we prevent recursion
8308 -- by suppressing the check.
8310 if not (Bignum_Operands or Long_Long_Integer_Operands)
8311 and then In_Result_Range
8313 Set_Do_Overflow_Check (N, False);
8314 Reexpand (Suppress => True);
8317 -- Here we know that we are not in the result range, and in the general
8318 -- case we will move into either the Bignum or Long_Long_Integer domain
8319 -- to compute the result. However, there is one exception. If we are
8320 -- at the top level, and we do not have Bignum or Long_Long_Integer
8321 -- operands, we will have to immediately convert the result back to
8322 -- the result type, so there is no point in Bignum/Long_Long_Integer
8326 and then not (Bignum_Operands or Long_Long_Integer_Operands)
8328 -- One further refinement. If we are at the top level, but our parent
8329 -- is a type conversion, then go into bignum or long long integer node
8330 -- since the result will be converted to that type directly without
8331 -- going through the result type, and we may avoid an overflow. This
8332 -- is the case for example of Long_Long_Integer (A ** 4), where A is
8333 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
8334 -- but does not fit in Integer.
8336 and then Nkind (Parent (N)) /= N_Type_Conversion
8338 -- Here keep original types, but we need to complete analysis
8340 -- One subtlety. We can't just go ahead and do an analyze operation
8341 -- here because it will cause recursion into the whole MINIMIZED/
8342 -- ELIMINATED overflow processing which is not what we want. Here
8343 -- we are at the top level, and we need a check against the result
8344 -- mode (i.e. we want to use STRICT mode). So do exactly that.
8345 -- Also, we have not modified the node, so this is a case where
8346 -- we need to reexpand, but not reanalyze.
8351 -- Cases where we do the operation in Bignum mode. This happens either
8352 -- because one of our operands is in Bignum mode already, or because
8353 -- the computed bounds are outside the bounds of Long_Long_Integer,
8354 -- which in some cases can be indicated by Hi and Lo being No_Uint.
8356 -- Note: we could do better here and in some cases switch back from
8357 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
8358 -- 0 .. 1, but the cases are rare and it is not worth the effort.
8359 -- Failing to do this switching back is only an efficiency issue.
8361 elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
8363 -- OK, we are definitely outside the range of Long_Long_Integer. The
8364 -- question is whether to move to Bignum mode, or stay in the domain
8365 -- of Long_Long_Integer, signalling that an overflow check is needed.
8367 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
8368 -- the Bignum business. In ELIMINATED mode, we will normally move
8369 -- into Bignum mode, but there is an exception if neither of our
8370 -- operands is Bignum now, and we are at the top level (Top_Level
8371 -- set True). In this case, there is no point in moving into Bignum
8372 -- mode to prevent overflow if the caller will immediately convert
8373 -- the Bignum value back to LLI with an overflow check. It's more
8374 -- efficient to stay in LLI mode with an overflow check (if needed)
8376 if Check_Mode = Minimized
8377 or else (Top_Level and not Bignum_Operands)
8379 if Do_Overflow_Check (N) then
8380 Enable_Overflow_Check (N);
8383 -- The result now has to be in Long_Long_Integer mode, so adjust
8384 -- the possible range to reflect this. Note these calls also
8385 -- change No_Uint values from the top level case to LLI bounds.
8390 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
8393 pragma Assert (Check_Mode = Eliminated);
8402 Fent := RTE (RE_Big_Abs);
8405 Fent := RTE (RE_Big_Add);
8408 Fent := RTE (RE_Big_Div);
8411 Fent := RTE (RE_Big_Exp);
8414 Fent := RTE (RE_Big_Neg);
8417 Fent := RTE (RE_Big_Mod);
8419 when N_Op_Multiply =>
8420 Fent := RTE (RE_Big_Mul);
8423 Fent := RTE (RE_Big_Rem);
8425 when N_Op_Subtract =>
8426 Fent := RTE (RE_Big_Sub);
8428 -- Anything else is an internal error, this includes the
8429 -- N_Op_Plus case, since how can plus cause the result
8430 -- to be out of range if the operand is in range?
8433 raise Program_Error;
8436 -- Construct argument list for Bignum call, converting our
8437 -- operands to Bignum form if they are not already there.
8442 Append_To (Args, Convert_To_Bignum (Left_Opnd (N)));
8445 Append_To (Args, Convert_To_Bignum (Right_Opnd (N)));
8447 -- Now rewrite the arithmetic operator with a call to the
8448 -- corresponding bignum function.
8451 Make_Function_Call (Loc,
8452 Name => New_Occurrence_Of (Fent, Loc),
8453 Parameter_Associations => Args));
8454 Reanalyze (RTE (RE_Bignum), Suppress => True);
8456 -- Indicate result is Bignum mode
8464 -- Otherwise we are in range of Long_Long_Integer, so no overflow
8465 -- check is required, at least not yet.
8468 Set_Do_Overflow_Check (N, False);
8471 -- Here we are not in Bignum territory, but we may have long long
8472 -- integer operands that need special handling. First a special check:
8473 -- If an exponentiation operator exponent is of type Long_Long_Integer,
8474 -- it means we converted it to prevent overflow, but exponentiation
8475 -- requires a Natural right operand, so convert it back to Natural.
8476 -- This conversion may raise an exception which is fine.
8478 if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then
8479 Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N));
8482 -- Here we will do the operation in Long_Long_Integer. We do this even
8483 -- if we know an overflow check is required, better to do this in long
8484 -- long integer mode, since we are less likely to overflow.
8486 -- Convert right or only operand to Long_Long_Integer, except that
8487 -- we do not touch the exponentiation right operand.
8489 if Nkind (N) /= N_Op_Expon then
8490 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
8493 -- Convert left operand to Long_Long_Integer for binary case
8496 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
8499 -- Reset node to unanalyzed
8501 Set_Analyzed (N, False);
8502 Set_Etype (N, Empty);
8503 Set_Entity (N, Empty);
8505 -- Now analyze this new node. This reanalysis will complete processing
8506 -- for the node. In particular we will complete the expansion of an
8507 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
8508 -- we will complete any division checks (since we have not changed the
8509 -- setting of the Do_Division_Check flag).
8511 -- We do this reanalysis in STRICT mode to avoid recursion into the
8512 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
8515 SG : constant Overflow_Mode_Type :=
8516 Scope_Suppress.Overflow_Mode_General;
8517 SA : constant Overflow_Mode_Type :=
8518 Scope_Suppress.Overflow_Mode_Assertions;
8521 Scope_Suppress.Overflow_Mode_General := Strict;
8522 Scope_Suppress.Overflow_Mode_Assertions := Strict;
8524 if not Do_Overflow_Check (N) then
8525 Reanalyze (LLIB, Suppress => True);
8530 Scope_Suppress.Overflow_Mode_General := SG;
8531 Scope_Suppress.Overflow_Mode_Assertions := SA;
8533 end Minimize_Eliminate_Overflows;
8535 -------------------------
8536 -- Overflow_Check_Mode --
8537 -------------------------
8539 function Overflow_Check_Mode return Overflow_Mode_Type is
8541 if In_Assertion_Expr = 0 then
8542 return Scope_Suppress.Overflow_Mode_General;
8544 return Scope_Suppress.Overflow_Mode_Assertions;
8546 end Overflow_Check_Mode;
8548 --------------------------------
8549 -- Overflow_Checks_Suppressed --
8550 --------------------------------
8552 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
8554 if Present (E) and then Checks_May_Be_Suppressed (E) then
8555 return Is_Check_Suppressed (E, Overflow_Check);
8557 return Scope_Suppress.Suppress (Overflow_Check);
8559 end Overflow_Checks_Suppressed;
8561 ---------------------------------
8562 -- Predicate_Checks_Suppressed --
8563 ---------------------------------
8565 function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
8567 if Present (E) and then Checks_May_Be_Suppressed (E) then
8568 return Is_Check_Suppressed (E, Predicate_Check);
8570 return Scope_Suppress.Suppress (Predicate_Check);
8572 end Predicate_Checks_Suppressed;
8574 -----------------------------
8575 -- Range_Checks_Suppressed --
8576 -----------------------------
8578 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
8581 if Kill_Range_Checks (E) then
8584 elsif Checks_May_Be_Suppressed (E) then
8585 return Is_Check_Suppressed (E, Range_Check);
8589 return Scope_Suppress.Suppress (Range_Check);
8590 end Range_Checks_Suppressed;
8592 -----------------------------------------
8593 -- Range_Or_Validity_Checks_Suppressed --
8594 -----------------------------------------
8596 -- Note: the coding would be simpler here if we simply made appropriate
8597 -- calls to Range/Validity_Checks_Suppressed, but that would result in
8598 -- duplicated checks which we prefer to avoid.
8600 function Range_Or_Validity_Checks_Suppressed
8601 (Expr : Node_Id) return Boolean
8604 -- Immediate return if scope checks suppressed for either check
8606 if Scope_Suppress.Suppress (Range_Check)
8608 Scope_Suppress.Suppress (Validity_Check)
8613 -- If no expression, that's odd, decide that checks are suppressed,
8614 -- since we don't want anyone trying to do checks in this case, which
8615 -- is most likely the result of some other error.
8621 -- Expression is present, so perform suppress checks on type
8624 Typ : constant Entity_Id := Etype (Expr);
8626 if Checks_May_Be_Suppressed (Typ)
8627 and then (Is_Check_Suppressed (Typ, Range_Check)
8629 Is_Check_Suppressed (Typ, Validity_Check))
8635 -- If expression is an entity name, perform checks on this entity
8637 if Is_Entity_Name (Expr) then
8639 Ent : constant Entity_Id := Entity (Expr);
8641 if Checks_May_Be_Suppressed (Ent) then
8642 return Is_Check_Suppressed (Ent, Range_Check)
8643 or else Is_Check_Suppressed (Ent, Validity_Check);
8648 -- If we fall through, no checks suppressed
8651 end Range_Or_Validity_Checks_Suppressed;
8657 procedure Remove_Checks (Expr : Node_Id) is
8658 function Process (N : Node_Id) return Traverse_Result;
8659 -- Process a single node during the traversal
8661 procedure Traverse is new Traverse_Proc (Process);
8662 -- The traversal procedure itself
8668 function Process (N : Node_Id) return Traverse_Result is
8670 if Nkind (N) not in N_Subexpr then
8674 Set_Do_Range_Check (N, False);
8678 Traverse (Left_Opnd (N));
8681 when N_Attribute_Reference =>
8682 Set_Do_Overflow_Check (N, False);
8684 when N_Function_Call =>
8685 Set_Do_Tag_Check (N, False);
8688 Set_Do_Overflow_Check (N, False);
8692 Set_Do_Division_Check (N, False);
8695 Set_Do_Length_Check (N, False);
8698 Set_Do_Division_Check (N, False);
8701 Set_Do_Length_Check (N, False);
8704 Set_Do_Division_Check (N, False);
8707 Set_Do_Length_Check (N, False);
8714 Traverse (Left_Opnd (N));
8717 when N_Selected_Component =>
8718 Set_Do_Discriminant_Check (N, False);
8720 when N_Type_Conversion =>
8721 Set_Do_Length_Check (N, False);
8722 Set_Do_Tag_Check (N, False);
8723 Set_Do_Overflow_Check (N, False);
8732 -- Start of processing for Remove_Checks
8738 ----------------------------
8739 -- Selected_Length_Checks --
8740 ----------------------------
8742 function Selected_Length_Checks
8744 Target_Typ : Entity_Id;
8745 Source_Typ : Entity_Id;
8746 Warn_Node : Node_Id) return Check_Result
8748 Loc : constant Source_Ptr := Sloc (Ck_Node);
8751 Expr_Actual : Node_Id;
8753 Cond : Node_Id := Empty;
8754 Do_Access : Boolean := False;
8755 Wnode : Node_Id := Warn_Node;
8756 Ret_Result : Check_Result := (Empty, Empty);
8757 Num_Checks : Natural := 0;
8759 procedure Add_Check (N : Node_Id);
8760 -- Adds the action given to Ret_Result if N is non-Empty
8762 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
8763 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
8764 -- Comments required ???
8766 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
8767 -- True for equal literals and for nodes that denote the same constant
8768 -- entity, even if its value is not a static constant. This includes the
8769 -- case of a discriminal reference within an init proc. Removes some
8770 -- obviously superfluous checks.
8772 function Length_E_Cond
8773 (Exptyp : Entity_Id;
8775 Indx : Nat) return Node_Id;
8776 -- Returns expression to compute:
8777 -- Typ'Length /= Exptyp'Length
8779 function Length_N_Cond
8782 Indx : Nat) return Node_Id;
8783 -- Returns expression to compute:
8784 -- Typ'Length /= Expr'Length
8790 procedure Add_Check (N : Node_Id) is
8794 -- For now, ignore attempt to place more than two checks ???
8795 -- This is really worrisome, are we really discarding checks ???
8797 if Num_Checks = 2 then
8801 pragma Assert (Num_Checks <= 1);
8802 Num_Checks := Num_Checks + 1;
8803 Ret_Result (Num_Checks) := N;
8811 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
8812 SE : constant Entity_Id := Scope (E);
8814 E1 : Entity_Id := E;
8817 if Ekind (Scope (E)) = E_Record_Type
8818 and then Has_Discriminants (Scope (E))
8820 N := Build_Discriminal_Subtype_Of_Component (E);
8823 Insert_Action (Ck_Node, N);
8824 E1 := Defining_Identifier (N);
8828 if Ekind (E1) = E_String_Literal_Subtype then
8830 Make_Integer_Literal (Loc,
8831 Intval => String_Literal_Length (E1));
8833 elsif SE /= Standard_Standard
8834 and then Ekind (Scope (SE)) = E_Protected_Type
8835 and then Has_Discriminants (Scope (SE))
8836 and then Has_Completion (Scope (SE))
8837 and then not Inside_Init_Proc
8839 -- If the type whose length is needed is a private component
8840 -- constrained by a discriminant, we must expand the 'Length
8841 -- attribute into an explicit computation, using the discriminal
8842 -- of the current protected operation. This is because the actual
8843 -- type of the prival is constructed after the protected opera-
8844 -- tion has been fully expanded.
8847 Indx_Type : Node_Id;
8850 Do_Expand : Boolean := False;
8853 Indx_Type := First_Index (E);
8855 for J in 1 .. Indx - 1 loop
8856 Next_Index (Indx_Type);
8859 Get_Index_Bounds (Indx_Type, Lo, Hi);
8861 if Nkind (Lo) = N_Identifier
8862 and then Ekind (Entity (Lo)) = E_In_Parameter
8864 Lo := Get_Discriminal (E, Lo);
8868 if Nkind (Hi) = N_Identifier
8869 and then Ekind (Entity (Hi)) = E_In_Parameter
8871 Hi := Get_Discriminal (E, Hi);
8876 if not Is_Entity_Name (Lo) then
8877 Lo := Duplicate_Subexpr_No_Checks (Lo);
8880 if not Is_Entity_Name (Hi) then
8881 Lo := Duplicate_Subexpr_No_Checks (Hi);
8887 Make_Op_Subtract (Loc,
8891 Right_Opnd => Make_Integer_Literal (Loc, 1));
8896 Make_Attribute_Reference (Loc,
8897 Attribute_Name => Name_Length,
8899 New_Occurrence_Of (E1, Loc));
8902 Set_Expressions (N, New_List (
8903 Make_Integer_Literal (Loc, Indx)));
8912 Make_Attribute_Reference (Loc,
8913 Attribute_Name => Name_Length,
8915 New_Occurrence_Of (E1, Loc));
8918 Set_Expressions (N, New_List (
8919 Make_Integer_Literal (Loc, Indx)));
8930 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
8933 Make_Attribute_Reference (Loc,
8934 Attribute_Name => Name_Length,
8936 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
8937 Expressions => New_List (
8938 Make_Integer_Literal (Loc, Indx)));
8945 function Length_E_Cond
8946 (Exptyp : Entity_Id;
8948 Indx : Nat) return Node_Id
8953 Left_Opnd => Get_E_Length (Typ, Indx),
8954 Right_Opnd => Get_E_Length (Exptyp, Indx));
8961 function Length_N_Cond
8964 Indx : Nat) return Node_Id
8969 Left_Opnd => Get_E_Length (Typ, Indx),
8970 Right_Opnd => Get_N_Length (Expr, Indx));
8977 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
8980 (Nkind (L) = N_Integer_Literal
8981 and then Nkind (R) = N_Integer_Literal
8982 and then Intval (L) = Intval (R))
8986 and then Ekind (Entity (L)) = E_Constant
8987 and then ((Is_Entity_Name (R)
8988 and then Entity (L) = Entity (R))
8990 (Nkind (R) = N_Type_Conversion
8991 and then Is_Entity_Name (Expression (R))
8992 and then Entity (L) = Entity (Expression (R)))))
8996 and then Ekind (Entity (R)) = E_Constant
8997 and then Nkind (L) = N_Type_Conversion
8998 and then Is_Entity_Name (Expression (L))
8999 and then Entity (R) = Entity (Expression (L)))
9003 and then Is_Entity_Name (R)
9004 and then Entity (L) = Entity (R)
9005 and then Ekind (Entity (L)) = E_In_Parameter
9006 and then Inside_Init_Proc);
9009 -- Start of processing for Selected_Length_Checks
9012 if not Expander_Active then
9016 if Target_Typ = Any_Type
9017 or else Target_Typ = Any_Composite
9018 or else Raises_Constraint_Error (Ck_Node)
9027 T_Typ := Target_Typ;
9029 if No (Source_Typ) then
9030 S_Typ := Etype (Ck_Node);
9032 S_Typ := Source_Typ;
9035 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9039 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9040 S_Typ := Designated_Type (S_Typ);
9041 T_Typ := Designated_Type (T_Typ);
9044 -- A simple optimization for the null case
9046 if Known_Null (Ck_Node) then
9051 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9052 if Is_Constrained (T_Typ) then
9054 -- The checking code to be generated will freeze the corresponding
9055 -- array type. However, we must freeze the type now, so that the
9056 -- freeze node does not appear within the generated if expression,
9059 Freeze_Before (Ck_Node, T_Typ);
9061 Expr_Actual := Get_Referenced_Object (Ck_Node);
9062 Exptyp := Get_Actual_Subtype (Ck_Node);
9064 if Is_Access_Type (Exptyp) then
9065 Exptyp := Designated_Type (Exptyp);
9068 -- String_Literal case. This needs to be handled specially be-
9069 -- cause no index types are available for string literals. The
9070 -- condition is simply:
9072 -- T_Typ'Length = string-literal-length
9074 if Nkind (Expr_Actual) = N_String_Literal
9075 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
9079 Left_Opnd => Get_E_Length (T_Typ, 1),
9081 Make_Integer_Literal (Loc,
9083 String_Literal_Length (Etype (Expr_Actual))));
9085 -- General array case. Here we have a usable actual subtype for
9086 -- the expression, and the condition is built from the two types
9089 -- T_Typ'Length /= Exptyp'Length or else
9090 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9091 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9094 elsif Is_Constrained (Exptyp) then
9096 Ndims : constant Nat := Number_Dimensions (T_Typ);
9109 -- At the library level, we need to ensure that the type of
9110 -- the object is elaborated before the check itself is
9111 -- emitted. This is only done if the object is in the
9112 -- current compilation unit, otherwise the type is frozen
9113 -- and elaborated in its unit.
9115 if Is_Itype (Exptyp)
9117 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
9119 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
9120 and then In_Open_Scopes (Scope (Exptyp))
9122 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
9123 Set_Itype (Ref_Node, Exptyp);
9124 Insert_Action (Ck_Node, Ref_Node);
9127 L_Index := First_Index (T_Typ);
9128 R_Index := First_Index (Exptyp);
9130 for Indx in 1 .. Ndims loop
9131 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9133 Nkind (R_Index) = N_Raise_Constraint_Error)
9135 Get_Index_Bounds (L_Index, L_Low, L_High);
9136 Get_Index_Bounds (R_Index, R_Low, R_High);
9138 -- Deal with compile time length check. Note that we
9139 -- skip this in the access case, because the access
9140 -- value may be null, so we cannot know statically.
9143 and then Compile_Time_Known_Value (L_Low)
9144 and then Compile_Time_Known_Value (L_High)
9145 and then Compile_Time_Known_Value (R_Low)
9146 and then Compile_Time_Known_Value (R_High)
9148 if Expr_Value (L_High) >= Expr_Value (L_Low) then
9149 L_Length := Expr_Value (L_High) -
9150 Expr_Value (L_Low) + 1;
9152 L_Length := UI_From_Int (0);
9155 if Expr_Value (R_High) >= Expr_Value (R_Low) then
9156 R_Length := Expr_Value (R_High) -
9157 Expr_Value (R_Low) + 1;
9159 R_Length := UI_From_Int (0);
9162 if L_Length > R_Length then
9164 (Compile_Time_Constraint_Error
9165 (Wnode, "too few elements for}??", T_Typ));
9167 elsif L_Length < R_Length then
9169 (Compile_Time_Constraint_Error
9170 (Wnode, "too many elements for}??", T_Typ));
9173 -- The comparison for an individual index subtype
9174 -- is omitted if the corresponding index subtypes
9175 -- statically match, since the result is known to
9176 -- be true. Note that this test is worth while even
9177 -- though we do static evaluation, because non-static
9178 -- subtypes can statically match.
9181 Subtypes_Statically_Match
9182 (Etype (L_Index), Etype (R_Index))
9185 (Same_Bounds (L_Low, R_Low)
9186 and then Same_Bounds (L_High, R_High))
9189 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
9198 -- Handle cases where we do not get a usable actual subtype that
9199 -- is constrained. This happens for example in the function call
9200 -- and explicit dereference cases. In these cases, we have to get
9201 -- the length or range from the expression itself, making sure we
9202 -- do not evaluate it more than once.
9204 -- Here Ck_Node is the original expression, or more properly the
9205 -- result of applying Duplicate_Expr to the original tree, forcing
9206 -- the result to be a name.
9210 Ndims : constant Nat := Number_Dimensions (T_Typ);
9213 -- Build the condition for the explicit dereference case
9215 for Indx in 1 .. Ndims loop
9217 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
9224 -- Construct the test and insert into the tree
9226 if Present (Cond) then
9228 Cond := Guard_Access (Cond, Loc, Ck_Node);
9232 (Make_Raise_Constraint_Error (Loc,
9234 Reason => CE_Length_Check_Failed));
9238 end Selected_Length_Checks;
9240 ---------------------------
9241 -- Selected_Range_Checks --
9242 ---------------------------
9244 function Selected_Range_Checks
9246 Target_Typ : Entity_Id;
9247 Source_Typ : Entity_Id;
9248 Warn_Node : Node_Id) return Check_Result
9250 Loc : constant Source_Ptr := Sloc (Ck_Node);
9253 Expr_Actual : Node_Id;
9255 Cond : Node_Id := Empty;
9256 Do_Access : Boolean := False;
9257 Wnode : Node_Id := Warn_Node;
9258 Ret_Result : Check_Result := (Empty, Empty);
9259 Num_Checks : Integer := 0;
9261 procedure Add_Check (N : Node_Id);
9262 -- Adds the action given to Ret_Result if N is non-Empty
9264 function Discrete_Range_Cond
9266 Typ : Entity_Id) return Node_Id;
9267 -- Returns expression to compute:
9268 -- Low_Bound (Expr) < Typ'First
9270 -- High_Bound (Expr) > Typ'Last
9272 function Discrete_Expr_Cond
9274 Typ : Entity_Id) return Node_Id;
9275 -- Returns expression to compute:
9280 function Get_E_First_Or_Last
9284 Nam : Name_Id) return Node_Id;
9285 -- Returns an attribute reference
9286 -- E'First or E'Last
9287 -- with a source location of Loc.
9289 -- Nam is Name_First or Name_Last, according to which attribute is
9290 -- desired. If Indx is non-zero, it is passed as a literal in the
9291 -- Expressions of the attribute reference (identifying the desired
9292 -- array dimension).
9294 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
9295 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
9296 -- Returns expression to compute:
9297 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9299 function Range_E_Cond
9300 (Exptyp : Entity_Id;
9304 -- Returns expression to compute:
9305 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9307 function Range_Equal_E_Cond
9308 (Exptyp : Entity_Id;
9310 Indx : Nat) return Node_Id;
9311 -- Returns expression to compute:
9312 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9314 function Range_N_Cond
9317 Indx : Nat) return Node_Id;
9318 -- Return expression to compute:
9319 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
9325 procedure Add_Check (N : Node_Id) is
9329 -- For now, ignore attempt to place more than 2 checks ???
9331 if Num_Checks = 2 then
9335 pragma Assert (Num_Checks <= 1);
9336 Num_Checks := Num_Checks + 1;
9337 Ret_Result (Num_Checks) := N;
9341 -------------------------
9342 -- Discrete_Expr_Cond --
9343 -------------------------
9345 function Discrete_Expr_Cond
9347 Typ : Entity_Id) return Node_Id
9355 Convert_To (Base_Type (Typ),
9356 Duplicate_Subexpr_No_Checks (Expr)),
9358 Convert_To (Base_Type (Typ),
9359 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
9364 Convert_To (Base_Type (Typ),
9365 Duplicate_Subexpr_No_Checks (Expr)),
9369 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
9370 end Discrete_Expr_Cond;
9372 -------------------------
9373 -- Discrete_Range_Cond --
9374 -------------------------
9376 function Discrete_Range_Cond
9378 Typ : Entity_Id) return Node_Id
9380 LB : Node_Id := Low_Bound (Expr);
9381 HB : Node_Id := High_Bound (Expr);
9383 Left_Opnd : Node_Id;
9384 Right_Opnd : Node_Id;
9387 if Nkind (LB) = N_Identifier
9388 and then Ekind (Entity (LB)) = E_Discriminant
9390 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9397 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
9402 Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
9404 if Nkind (HB) = N_Identifier
9405 and then Ekind (Entity (HB)) = E_Discriminant
9407 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9414 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
9419 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
9421 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
9422 end Discrete_Range_Cond;
9424 -------------------------
9425 -- Get_E_First_Or_Last --
9426 -------------------------
9428 function Get_E_First_Or_Last
9432 Nam : Name_Id) return Node_Id
9437 Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
9442 return Make_Attribute_Reference (Loc,
9443 Prefix => New_Occurrence_Of (E, Loc),
9444 Attribute_Name => Nam,
9445 Expressions => Exprs);
9446 end Get_E_First_Or_Last;
9452 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
9455 Make_Attribute_Reference (Loc,
9456 Attribute_Name => Name_First,
9458 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9459 Expressions => New_List (
9460 Make_Integer_Literal (Loc, Indx)));
9467 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
9470 Make_Attribute_Reference (Loc,
9471 Attribute_Name => Name_Last,
9473 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9474 Expressions => New_List (
9475 Make_Integer_Literal (Loc, Indx)));
9482 function Range_E_Cond
9483 (Exptyp : Entity_Id;
9485 Indx : Nat) return Node_Id
9493 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9495 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9500 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9502 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9505 ------------------------
9506 -- Range_Equal_E_Cond --
9507 ------------------------
9509 function Range_Equal_E_Cond
9510 (Exptyp : Entity_Id;
9512 Indx : Nat) return Node_Id
9520 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9522 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9527 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9529 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9530 end Range_Equal_E_Cond;
9536 function Range_N_Cond
9539 Indx : Nat) return Node_Id
9547 Get_N_First (Expr, Indx),
9549 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9554 Get_N_Last (Expr, Indx),
9556 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9559 -- Start of processing for Selected_Range_Checks
9562 if not Expander_Active then
9566 if Target_Typ = Any_Type
9567 or else Target_Typ = Any_Composite
9568 or else Raises_Constraint_Error (Ck_Node)
9577 T_Typ := Target_Typ;
9579 if No (Source_Typ) then
9580 S_Typ := Etype (Ck_Node);
9582 S_Typ := Source_Typ;
9585 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9589 -- The order of evaluating T_Typ before S_Typ seems to be critical
9590 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
9591 -- in, and since Node can be an N_Range node, it might be invalid.
9592 -- Should there be an assert check somewhere for taking the Etype of
9593 -- an N_Range node ???
9595 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9596 S_Typ := Designated_Type (S_Typ);
9597 T_Typ := Designated_Type (T_Typ);
9600 -- A simple optimization for the null case
9602 if Known_Null (Ck_Node) then
9607 -- For an N_Range Node, check for a null range and then if not
9608 -- null generate a range check action.
9610 if Nkind (Ck_Node) = N_Range then
9612 -- There's no point in checking a range against itself
9614 if Ck_Node = Scalar_Range (T_Typ) then
9619 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
9620 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
9621 Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
9622 Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
9624 LB : Node_Id := Low_Bound (Ck_Node);
9625 HB : Node_Id := High_Bound (Ck_Node);
9629 Null_Range : Boolean;
9630 Out_Of_Range_L : Boolean;
9631 Out_Of_Range_H : Boolean;
9634 -- Compute what is known at compile time
9636 if Known_T_LB and Known_T_HB then
9637 if Compile_Time_Known_Value (LB) then
9640 -- There's no point in checking that a bound is within its
9641 -- own range so pretend that it is known in this case. First
9642 -- deal with low bound.
9644 elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype
9645 and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ)
9654 -- Likewise for the high bound
9656 if Compile_Time_Known_Value (HB) then
9659 elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype
9660 and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ)
9669 -- Check for case where everything is static and we can do the
9670 -- check at compile time. This is skipped if we have an access
9671 -- type, since the access value may be null.
9673 -- ??? This code can be improved since you only need to know that
9674 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9675 -- compile time to emit pertinent messages.
9677 if Known_T_LB and Known_T_HB and Known_LB and Known_HB
9680 -- Floating-point case
9682 if Is_Floating_Point_Type (S_Typ) then
9683 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
9685 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
9687 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
9690 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
9692 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
9694 -- Fixed or discrete type case
9697 Null_Range := Expr_Value (HB) < Expr_Value (LB);
9699 (Expr_Value (LB) < Expr_Value (T_LB))
9701 (Expr_Value (LB) > Expr_Value (T_HB));
9704 (Expr_Value (HB) > Expr_Value (T_HB))
9706 (Expr_Value (HB) < Expr_Value (T_LB));
9709 if not Null_Range then
9710 if Out_Of_Range_L then
9711 if No (Warn_Node) then
9713 (Compile_Time_Constraint_Error
9714 (Low_Bound (Ck_Node),
9715 "static value out of range of}??", T_Typ));
9719 (Compile_Time_Constraint_Error
9721 "static range out of bounds of}??", T_Typ));
9725 if Out_Of_Range_H then
9726 if No (Warn_Node) then
9728 (Compile_Time_Constraint_Error
9729 (High_Bound (Ck_Node),
9730 "static value out of range of}??", T_Typ));
9734 (Compile_Time_Constraint_Error
9736 "static range out of bounds of}??", T_Typ));
9743 LB : Node_Id := Low_Bound (Ck_Node);
9744 HB : Node_Id := High_Bound (Ck_Node);
9747 -- If either bound is a discriminant and we are within the
9748 -- record declaration, it is a use of the discriminant in a
9749 -- constraint of a component, and nothing can be checked
9750 -- here. The check will be emitted within the init proc.
9751 -- Before then, the discriminal has no real meaning.
9752 -- Similarly, if the entity is a discriminal, there is no
9753 -- check to perform yet.
9755 -- The same holds within a discriminated synchronized type,
9756 -- where the discriminant may constrain a component or an
9759 if Nkind (LB) = N_Identifier
9760 and then Denotes_Discriminant (LB, True)
9762 if Current_Scope = Scope (Entity (LB))
9763 or else Is_Concurrent_Type (Current_Scope)
9764 or else Ekind (Entity (LB)) /= E_Discriminant
9769 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9773 if Nkind (HB) = N_Identifier
9774 and then Denotes_Discriminant (HB, True)
9776 if Current_Scope = Scope (Entity (HB))
9777 or else Is_Concurrent_Type (Current_Scope)
9778 or else Ekind (Entity (HB)) /= E_Discriminant
9783 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9787 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
9788 Set_Paren_Count (Cond, 1);
9795 Convert_To (Base_Type (Etype (HB)),
9796 Duplicate_Subexpr_No_Checks (HB)),
9798 Convert_To (Base_Type (Etype (LB)),
9799 Duplicate_Subexpr_No_Checks (LB))),
9800 Right_Opnd => Cond);
9805 elsif Is_Scalar_Type (S_Typ) then
9807 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9808 -- except the above simply sets a flag in the node and lets
9809 -- gigi generate the check base on the Etype of the expression.
9810 -- Sometimes, however we want to do a dynamic check against an
9811 -- arbitrary target type, so we do that here.
9813 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
9814 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9816 -- For literals, we can tell if the constraint error will be
9817 -- raised at compile time, so we never need a dynamic check, but
9818 -- if the exception will be raised, then post the usual warning,
9819 -- and replace the literal with a raise constraint error
9820 -- expression. As usual, skip this for access types
9822 elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
9824 LB : constant Node_Id := Type_Low_Bound (T_Typ);
9825 UB : constant Node_Id := Type_High_Bound (T_Typ);
9827 Out_Of_Range : Boolean;
9828 Static_Bounds : constant Boolean :=
9829 Compile_Time_Known_Value (LB)
9830 and Compile_Time_Known_Value (UB);
9833 -- Following range tests should use Sem_Eval routine ???
9835 if Static_Bounds then
9836 if Is_Floating_Point_Type (S_Typ) then
9838 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
9840 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
9842 -- Fixed or discrete type
9846 Expr_Value (Ck_Node) < Expr_Value (LB)
9848 Expr_Value (Ck_Node) > Expr_Value (UB);
9851 -- Bounds of the type are static and the literal is out of
9852 -- range so output a warning message.
9854 if Out_Of_Range then
9855 if No (Warn_Node) then
9857 (Compile_Time_Constraint_Error
9859 "static value out of range of}??", T_Typ));
9863 (Compile_Time_Constraint_Error
9865 "static value out of range of}??", T_Typ));
9870 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9874 -- Here for the case of a non-static expression, we need a runtime
9875 -- check unless the source type range is guaranteed to be in the
9876 -- range of the target type.
9879 if not In_Subrange_Of (S_Typ, T_Typ) then
9880 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9885 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9886 if Is_Constrained (T_Typ) then
9888 Expr_Actual := Get_Referenced_Object (Ck_Node);
9889 Exptyp := Get_Actual_Subtype (Expr_Actual);
9891 if Is_Access_Type (Exptyp) then
9892 Exptyp := Designated_Type (Exptyp);
9895 -- String_Literal case. This needs to be handled specially be-
9896 -- cause no index types are available for string literals. The
9897 -- condition is simply:
9899 -- T_Typ'Length = string-literal-length
9901 if Nkind (Expr_Actual) = N_String_Literal then
9904 -- General array case. Here we have a usable actual subtype for
9905 -- the expression, and the condition is built from the two types
9907 -- T_Typ'First < Exptyp'First or else
9908 -- T_Typ'Last > Exptyp'Last or else
9909 -- T_Typ'First(1) < Exptyp'First(1) or else
9910 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9913 elsif Is_Constrained (Exptyp) then
9915 Ndims : constant Nat := Number_Dimensions (T_Typ);
9921 L_Index := First_Index (T_Typ);
9922 R_Index := First_Index (Exptyp);
9924 for Indx in 1 .. Ndims loop
9925 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9927 Nkind (R_Index) = N_Raise_Constraint_Error)
9929 -- Deal with compile time length check. Note that we
9930 -- skip this in the access case, because the access
9931 -- value may be null, so we cannot know statically.
9934 Subtypes_Statically_Match
9935 (Etype (L_Index), Etype (R_Index))
9937 -- If the target type is constrained then we
9938 -- have to check for exact equality of bounds
9939 -- (required for qualified expressions).
9941 if Is_Constrained (T_Typ) then
9944 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
9947 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
9957 -- Handle cases where we do not get a usable actual subtype that
9958 -- is constrained. This happens for example in the function call
9959 -- and explicit dereference cases. In these cases, we have to get
9960 -- the length or range from the expression itself, making sure we
9961 -- do not evaluate it more than once.
9963 -- Here Ck_Node is the original expression, or more properly the
9964 -- result of applying Duplicate_Expr to the original tree,
9965 -- forcing the result to be a name.
9969 Ndims : constant Nat := Number_Dimensions (T_Typ);
9972 -- Build the condition for the explicit dereference case
9974 for Indx in 1 .. Ndims loop
9976 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
9982 -- For a conversion to an unconstrained array type, generate an
9983 -- Action to check that the bounds of the source value are within
9984 -- the constraints imposed by the target type (RM 4.6(38)). No
9985 -- check is needed for a conversion to an access to unconstrained
9986 -- array type, as 4.6(24.15/2) requires the designated subtypes
9987 -- of the two access types to statically match.
9989 if Nkind (Parent (Ck_Node)) = N_Type_Conversion
9990 and then not Do_Access
9993 Opnd_Index : Node_Id;
9994 Targ_Index : Node_Id;
9995 Opnd_Range : Node_Id;
9998 Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
9999 Targ_Index := First_Index (T_Typ);
10000 while Present (Opnd_Index) loop
10002 -- If the index is a range, use its bounds. If it is an
10003 -- entity (as will be the case if it is a named subtype
10004 -- or an itype created for a slice) retrieve its range.
10006 if Is_Entity_Name (Opnd_Index)
10007 and then Is_Type (Entity (Opnd_Index))
10009 Opnd_Range := Scalar_Range (Entity (Opnd_Index));
10011 Opnd_Range := Opnd_Index;
10014 if Nkind (Opnd_Range) = N_Range then
10016 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10017 Assume_Valid => True)
10020 (High_Bound (Opnd_Range), Etype (Targ_Index),
10021 Assume_Valid => True)
10025 -- If null range, no check needed
10028 Compile_Time_Known_Value (High_Bound (Opnd_Range))
10030 Compile_Time_Known_Value (Low_Bound (Opnd_Range))
10032 Expr_Value (High_Bound (Opnd_Range)) <
10033 Expr_Value (Low_Bound (Opnd_Range))
10037 elsif Is_Out_Of_Range
10038 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10039 Assume_Valid => True)
10042 (High_Bound (Opnd_Range), Etype (Targ_Index),
10043 Assume_Valid => True)
10046 (Compile_Time_Constraint_Error
10047 (Wnode, "value out of range of}??", T_Typ));
10052 Discrete_Range_Cond
10053 (Opnd_Range, Etype (Targ_Index)));
10057 Next_Index (Opnd_Index);
10058 Next_Index (Targ_Index);
10065 -- Construct the test and insert into the tree
10067 if Present (Cond) then
10069 Cond := Guard_Access (Cond, Loc, Ck_Node);
10073 (Make_Raise_Constraint_Error (Loc,
10075 Reason => CE_Range_Check_Failed));
10079 end Selected_Range_Checks;
10081 -------------------------------
10082 -- Storage_Checks_Suppressed --
10083 -------------------------------
10085 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
10087 if Present (E) and then Checks_May_Be_Suppressed (E) then
10088 return Is_Check_Suppressed (E, Storage_Check);
10090 return Scope_Suppress.Suppress (Storage_Check);
10092 end Storage_Checks_Suppressed;
10094 ---------------------------
10095 -- Tag_Checks_Suppressed --
10096 ---------------------------
10098 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
10101 and then Checks_May_Be_Suppressed (E)
10103 return Is_Check_Suppressed (E, Tag_Check);
10105 return Scope_Suppress.Suppress (Tag_Check);
10107 end Tag_Checks_Suppressed;
10109 ---------------------------------------
10110 -- Validate_Alignment_Check_Warnings --
10111 ---------------------------------------
10113 procedure Validate_Alignment_Check_Warnings is
10115 for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop
10117 AWR : Alignment_Warnings_Record
10118 renames Alignment_Warnings.Table (J);
10120 if Known_Alignment (AWR.E)
10121 and then AWR.A mod Alignment (AWR.E) = 0
10123 Delete_Warning_And_Continuations (AWR.W);
10127 end Validate_Alignment_Check_Warnings;
10129 --------------------------
10130 -- Validity_Check_Range --
10131 --------------------------
10133 procedure Validity_Check_Range
10135 Related_Id : Entity_Id := Empty)
10138 if Validity_Checks_On and Validity_Check_Operands then
10139 if Nkind (N) = N_Range then
10141 (Expr => Low_Bound (N),
10142 Related_Id => Related_Id,
10143 Is_Low_Bound => True);
10146 (Expr => High_Bound (N),
10147 Related_Id => Related_Id,
10148 Is_High_Bound => True);
10151 end Validity_Check_Range;
10153 --------------------------------
10154 -- Validity_Checks_Suppressed --
10155 --------------------------------
10157 function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
10159 if Present (E) and then Checks_May_Be_Suppressed (E) then
10160 return Is_Check_Suppressed (E, Validity_Check);
10162 return Scope_Suppress.Suppress (Validity_Check);
10164 end Validity_Checks_Suppressed;