1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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.
340 -- ??? In fact it does construct the test and insert it into the tree,
341 -- and insert actions in various ways (calling Insert_Action directly
342 -- in particular) so we do not call it in GNATprove mode, contrary to
343 -- Selected_Range_Checks.
345 function Selected_Range_Checks
347 Target_Typ : Entity_Id;
348 Source_Typ : Entity_Id;
349 Warn_Node : Node_Id) return Check_Result;
350 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
351 -- just returns a list of nodes as described in the spec of this package
352 -- for the Range_Check function.
354 ------------------------------
355 -- Access_Checks_Suppressed --
356 ------------------------------
358 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
360 if Present (E) and then Checks_May_Be_Suppressed (E) then
361 return Is_Check_Suppressed (E, Access_Check);
363 return Scope_Suppress.Suppress (Access_Check);
365 end Access_Checks_Suppressed;
367 -------------------------------------
368 -- Accessibility_Checks_Suppressed --
369 -------------------------------------
371 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
373 if Present (E) and then Checks_May_Be_Suppressed (E) then
374 return Is_Check_Suppressed (E, Accessibility_Check);
376 return Scope_Suppress.Suppress (Accessibility_Check);
378 end Accessibility_Checks_Suppressed;
380 -----------------------------
381 -- Activate_Division_Check --
382 -----------------------------
384 procedure Activate_Division_Check (N : Node_Id) is
386 Set_Do_Division_Check (N, True);
387 Possible_Local_Raise (N, Standard_Constraint_Error);
388 end Activate_Division_Check;
390 -----------------------------
391 -- Activate_Overflow_Check --
392 -----------------------------
394 procedure Activate_Overflow_Check (N : Node_Id) is
395 Typ : constant Entity_Id := Etype (N);
398 -- Floating-point case. If Etype is not set (this can happen when we
399 -- activate a check on a node that has not yet been analyzed), then
400 -- we assume we do not have a floating-point type (as per our spec).
402 if Present (Typ) and then Is_Floating_Point_Type (Typ) then
404 -- Ignore call if we have no automatic overflow checks on the target
405 -- and Check_Float_Overflow mode is not set. These are the cases in
406 -- which we expect to generate infinities and NaN's with no check.
408 if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
411 -- Ignore for unary operations ("+", "-", abs) since these can never
412 -- result in overflow for floating-point cases.
414 elsif Nkind (N) in N_Unary_Op then
417 -- Otherwise we will set the flag
426 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
427 -- for zero-divide is a divide check, not an overflow check).
429 if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
434 -- Fall through for cases where we do set the flag
436 Set_Do_Overflow_Check (N, True);
437 Possible_Local_Raise (N, Standard_Constraint_Error);
438 end Activate_Overflow_Check;
440 --------------------------
441 -- Activate_Range_Check --
442 --------------------------
444 procedure Activate_Range_Check (N : Node_Id) is
446 Set_Do_Range_Check (N, True);
447 Possible_Local_Raise (N, Standard_Constraint_Error);
448 end Activate_Range_Check;
450 ---------------------------------
451 -- Alignment_Checks_Suppressed --
452 ---------------------------------
454 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
456 if Present (E) and then Checks_May_Be_Suppressed (E) then
457 return Is_Check_Suppressed (E, Alignment_Check);
459 return Scope_Suppress.Suppress (Alignment_Check);
461 end Alignment_Checks_Suppressed;
463 ----------------------------------
464 -- Allocation_Checks_Suppressed --
465 ----------------------------------
467 -- Note: at the current time there are no calls to this function, because
468 -- the relevant check is in the run-time, so it is not a check that the
469 -- compiler can suppress anyway, but we still have to recognize the check
470 -- name Allocation_Check since it is part of the standard.
472 function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
474 if Present (E) and then Checks_May_Be_Suppressed (E) then
475 return Is_Check_Suppressed (E, Allocation_Check);
477 return Scope_Suppress.Suppress (Allocation_Check);
479 end Allocation_Checks_Suppressed;
481 -------------------------
482 -- Append_Range_Checks --
483 -------------------------
485 procedure Append_Range_Checks
486 (Checks : Check_Result;
488 Suppress_Typ : Entity_Id;
489 Static_Sloc : Source_Ptr;
492 Internal_Flag_Node : constant Node_Id := Flag_Node;
493 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
495 Checks_On : constant Boolean :=
496 (not Index_Checks_Suppressed (Suppress_Typ))
497 or else (not Range_Checks_Suppressed (Suppress_Typ));
500 -- For now we just return if Checks_On is false, however this should
501 -- be enhanced to check for an always True value in the condition
502 -- and to generate a compilation warning???
504 if not Checks_On then
509 exit when No (Checks (J));
511 if Nkind (Checks (J)) = N_Raise_Constraint_Error
512 and then Present (Condition (Checks (J)))
514 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
515 Append_To (Stmts, Checks (J));
516 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
522 Make_Raise_Constraint_Error (Internal_Static_Sloc,
523 Reason => CE_Range_Check_Failed));
526 end Append_Range_Checks;
528 ------------------------
529 -- Apply_Access_Check --
530 ------------------------
532 procedure Apply_Access_Check (N : Node_Id) is
533 P : constant Node_Id := Prefix (N);
536 -- We do not need checks if we are not generating code (i.e. the
537 -- expander is not active). This is not just an optimization, there
538 -- are cases (e.g. with pragma Debug) where generating the checks
539 -- can cause real trouble).
541 if not Expander_Active then
545 -- No check if short circuiting makes check unnecessary
547 if not Check_Needed (P, Access_Check) then
551 -- No check if accessing the Offset_To_Top component of a dispatch
552 -- table. They are safe by construction.
554 if Tagged_Type_Expansion
555 and then Present (Etype (P))
556 and then RTU_Loaded (Ada_Tags)
557 and then RTE_Available (RE_Offset_To_Top_Ptr)
558 and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
563 -- Otherwise go ahead and install the check
565 Install_Null_Excluding_Check (P);
566 end Apply_Access_Check;
568 -------------------------------
569 -- Apply_Accessibility_Check --
570 -------------------------------
572 procedure Apply_Accessibility_Check
575 Insert_Node : Node_Id)
577 Loc : constant Source_Ptr := Sloc (N);
578 Param_Ent : Entity_Id := Param_Entity (N);
579 Param_Level : Node_Id;
580 Type_Level : Node_Id;
583 if Ada_Version >= Ada_2012
584 and then not Present (Param_Ent)
585 and then Is_Entity_Name (N)
586 and then Ekind_In (Entity (N), E_Constant, E_Variable)
587 and then Present (Effective_Extra_Accessibility (Entity (N)))
589 Param_Ent := Entity (N);
590 while Present (Renamed_Object (Param_Ent)) loop
592 -- Renamed_Object must return an Entity_Name here
593 -- because of preceding "Present (E_E_A (...))" test.
595 Param_Ent := Entity (Renamed_Object (Param_Ent));
599 if Inside_A_Generic then
602 -- Only apply the run-time check if the access parameter has an
603 -- associated extra access level parameter and when the level of the
604 -- type is less deep than the level of the access parameter, and
605 -- accessibility checks are not suppressed.
607 elsif Present (Param_Ent)
608 and then Present (Extra_Accessibility (Param_Ent))
609 and then UI_Gt (Object_Access_Level (N),
610 Deepest_Type_Access_Level (Typ))
611 and then not Accessibility_Checks_Suppressed (Param_Ent)
612 and then not Accessibility_Checks_Suppressed (Typ)
615 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
618 Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
620 -- Raise Program_Error if the accessibility level of the access
621 -- parameter is deeper than the level of the target access type.
623 Insert_Action (Insert_Node,
624 Make_Raise_Program_Error (Loc,
627 Left_Opnd => Param_Level,
628 Right_Opnd => Type_Level),
629 Reason => PE_Accessibility_Check_Failed));
631 Analyze_And_Resolve (N);
633 end Apply_Accessibility_Check;
635 --------------------------------
636 -- Apply_Address_Clause_Check --
637 --------------------------------
639 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
640 pragma Assert (Nkind (N) = N_Freeze_Entity);
642 AC : constant Node_Id := Address_Clause (E);
643 Loc : constant Source_Ptr := Sloc (AC);
644 Typ : constant Entity_Id := Etype (E);
647 -- Address expression (not necessarily the same as Aexp, for example
648 -- when Aexp is a reference to a constant, in which case Expr gets
649 -- reset to reference the value expression of the constant).
652 -- See if alignment check needed. Note that we never need a check if the
653 -- maximum alignment is one, since the check will always succeed.
655 -- Note: we do not check for checks suppressed here, since that check
656 -- was done in Sem_Ch13 when the address clause was processed. We are
657 -- only called if checks were not suppressed. The reason for this is
658 -- that we have to delay the call to Apply_Alignment_Check till freeze
659 -- time (so that all types etc are elaborated), but we have to check
660 -- the status of check suppressing at the point of the address clause.
663 or else not Check_Address_Alignment (AC)
664 or else Maximum_Alignment = 1
669 -- Obtain expression from address clause
671 Expr := Address_Value (Expression (AC));
673 -- See if we know that Expr has an acceptable value at compile time. If
674 -- it hasn't or we don't know, we defer issuing the warning until the
675 -- end of the compilation to take into account back end annotations.
677 if Compile_Time_Known_Value (Expr)
678 and then (Known_Alignment (E) or else Known_Alignment (Typ))
681 AL : Uint := Alignment (Typ);
684 -- The object alignment might be more restrictive than the type
687 if Known_Alignment (E) then
691 if Expr_Value (Expr) mod AL = 0 then
696 -- If the expression has the form X'Address, then we can find out if the
697 -- object X has an alignment that is compatible with the object E. If it
698 -- hasn't or we don't know, we defer issuing the warning until the end
699 -- of the compilation to take into account back end annotations.
701 elsif Nkind (Expr) = N_Attribute_Reference
702 and then Attribute_Name (Expr) = Name_Address
704 Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible
709 -- Here we do not know if the value is acceptable. Strictly we don't
710 -- have to do anything, since if the alignment is bad, we have an
711 -- erroneous program. However we are allowed to check for erroneous
712 -- conditions and we decide to do this by default if the check is not
715 -- However, don't do the check if elaboration code is unwanted
717 if Restriction_Active (No_Elaboration_Code) then
720 -- Generate a check to raise PE if alignment may be inappropriate
723 -- If the original expression is a non-static constant, use the name
724 -- of the constant itself rather than duplicating its initialization
725 -- expression, which was extracted above.
727 -- Note: Expr is empty if the address-clause is applied to in-mode
728 -- actuals (allowed by 13.1(22)).
730 if not Present (Expr)
732 (Is_Entity_Name (Expression (AC))
733 and then Ekind (Entity (Expression (AC))) = E_Constant
734 and then Nkind (Parent (Entity (Expression (AC)))) =
735 N_Object_Declaration)
737 Expr := New_Copy_Tree (Expression (AC));
739 Remove_Side_Effects (Expr);
742 if No (Actions (N)) then
743 Set_Actions (N, New_List);
746 Prepend_To (Actions (N),
747 Make_Raise_Program_Error (Loc,
754 (RTE (RE_Integer_Address), Expr),
756 Make_Attribute_Reference (Loc,
757 Prefix => New_Occurrence_Of (E, Loc),
758 Attribute_Name => Name_Alignment)),
759 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
760 Reason => PE_Misaligned_Address_Value));
762 Warning_Msg := No_Error_Msg;
763 Analyze (First (Actions (N)), Suppress => All_Checks);
765 -- If the above raise action generated a warning message (for example
766 -- from Warn_On_Non_Local_Exception mode with the active restriction
767 -- No_Exception_Propagation).
769 if Warning_Msg /= No_Error_Msg then
771 -- If the expression has a known at compile time value, then
772 -- once we know the alignment of the type, we can check if the
773 -- exception will be raised or not, and if not, we don't need
774 -- the warning so we will kill the warning later on.
776 if Compile_Time_Known_Value (Expr) then
777 Alignment_Warnings.Append
778 ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
780 -- Add explanation of the warning generated by the check
784 ("\address value may be incompatible with alignment of "
794 -- If we have some missing run time component in configurable run time
795 -- mode then just skip the check (it is not required in any case).
797 when RE_Not_Available =>
799 end Apply_Address_Clause_Check;
801 -------------------------------------
802 -- Apply_Arithmetic_Overflow_Check --
803 -------------------------------------
805 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
807 -- Use old routine in almost all cases (the only case we are treating
808 -- specially is the case of a signed integer arithmetic op with the
809 -- overflow checking mode set to MINIMIZED or ELIMINATED).
811 if Overflow_Check_Mode = Strict
812 or else not Is_Signed_Integer_Arithmetic_Op (N)
814 Apply_Arithmetic_Overflow_Strict (N);
816 -- Otherwise use the new routine for the case of a signed integer
817 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
818 -- mode is MINIMIZED or ELIMINATED.
821 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
823 end Apply_Arithmetic_Overflow_Check;
825 --------------------------------------
826 -- Apply_Arithmetic_Overflow_Strict --
827 --------------------------------------
829 -- This routine is called only if the type is an integer type, and a
830 -- software arithmetic overflow check may be needed for op (add, subtract,
831 -- or multiply). This check is performed only if Software_Overflow_Checking
832 -- is enabled and Do_Overflow_Check is set. In this case we expand the
833 -- operation into a more complex sequence of tests that ensures that
834 -- overflow is properly caught.
836 -- This is used in CHECKED modes. It is identical to the code for this
837 -- cases before the big overflow earthquake, thus ensuring that in this
838 -- modes we have compatible behavior (and reliability) to what was there
839 -- before. It is also called for types other than signed integers, and if
840 -- the Do_Overflow_Check flag is off.
842 -- Note: we also call this routine if we decide in the MINIMIZED case
843 -- to give up and just generate an overflow check without any fuss.
845 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
846 Loc : constant Source_Ptr := Sloc (N);
847 Typ : constant Entity_Id := Etype (N);
848 Rtyp : constant Entity_Id := Root_Type (Typ);
851 -- Nothing to do if Do_Overflow_Check not set or overflow checks
854 if not Do_Overflow_Check (N) then
858 -- An interesting special case. If the arithmetic operation appears as
859 -- the operand of a type conversion:
863 -- and all the following conditions apply:
865 -- arithmetic operation is for a signed integer type
866 -- target type type1 is a static integer subtype
867 -- range of x and y are both included in the range of type1
868 -- range of x op y is included in the range of type1
869 -- size of type1 is at least twice the result size of op
871 -- then we don't do an overflow check in any case. Instead, we transform
872 -- the operation so that we end up with:
874 -- type1 (type1 (x) op type1 (y))
876 -- This avoids intermediate overflow before the conversion. It is
877 -- explicitly permitted by RM 3.5.4(24):
879 -- For the execution of a predefined operation of a signed integer
880 -- type, the implementation need not raise Constraint_Error if the
881 -- result is outside the base range of the type, so long as the
882 -- correct result is produced.
884 -- It's hard to imagine that any programmer counts on the exception
885 -- being raised in this case, and in any case it's wrong coding to
886 -- have this expectation, given the RM permission. Furthermore, other
887 -- Ada compilers do allow such out of range results.
889 -- Note that we do this transformation even if overflow checking is
890 -- off, since this is precisely about giving the "right" result and
891 -- avoiding the need for an overflow check.
893 -- Note: this circuit is partially redundant with respect to the similar
894 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
895 -- with cases that do not come through here. We still need the following
896 -- processing even with the Exp_Ch4 code in place, since we want to be
897 -- sure not to generate the arithmetic overflow check in these cases
898 -- (Exp_Ch4 would have a hard time removing them once generated).
900 if Is_Signed_Integer_Type (Typ)
901 and then Nkind (Parent (N)) = N_Type_Conversion
903 Conversion_Optimization : declare
904 Target_Type : constant Entity_Id :=
905 Base_Type (Entity (Subtype_Mark (Parent (N))));
919 if Is_Integer_Type (Target_Type)
920 and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
922 Tlo := Expr_Value (Type_Low_Bound (Target_Type));
923 Thi := Expr_Value (Type_High_Bound (Target_Type));
926 (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
928 (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
931 and then Tlo <= Llo and then Lhi <= Thi
932 and then Tlo <= Rlo and then Rhi <= Thi
934 Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
936 if VOK and then Tlo <= Vlo and then Vhi <= Thi then
937 Rewrite (Left_Opnd (N),
938 Make_Type_Conversion (Loc,
939 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
940 Expression => Relocate_Node (Left_Opnd (N))));
942 Rewrite (Right_Opnd (N),
943 Make_Type_Conversion (Loc,
944 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
945 Expression => Relocate_Node (Right_Opnd (N))));
947 -- Rewrite the conversion operand so that the original
948 -- node is retained, in order to avoid the warning for
949 -- redundant conversions in Resolve_Type_Conversion.
951 Rewrite (N, Relocate_Node (N));
953 Set_Etype (N, Target_Type);
955 Analyze_And_Resolve (Left_Opnd (N), Target_Type);
956 Analyze_And_Resolve (Right_Opnd (N), Target_Type);
958 -- Given that the target type is twice the size of the
959 -- source type, overflow is now impossible, so we can
960 -- safely kill the overflow check and return.
962 Set_Do_Overflow_Check (N, False);
967 end Conversion_Optimization;
970 -- Now see if an overflow check is required
973 Siz : constant Int := UI_To_Int (Esize (Rtyp));
974 Dsiz : constant Int := Siz * 2;
981 -- Skip check if back end does overflow checks, or the overflow flag
982 -- is not set anyway, or we are not doing code expansion, or the
983 -- parent node is a type conversion whose operand is an arithmetic
984 -- operation on signed integers on which the expander can promote
985 -- later the operands to type Integer (see Expand_N_Type_Conversion).
987 if Backend_Overflow_Checks_On_Target
988 or else not Do_Overflow_Check (N)
989 or else not Expander_Active
990 or else (Present (Parent (N))
991 and then Nkind (Parent (N)) = N_Type_Conversion
992 and then Integer_Promotion_Possible (Parent (N)))
997 -- Otherwise, generate the full general code for front end overflow
998 -- detection, which works by doing arithmetic in a larger type:
1004 -- Typ (Checktyp (x) op Checktyp (y));
1006 -- where Typ is the type of the original expression, and Checktyp is
1007 -- an integer type of sufficient length to hold the largest possible
1010 -- If the size of check type exceeds the size of Long_Long_Integer,
1011 -- we use a different approach, expanding to:
1013 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1015 -- where xxx is Add, Multiply or Subtract as appropriate
1017 -- Find check type if one exists
1019 if Dsiz <= Standard_Integer_Size then
1020 Ctyp := Standard_Integer;
1022 elsif Dsiz <= Standard_Long_Long_Integer_Size then
1023 Ctyp := Standard_Long_Long_Integer;
1025 -- No check type exists, use runtime call
1028 if Nkind (N) = N_Op_Add then
1029 Cent := RE_Add_With_Ovflo_Check;
1031 elsif Nkind (N) = N_Op_Multiply then
1032 Cent := RE_Multiply_With_Ovflo_Check;
1035 pragma Assert (Nkind (N) = N_Op_Subtract);
1036 Cent := RE_Subtract_With_Ovflo_Check;
1041 Make_Function_Call (Loc,
1042 Name => New_Occurrence_Of (RTE (Cent), Loc),
1043 Parameter_Associations => New_List (
1044 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
1045 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
1047 Analyze_And_Resolve (N, Typ);
1051 -- If we fall through, we have the case where we do the arithmetic
1052 -- in the next higher type and get the check by conversion. In these
1053 -- cases Ctyp is set to the type to be used as the check type.
1055 Opnod := Relocate_Node (N);
1057 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
1060 Set_Etype (Opnd, Ctyp);
1061 Set_Analyzed (Opnd, True);
1062 Set_Left_Opnd (Opnod, Opnd);
1064 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
1067 Set_Etype (Opnd, Ctyp);
1068 Set_Analyzed (Opnd, True);
1069 Set_Right_Opnd (Opnod, Opnd);
1071 -- The type of the operation changes to the base type of the check
1072 -- type, and we reset the overflow check indication, since clearly no
1073 -- overflow is possible now that we are using a double length type.
1074 -- We also set the Analyzed flag to avoid a recursive attempt to
1077 Set_Etype (Opnod, Base_Type (Ctyp));
1078 Set_Do_Overflow_Check (Opnod, False);
1079 Set_Analyzed (Opnod, True);
1081 -- Now build the outer conversion
1083 Opnd := OK_Convert_To (Typ, Opnod);
1085 Set_Etype (Opnd, Typ);
1087 -- In the discrete type case, we directly generate the range check
1088 -- for the outer operand. This range check will implement the
1089 -- required overflow check.
1091 if Is_Discrete_Type (Typ) then
1093 Generate_Range_Check
1094 (Expression (N), Typ, CE_Overflow_Check_Failed);
1096 -- For other types, we enable overflow checking on the conversion,
1097 -- after setting the node as analyzed to prevent recursive attempts
1098 -- to expand the conversion node.
1101 Set_Analyzed (Opnd, True);
1102 Enable_Overflow_Check (Opnd);
1107 when RE_Not_Available =>
1110 end Apply_Arithmetic_Overflow_Strict;
1112 ----------------------------------------------------
1113 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1114 ----------------------------------------------------
1116 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
1117 pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
1119 Loc : constant Source_Ptr := Sloc (Op);
1120 P : constant Node_Id := Parent (Op);
1122 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
1123 -- Operands and results are of this type when we convert
1125 Result_Type : constant Entity_Id := Etype (Op);
1126 -- Original result type
1128 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1129 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
1132 -- Ranges of values for result
1135 -- Nothing to do if our parent is one of the following:
1137 -- Another signed integer arithmetic op
1138 -- A membership operation
1139 -- A comparison operation
1141 -- In all these cases, we will process at the higher level (and then
1142 -- this node will be processed during the downwards recursion that
1143 -- is part of the processing in Minimize_Eliminate_Overflows).
1145 if Is_Signed_Integer_Arithmetic_Op (P)
1146 or else Nkind (P) in N_Membership_Test
1147 or else Nkind (P) in N_Op_Compare
1149 -- This is also true for an alternative in a case expression
1151 or else Nkind (P) = N_Case_Expression_Alternative
1153 -- This is also true for a range operand in a membership test
1155 or else (Nkind (P) = N_Range
1156 and then Nkind (Parent (P)) in N_Membership_Test)
1158 -- If_Expressions and Case_Expressions are treated as arithmetic
1159 -- ops, but if they appear in an assignment or similar contexts
1160 -- there is no overflow check that starts from that parent node,
1161 -- so apply check now.
1163 if Nkind_In (P, N_If_Expression, N_Case_Expression)
1164 and then not Is_Signed_Integer_Arithmetic_Op (Parent (P))
1172 -- Otherwise, we have a top level arithmetic operation node, and this
1173 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1174 -- modes. This is the case where we tell the machinery not to move into
1175 -- Bignum mode at this top level (of course the top level operation
1176 -- will still be in Bignum mode if either of its operands are of type
1179 Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
1181 -- That call may but does not necessarily change the result type of Op.
1182 -- It is the job of this routine to undo such changes, so that at the
1183 -- top level, we have the proper type. This "undoing" is a point at
1184 -- which a final overflow check may be applied.
1186 -- If the result type was not fiddled we are all set. We go to base
1187 -- types here because things may have been rewritten to generate the
1188 -- base type of the operand types.
1190 if Base_Type (Etype (Op)) = Base_Type (Result_Type) then
1195 elsif Is_RTE (Etype (Op), RE_Bignum) then
1197 -- We need a sequence that looks like:
1199 -- Rnn : Result_Type;
1202 -- M : Mark_Id := SS_Mark;
1204 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1208 -- This block is inserted (using Insert_Actions), and then the node
1209 -- is replaced with a reference to Rnn.
1211 -- If our parent is a conversion node then there is no point in
1212 -- generating a conversion to Result_Type. Instead, we let the parent
1213 -- handle this. Note that this special case is not just about
1214 -- optimization. Consider
1218 -- X := Long_Long_Integer'Base (A * (B ** C));
1220 -- Now the product may fit in Long_Long_Integer but not in Integer.
1221 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1222 -- overflow exception for this intermediate value.
1225 Blk : constant Node_Id := Make_Bignum_Block (Loc);
1226 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
1232 RHS := Convert_From_Bignum (Op);
1234 if Nkind (P) /= N_Type_Conversion then
1235 Convert_To_And_Rewrite (Result_Type, RHS);
1236 Rtype := Result_Type;
1238 -- Interesting question, do we need a check on that conversion
1239 -- operation. Answer, not if we know the result is in range.
1240 -- At the moment we are not taking advantage of this. To be
1241 -- looked at later ???
1248 (First (Statements (Handled_Statement_Sequence (Blk))),
1249 Make_Assignment_Statement (Loc,
1250 Name => New_Occurrence_Of (Rnn, Loc),
1251 Expression => RHS));
1253 Insert_Actions (Op, New_List (
1254 Make_Object_Declaration (Loc,
1255 Defining_Identifier => Rnn,
1256 Object_Definition => New_Occurrence_Of (Rtype, Loc)),
1259 Rewrite (Op, New_Occurrence_Of (Rnn, Loc));
1260 Analyze_And_Resolve (Op);
1263 -- Here we know the result is Long_Long_Integer'Base, or that it has
1264 -- been rewritten because the parent operation is a conversion. See
1265 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1269 (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion);
1271 -- All we need to do here is to convert the result to the proper
1272 -- result type. As explained above for the Bignum case, we can
1273 -- omit this if our parent is a type conversion.
1275 if Nkind (P) /= N_Type_Conversion then
1276 Convert_To_And_Rewrite (Result_Type, Op);
1279 Analyze_And_Resolve (Op);
1281 end Apply_Arithmetic_Overflow_Minimized_Eliminated;
1283 ----------------------------
1284 -- Apply_Constraint_Check --
1285 ----------------------------
1287 procedure Apply_Constraint_Check
1290 No_Sliding : Boolean := False)
1292 Desig_Typ : Entity_Id;
1295 -- No checks inside a generic (check the instantiations)
1297 if Inside_A_Generic then
1301 -- Apply required constraint checks
1303 if Is_Scalar_Type (Typ) then
1304 Apply_Scalar_Range_Check (N, Typ);
1306 elsif Is_Array_Type (Typ) then
1308 -- A useful optimization: an aggregate with only an others clause
1309 -- always has the right bounds.
1311 if Nkind (N) = N_Aggregate
1312 and then No (Expressions (N))
1314 (First (Choices (First (Component_Associations (N)))))
1320 if Is_Constrained (Typ) then
1321 Apply_Length_Check (N, Typ);
1324 Apply_Range_Check (N, Typ);
1327 Apply_Range_Check (N, Typ);
1330 elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
1331 and then Has_Discriminants (Base_Type (Typ))
1332 and then Is_Constrained (Typ)
1334 Apply_Discriminant_Check (N, Typ);
1336 elsif Is_Access_Type (Typ) then
1338 Desig_Typ := Designated_Type (Typ);
1340 -- No checks necessary if expression statically null
1342 if Known_Null (N) then
1343 if Can_Never_Be_Null (Typ) then
1344 Install_Null_Excluding_Check (N);
1347 -- No sliding possible on access to arrays
1349 elsif Is_Array_Type (Desig_Typ) then
1350 if Is_Constrained (Desig_Typ) then
1351 Apply_Length_Check (N, Typ);
1354 Apply_Range_Check (N, Typ);
1356 elsif Has_Discriminants (Base_Type (Desig_Typ))
1357 and then Is_Constrained (Desig_Typ)
1359 Apply_Discriminant_Check (N, Typ);
1362 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1363 -- this check if the constraint node is illegal, as shown by having
1364 -- an error posted. This additional guard prevents cascaded errors
1365 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1367 if Can_Never_Be_Null (Typ)
1368 and then not Can_Never_Be_Null (Etype (N))
1369 and then not Error_Posted (N)
1371 Install_Null_Excluding_Check (N);
1374 end Apply_Constraint_Check;
1376 ------------------------------
1377 -- Apply_Discriminant_Check --
1378 ------------------------------
1380 procedure Apply_Discriminant_Check
1383 Lhs : Node_Id := Empty)
1385 Loc : constant Source_Ptr := Sloc (N);
1386 Do_Access : constant Boolean := Is_Access_Type (Typ);
1387 S_Typ : Entity_Id := Etype (N);
1391 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
1392 -- A heap object with an indefinite subtype is constrained by its
1393 -- initial value, and assigning to it requires a constraint_check.
1394 -- The target may be an explicit dereference, or a renaming of one.
1396 function Is_Aliased_Unconstrained_Component return Boolean;
1397 -- It is possible for an aliased component to have a nominal
1398 -- unconstrained subtype (through instantiation). If this is a
1399 -- discriminated component assigned in the expansion of an aggregate
1400 -- in an initialization, the check must be suppressed. This unusual
1401 -- situation requires a predicate of its own.
1403 ----------------------------------
1404 -- Denotes_Explicit_Dereference --
1405 ----------------------------------
1407 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
1410 Nkind (Obj) = N_Explicit_Dereference
1412 (Is_Entity_Name (Obj)
1413 and then Present (Renamed_Object (Entity (Obj)))
1414 and then Nkind (Renamed_Object (Entity (Obj))) =
1415 N_Explicit_Dereference);
1416 end Denotes_Explicit_Dereference;
1418 ----------------------------------------
1419 -- Is_Aliased_Unconstrained_Component --
1420 ----------------------------------------
1422 function Is_Aliased_Unconstrained_Component return Boolean is
1427 if Nkind (Lhs) /= N_Selected_Component then
1430 Comp := Entity (Selector_Name (Lhs));
1431 Pref := Prefix (Lhs);
1434 if Ekind (Comp) /= E_Component
1435 or else not Is_Aliased (Comp)
1440 return not Comes_From_Source (Pref)
1441 and then In_Instance
1442 and then not Is_Constrained (Etype (Comp));
1443 end Is_Aliased_Unconstrained_Component;
1445 -- Start of processing for Apply_Discriminant_Check
1449 T_Typ := Designated_Type (Typ);
1454 -- Only apply checks when generating code and discriminant checks are
1455 -- not suppressed. In GNATprove mode, we do not apply the checks, but we
1456 -- still analyze the expression to possibly issue errors on SPARK code
1457 -- when a run-time error can be detected at compile time.
1459 if not GNATprove_Mode then
1460 if not Expander_Active
1461 or else Discriminant_Checks_Suppressed (T_Typ)
1467 -- No discriminant checks necessary for an access when expression is
1468 -- statically Null. This is not only an optimization, it is fundamental
1469 -- because otherwise discriminant checks may be generated in init procs
1470 -- for types containing an access to a not-yet-frozen record, causing a
1471 -- deadly forward reference.
1473 -- Also, if the expression is of an access type whose designated type is
1474 -- incomplete, then the access value must be null and we suppress the
1477 if Known_Null (N) then
1480 elsif Is_Access_Type (S_Typ) then
1481 S_Typ := Designated_Type (S_Typ);
1483 if Ekind (S_Typ) = E_Incomplete_Type then
1488 -- If an assignment target is present, then we need to generate the
1489 -- actual subtype if the target is a parameter or aliased object with
1490 -- an unconstrained nominal subtype.
1492 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1493 -- subtype to the parameter and dereference cases, since other aliased
1494 -- objects are unconstrained (unless the nominal subtype is explicitly
1498 and then (Present (Param_Entity (Lhs))
1499 or else (Ada_Version < Ada_2005
1500 and then not Is_Constrained (T_Typ)
1501 and then Is_Aliased_View (Lhs)
1502 and then not Is_Aliased_Unconstrained_Component)
1503 or else (Ada_Version >= Ada_2005
1504 and then not Is_Constrained (T_Typ)
1505 and then Denotes_Explicit_Dereference (Lhs)
1506 and then Nkind (Original_Node (Lhs)) /=
1509 T_Typ := Get_Actual_Subtype (Lhs);
1512 -- Nothing to do if the type is unconstrained (this is the case where
1513 -- the actual subtype in the RM sense of N is unconstrained and no check
1516 if not Is_Constrained (T_Typ) then
1519 -- Ada 2005: nothing to do if the type is one for which there is a
1520 -- partial view that is constrained.
1522 elsif Ada_Version >= Ada_2005
1523 and then Object_Type_Has_Constrained_Partial_View
1524 (Typ => Base_Type (T_Typ),
1525 Scop => Current_Scope)
1530 -- Nothing to do if the type is an Unchecked_Union
1532 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1536 -- Suppress checks if the subtypes are the same. The check must be
1537 -- preserved in an assignment to a formal, because the constraint is
1538 -- given by the actual.
1540 if Nkind (Original_Node (N)) /= N_Allocator
1542 or else not Is_Entity_Name (Lhs)
1543 or else No (Param_Entity (Lhs)))
1546 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1547 and then not Is_Aliased_View (Lhs)
1552 -- We can also eliminate checks on allocators with a subtype mark that
1553 -- coincides with the context type. The context type may be a subtype
1554 -- without a constraint (common case, a generic actual).
1556 elsif Nkind (Original_Node (N)) = N_Allocator
1557 and then Is_Entity_Name (Expression (Original_Node (N)))
1560 Alloc_Typ : constant Entity_Id :=
1561 Entity (Expression (Original_Node (N)));
1564 if Alloc_Typ = T_Typ
1565 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1566 and then Is_Entity_Name (
1567 Subtype_Indication (Parent (T_Typ)))
1568 and then Alloc_Typ = Base_Type (T_Typ))
1576 -- See if we have a case where the types are both constrained, and all
1577 -- the constraints are constants. In this case, we can do the check
1578 -- successfully at compile time.
1580 -- We skip this check for the case where the node is rewritten as
1581 -- an allocator, because it already carries the context subtype,
1582 -- and extracting the discriminants from the aggregate is messy.
1584 if Is_Constrained (S_Typ)
1585 and then Nkind (Original_Node (N)) /= N_Allocator
1595 -- S_Typ may not have discriminants in the case where it is a
1596 -- private type completed by a default discriminated type. In that
1597 -- case, we need to get the constraints from the underlying type.
1598 -- If the underlying type is unconstrained (i.e. has no default
1599 -- discriminants) no check is needed.
1601 if Has_Discriminants (S_Typ) then
1602 Discr := First_Discriminant (S_Typ);
1603 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1606 Discr := First_Discriminant (Underlying_Type (S_Typ));
1609 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1615 -- A further optimization: if T_Typ is derived from S_Typ
1616 -- without imposing a constraint, no check is needed.
1618 if Nkind (Original_Node (Parent (T_Typ))) =
1619 N_Full_Type_Declaration
1622 Type_Def : constant Node_Id :=
1623 Type_Definition (Original_Node (Parent (T_Typ)));
1625 if Nkind (Type_Def) = N_Derived_Type_Definition
1626 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1627 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1635 -- Constraint may appear in full view of type
1637 if Ekind (T_Typ) = E_Private_Subtype
1638 and then Present (Full_View (T_Typ))
1641 First_Elmt (Discriminant_Constraint (Full_View (T_Typ)));
1644 First_Elmt (Discriminant_Constraint (T_Typ));
1647 while Present (Discr) loop
1648 ItemS := Node (DconS);
1649 ItemT := Node (DconT);
1651 -- For a discriminated component type constrained by the
1652 -- current instance of an enclosing type, there is no
1653 -- applicable discriminant check.
1655 if Nkind (ItemT) = N_Attribute_Reference
1656 and then Is_Access_Type (Etype (ItemT))
1657 and then Is_Entity_Name (Prefix (ItemT))
1658 and then Is_Type (Entity (Prefix (ItemT)))
1663 -- If the expressions for the discriminants are identical
1664 -- and it is side-effect free (for now just an entity),
1665 -- this may be a shared constraint, e.g. from a subtype
1666 -- without a constraint introduced as a generic actual.
1667 -- Examine other discriminants if any.
1670 and then Is_Entity_Name (ItemS)
1674 elsif not Is_OK_Static_Expression (ItemS)
1675 or else not Is_OK_Static_Expression (ItemT)
1679 elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
1680 if Do_Access then -- needs run-time check.
1683 Apply_Compile_Time_Constraint_Error
1684 (N, "incorrect value for discriminant&??",
1685 CE_Discriminant_Check_Failed, Ent => Discr);
1692 Next_Discriminant (Discr);
1701 -- In GNATprove mode, we do not apply the checks
1703 if GNATprove_Mode then
1707 -- Here we need a discriminant check. First build the expression
1708 -- for the comparisons of the discriminants:
1710 -- (n.disc1 /= typ.disc1) or else
1711 -- (n.disc2 /= typ.disc2) or else
1713 -- (n.discn /= typ.discn)
1715 Cond := Build_Discriminant_Checks (N, T_Typ);
1717 -- If Lhs is set and is a parameter, then the condition is guarded by:
1718 -- lhs'constrained and then (condition built above)
1720 if Present (Param_Entity (Lhs)) then
1724 Make_Attribute_Reference (Loc,
1725 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1726 Attribute_Name => Name_Constrained),
1727 Right_Opnd => Cond);
1731 Cond := Guard_Access (Cond, Loc, N);
1735 Make_Raise_Constraint_Error (Loc,
1737 Reason => CE_Discriminant_Check_Failed));
1738 end Apply_Discriminant_Check;
1740 -------------------------
1741 -- Apply_Divide_Checks --
1742 -------------------------
1744 procedure Apply_Divide_Checks (N : Node_Id) is
1745 Loc : constant Source_Ptr := Sloc (N);
1746 Typ : constant Entity_Id := Etype (N);
1747 Left : constant Node_Id := Left_Opnd (N);
1748 Right : constant Node_Id := Right_Opnd (N);
1750 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1751 -- Current overflow checking mode
1761 pragma Warnings (Off, Lhi);
1762 -- Don't actually use this value
1765 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1766 -- operating on signed integer types, then the only thing this routine
1767 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1768 -- procedure will (possibly later on during recursive downward calls),
1769 -- ensure that any needed overflow/division checks are properly applied.
1771 if Mode in Minimized_Or_Eliminated
1772 and then Is_Signed_Integer_Type (Typ)
1774 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
1778 -- Proceed here in SUPPRESSED or CHECKED modes
1781 and then not Backend_Divide_Checks_On_Target
1782 and then Check_Needed (Right, Division_Check)
1784 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
1786 -- Deal with division check
1788 if Do_Division_Check (N)
1789 and then not Division_Checks_Suppressed (Typ)
1791 Apply_Division_Check (N, Rlo, Rhi, ROK);
1794 -- Deal with overflow check
1796 if Do_Overflow_Check (N)
1797 and then not Overflow_Checks_Suppressed (Etype (N))
1799 Set_Do_Overflow_Check (N, False);
1801 -- Test for extremely annoying case of xxx'First divided by -1
1802 -- for division of signed integer types (only overflow case).
1804 if Nkind (N) = N_Op_Divide
1805 and then Is_Signed_Integer_Type (Typ)
1807 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
1808 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1810 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1812 ((not LOK) or else (Llo = LLB))
1815 Make_Raise_Constraint_Error (Loc,
1821 Duplicate_Subexpr_Move_Checks (Left),
1822 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1826 Left_Opnd => Duplicate_Subexpr (Right),
1827 Right_Opnd => Make_Integer_Literal (Loc, -1))),
1829 Reason => CE_Overflow_Check_Failed));
1834 end Apply_Divide_Checks;
1836 --------------------------
1837 -- Apply_Division_Check --
1838 --------------------------
1840 procedure Apply_Division_Check
1846 pragma Assert (Do_Division_Check (N));
1848 Loc : constant Source_Ptr := Sloc (N);
1849 Right : constant Node_Id := Right_Opnd (N);
1853 and then not Backend_Divide_Checks_On_Target
1854 and then Check_Needed (Right, Division_Check)
1856 -- See if division by zero possible, and if so generate test. This
1857 -- part of the test is not controlled by the -gnato switch, since
1858 -- it is a Division_Check and not an Overflow_Check.
1860 if Do_Division_Check (N) then
1861 Set_Do_Division_Check (N, False);
1863 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1865 Make_Raise_Constraint_Error (Loc,
1868 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1869 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1870 Reason => CE_Divide_By_Zero));
1874 end Apply_Division_Check;
1876 ----------------------------------
1877 -- Apply_Float_Conversion_Check --
1878 ----------------------------------
1880 -- Let F and I be the source and target types of the conversion. The RM
1881 -- specifies that a floating-point value X is rounded to the nearest
1882 -- integer, with halfway cases being rounded away from zero. The rounded
1883 -- value of X is checked against I'Range.
1885 -- The catch in the above paragraph is that there is no good way to know
1886 -- whether the round-to-integer operation resulted in overflow. A remedy is
1887 -- to perform a range check in the floating-point domain instead, however:
1889 -- (1) The bounds may not be known at compile time
1890 -- (2) The check must take into account rounding or truncation.
1891 -- (3) The range of type I may not be exactly representable in F.
1892 -- (4) For the rounding case, The end-points I'First - 0.5 and
1893 -- I'Last + 0.5 may or may not be in range, depending on the
1894 -- sign of I'First and I'Last.
1895 -- (5) X may be a NaN, which will fail any comparison
1897 -- The following steps correctly convert X with rounding:
1899 -- (1) If either I'First or I'Last is not known at compile time, use
1900 -- I'Base instead of I in the next three steps and perform a
1901 -- regular range check against I'Range after conversion.
1902 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1903 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1904 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1905 -- In other words, take one of the closest floating-point numbers
1906 -- (which is an integer value) to I'First, and see if it is in
1908 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1909 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1910 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1911 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1912 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1914 -- For the truncating case, replace steps (2) and (3) as follows:
1915 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1916 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1918 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1919 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1922 procedure Apply_Float_Conversion_Check
1924 Target_Typ : Entity_Id)
1926 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1927 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1928 Loc : constant Source_Ptr := Sloc (Ck_Node);
1929 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1930 Target_Base : constant Entity_Id :=
1931 Implementation_Base_Type (Target_Typ);
1933 Par : constant Node_Id := Parent (Ck_Node);
1934 pragma Assert (Nkind (Par) = N_Type_Conversion);
1935 -- Parent of check node, must be a type conversion
1937 Truncate : constant Boolean := Float_Truncate (Par);
1938 Max_Bound : constant Uint :=
1940 (Machine_Radix_Value (Expr_Type),
1941 Machine_Mantissa_Value (Expr_Type) - 1) - 1;
1943 -- Largest bound, so bound plus or minus half is a machine number of F
1945 Ifirst, Ilast : Uint;
1946 -- Bounds of integer type
1949 -- Bounds to check in floating-point domain
1951 Lo_OK, Hi_OK : Boolean;
1952 -- True iff Lo resp. Hi belongs to I'Range
1954 Lo_Chk, Hi_Chk : Node_Id;
1955 -- Expressions that are False iff check fails
1957 Reason : RT_Exception_Code;
1960 -- We do not need checks if we are not generating code (i.e. the full
1961 -- expander is not active). In SPARK mode, we specifically don't want
1962 -- the frontend to expand these checks, which are dealt with directly
1963 -- in the formal verification backend.
1965 if not Expander_Active then
1969 if not Compile_Time_Known_Value (LB)
1970 or not Compile_Time_Known_Value (HB)
1973 -- First check that the value falls in the range of the base type,
1974 -- to prevent overflow during conversion and then perform a
1975 -- regular range check against the (dynamic) bounds.
1977 pragma Assert (Target_Base /= Target_Typ);
1979 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
1982 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
1983 Set_Etype (Temp, Target_Base);
1985 Insert_Action (Parent (Par),
1986 Make_Object_Declaration (Loc,
1987 Defining_Identifier => Temp,
1988 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
1989 Expression => New_Copy_Tree (Par)),
1990 Suppress => All_Checks);
1993 Make_Raise_Constraint_Error (Loc,
1996 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1997 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
1998 Reason => CE_Range_Check_Failed));
1999 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
2005 -- Get the (static) bounds of the target type
2007 Ifirst := Expr_Value (LB);
2008 Ilast := Expr_Value (HB);
2010 -- A simple optimization: if the expression is a universal literal,
2011 -- we can do the comparison with the bounds and the conversion to
2012 -- an integer type statically. The range checks are unchanged.
2014 if Nkind (Ck_Node) = N_Real_Literal
2015 and then Etype (Ck_Node) = Universal_Real
2016 and then Is_Integer_Type (Target_Typ)
2017 and then Nkind (Parent (Ck_Node)) = N_Type_Conversion
2020 Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
2023 if Int_Val <= Ilast and then Int_Val >= Ifirst then
2025 -- Conversion is safe
2027 Rewrite (Parent (Ck_Node),
2028 Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
2029 Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
2035 -- Check against lower bound
2037 if Truncate and then Ifirst > 0 then
2038 Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
2042 Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
2045 elsif abs (Ifirst) < Max_Bound then
2046 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
2047 Lo_OK := (Ifirst > 0);
2050 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
2051 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
2056 -- Lo_Chk := (X >= Lo)
2058 Lo_Chk := Make_Op_Ge (Loc,
2059 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2060 Right_Opnd => Make_Real_Literal (Loc, Lo));
2063 -- Lo_Chk := (X > Lo)
2065 Lo_Chk := Make_Op_Gt (Loc,
2066 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2067 Right_Opnd => Make_Real_Literal (Loc, Lo));
2070 -- Check against higher bound
2072 if Truncate and then Ilast < 0 then
2073 Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
2077 Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
2080 elsif abs (Ilast) < Max_Bound then
2081 Hi := UR_From_Uint (Ilast) + Ureal_Half;
2082 Hi_OK := (Ilast < 0);
2084 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
2085 Hi_OK := (Hi <= UR_From_Uint (Ilast));
2090 -- Hi_Chk := (X <= Hi)
2092 Hi_Chk := Make_Op_Le (Loc,
2093 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2094 Right_Opnd => Make_Real_Literal (Loc, Hi));
2097 -- Hi_Chk := (X < Hi)
2099 Hi_Chk := Make_Op_Lt (Loc,
2100 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2101 Right_Opnd => Make_Real_Literal (Loc, Hi));
2104 -- If the bounds of the target type are the same as those of the base
2105 -- type, the check is an overflow check as a range check is not
2106 -- performed in these cases.
2108 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
2109 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
2111 Reason := CE_Overflow_Check_Failed;
2113 Reason := CE_Range_Check_Failed;
2116 -- Raise CE if either conditions does not hold
2118 Insert_Action (Ck_Node,
2119 Make_Raise_Constraint_Error (Loc,
2120 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
2122 end Apply_Float_Conversion_Check;
2124 ------------------------
2125 -- Apply_Length_Check --
2126 ------------------------
2128 procedure Apply_Length_Check
2130 Target_Typ : Entity_Id;
2131 Source_Typ : Entity_Id := Empty)
2134 Apply_Selected_Length_Checks
2135 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2136 end Apply_Length_Check;
2138 -------------------------------------
2139 -- Apply_Parameter_Aliasing_Checks --
2140 -------------------------------------
2142 procedure Apply_Parameter_Aliasing_Checks
2146 Loc : constant Source_Ptr := Sloc (Call);
2148 function May_Cause_Aliasing
2149 (Formal_1 : Entity_Id;
2150 Formal_2 : Entity_Id) return Boolean;
2151 -- Determine whether two formal parameters can alias each other
2152 -- depending on their modes.
2154 function Original_Actual (N : Node_Id) return Node_Id;
2155 -- The expander may replace an actual with a temporary for the sake of
2156 -- side effect removal. The temporary may hide a potential aliasing as
2157 -- it does not share the address of the actual. This routine attempts
2158 -- to retrieve the original actual.
2160 procedure Overlap_Check
2161 (Actual_1 : Node_Id;
2163 Formal_1 : Entity_Id;
2164 Formal_2 : Entity_Id;
2165 Check : in out Node_Id);
2166 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2167 -- If detailed exception messages are enabled, the check is augmented to
2168 -- provide information about the names of the corresponding formals. See
2169 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2170 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2171 -- Check contains all and-ed simple tests generated so far or remains
2172 -- unchanged in the case of detailed exception messaged.
2174 ------------------------
2175 -- May_Cause_Aliasing --
2176 ------------------------
2178 function May_Cause_Aliasing
2179 (Formal_1 : Entity_Id;
2180 Formal_2 : Entity_Id) return Boolean
2183 -- The following combination cannot lead to aliasing
2185 -- Formal 1 Formal 2
2188 if Ekind (Formal_1) = E_In_Parameter
2190 Ekind (Formal_2) = E_In_Parameter
2194 -- The following combinations may lead to aliasing
2196 -- Formal 1 Formal 2
2206 end May_Cause_Aliasing;
2208 ---------------------
2209 -- Original_Actual --
2210 ---------------------
2212 function Original_Actual (N : Node_Id) return Node_Id is
2214 if Nkind (N) = N_Type_Conversion then
2215 return Expression (N);
2217 -- The expander created a temporary to capture the result of a type
2218 -- conversion where the expression is the real actual.
2220 elsif Nkind (N) = N_Identifier
2221 and then Present (Original_Node (N))
2222 and then Nkind (Original_Node (N)) = N_Type_Conversion
2224 return Expression (Original_Node (N));
2228 end Original_Actual;
2234 procedure Overlap_Check
2235 (Actual_1 : Node_Id;
2237 Formal_1 : Entity_Id;
2238 Formal_2 : Entity_Id;
2239 Check : in out Node_Id)
2242 ID_Casing : constant Casing_Type :=
2243 Identifier_Casing (Source_Index (Current_Sem_Unit));
2247 -- Actual_1'Overlaps_Storage (Actual_2)
2250 Make_Attribute_Reference (Loc,
2251 Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
2252 Attribute_Name => Name_Overlaps_Storage,
2254 New_List (New_Copy_Tree (Original_Actual (Actual_2))));
2256 -- Generate the following check when detailed exception messages are
2259 -- if Actual_1'Overlaps_Storage (Actual_2) then
2260 -- raise Program_Error with <detailed message>;
2263 if Exception_Extra_Info then
2266 -- Do not generate location information for internal calls
2268 if Comes_From_Source (Call) then
2269 Store_String_Chars (Build_Location_String (Loc));
2270 Store_String_Char (' ');
2273 Store_String_Chars ("aliased parameters, actuals for """);
2275 Get_Name_String (Chars (Formal_1));
2276 Set_Casing (ID_Casing);
2277 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2279 Store_String_Chars (""" and """);
2281 Get_Name_String (Chars (Formal_2));
2282 Set_Casing (ID_Casing);
2283 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2285 Store_String_Chars (""" overlap");
2287 Insert_Action (Call,
2288 Make_If_Statement (Loc,
2290 Then_Statements => New_List (
2291 Make_Raise_Statement (Loc,
2293 New_Occurrence_Of (Standard_Program_Error, Loc),
2294 Expression => Make_String_Literal (Loc, End_String)))));
2296 -- Create a sequence of overlapping checks by and-ing them all
2306 Right_Opnd => Cond);
2316 Formal_1 : Entity_Id;
2317 Formal_2 : Entity_Id;
2318 Orig_Act_1 : Node_Id;
2319 Orig_Act_2 : Node_Id;
2321 -- Start of processing for Apply_Parameter_Aliasing_Checks
2326 Actual_1 := First_Actual (Call);
2327 Formal_1 := First_Formal (Subp);
2328 while Present (Actual_1) and then Present (Formal_1) loop
2329 Orig_Act_1 := Original_Actual (Actual_1);
2331 -- Ensure that the actual is an object that is not passed by value.
2332 -- Elementary types are always passed by value, therefore actuals of
2333 -- such types cannot lead to aliasing. An aggregate is an object in
2334 -- Ada 2012, but an actual that is an aggregate cannot overlap with
2335 -- another actual. A type that is By_Reference (such as an array of
2336 -- controlled types) is not subject to the check because any update
2337 -- will be done in place and a subsequent read will always see the
2338 -- correct value, see RM 6.2 (12/3).
2340 if Nkind (Orig_Act_1) = N_Aggregate
2341 or else (Nkind (Orig_Act_1) = N_Qualified_Expression
2342 and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
2346 elsif Is_Object_Reference (Orig_Act_1)
2347 and then not Is_Elementary_Type (Etype (Orig_Act_1))
2348 and then not Is_By_Reference_Type (Etype (Orig_Act_1))
2350 Actual_2 := Next_Actual (Actual_1);
2351 Formal_2 := Next_Formal (Formal_1);
2352 while Present (Actual_2) and then Present (Formal_2) loop
2353 Orig_Act_2 := Original_Actual (Actual_2);
2355 -- The other actual we are testing against must also denote
2356 -- a non pass-by-value object. Generate the check only when
2357 -- the mode of the two formals may lead to aliasing.
2359 if Is_Object_Reference (Orig_Act_2)
2360 and then not Is_Elementary_Type (Etype (Orig_Act_2))
2361 and then May_Cause_Aliasing (Formal_1, Formal_2)
2364 (Actual_1 => Actual_1,
2365 Actual_2 => Actual_2,
2366 Formal_1 => Formal_1,
2367 Formal_2 => Formal_2,
2371 Next_Actual (Actual_2);
2372 Next_Formal (Formal_2);
2376 Next_Actual (Actual_1);
2377 Next_Formal (Formal_1);
2380 -- Place a simple check right before the call
2382 if Present (Check) and then not Exception_Extra_Info then
2383 Insert_Action (Call,
2384 Make_Raise_Program_Error (Loc,
2386 Reason => PE_Aliased_Parameters));
2388 end Apply_Parameter_Aliasing_Checks;
2390 -------------------------------------
2391 -- Apply_Parameter_Validity_Checks --
2392 -------------------------------------
2394 procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
2395 Subp_Decl : Node_Id;
2397 procedure Add_Validity_Check
2398 (Formal : Entity_Id;
2400 For_Result : Boolean := False);
2401 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2402 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2403 -- Set flag For_Result when to verify the result of a function.
2405 ------------------------
2406 -- Add_Validity_Check --
2407 ------------------------
2409 procedure Add_Validity_Check
2410 (Formal : Entity_Id;
2412 For_Result : Boolean := False)
2414 procedure Build_Pre_Post_Condition (Expr : Node_Id);
2415 -- Create a pre/postcondition pragma that tests expression Expr
2417 ------------------------------
2418 -- Build_Pre_Post_Condition --
2419 ------------------------------
2421 procedure Build_Pre_Post_Condition (Expr : Node_Id) is
2422 Loc : constant Source_Ptr := Sloc (Subp);
2430 Pragma_Argument_Associations => New_List (
2431 Make_Pragma_Argument_Association (Loc,
2432 Chars => Name_Check,
2433 Expression => Expr)));
2435 -- Add a message unless exception messages are suppressed
2437 if not Exception_Locations_Suppressed then
2438 Append_To (Pragma_Argument_Associations (Prag),
2439 Make_Pragma_Argument_Association (Loc,
2440 Chars => Name_Message,
2442 Make_String_Literal (Loc,
2444 & Get_Name_String (Prag_Nam)
2446 & Build_Location_String (Loc))));
2449 -- Insert the pragma in the tree
2451 if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then
2452 Add_Global_Declaration (Prag);
2455 -- PPC pragmas associated with subprogram bodies must be inserted
2456 -- in the declarative part of the body.
2458 elsif Nkind (Subp_Decl) = N_Subprogram_Body then
2459 Decls := Declarations (Subp_Decl);
2463 Set_Declarations (Subp_Decl, Decls);
2466 Prepend_To (Decls, Prag);
2469 -- For subprogram declarations insert the PPC pragma right after
2470 -- the declarative node.
2473 Insert_After_And_Analyze (Subp_Decl, Prag);
2475 end Build_Pre_Post_Condition;
2479 Loc : constant Source_Ptr := Sloc (Subp);
2480 Typ : constant Entity_Id := Etype (Formal);
2484 -- Start of processing for Add_Validity_Check
2487 -- For scalars, generate 'Valid test
2489 if Is_Scalar_Type (Typ) then
2492 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2494 elsif Scalar_Part_Present (Typ) then
2495 Nam := Name_Valid_Scalars;
2497 -- No test needed for other cases (no scalars to test)
2503 -- Step 1: Create the expression to verify the validity of the
2506 Check := New_Occurrence_Of (Formal, Loc);
2508 -- When processing a function result, use 'Result. Generate
2513 Make_Attribute_Reference (Loc,
2515 Attribute_Name => Name_Result);
2519 -- Context['Result]'Valid[_Scalars]
2522 Make_Attribute_Reference (Loc,
2524 Attribute_Name => Nam);
2526 -- Step 2: Create a pre or post condition pragma
2528 Build_Pre_Post_Condition (Check);
2529 end Add_Validity_Check;
2534 Subp_Spec : Node_Id;
2536 -- Start of processing for Apply_Parameter_Validity_Checks
2539 -- Extract the subprogram specification and declaration nodes
2541 Subp_Spec := Parent (Subp);
2543 if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
2544 Subp_Spec := Parent (Subp_Spec);
2547 Subp_Decl := Parent (Subp_Spec);
2549 if not Comes_From_Source (Subp)
2551 -- Do not process formal subprograms because the corresponding actual
2552 -- will receive the proper checks when the instance is analyzed.
2554 or else Is_Formal_Subprogram (Subp)
2556 -- Do not process imported subprograms since pre and postconditions
2557 -- are never verified on routines coming from a different language.
2559 or else Is_Imported (Subp)
2560 or else Is_Intrinsic_Subprogram (Subp)
2562 -- The PPC pragmas generated by this routine do not correspond to
2563 -- source aspects, therefore they cannot be applied to abstract
2566 or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
2568 -- Do not consider subprogram renaminds because the renamed entity
2569 -- already has the proper PPC pragmas.
2571 or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
2573 -- Do not process null procedures because there is no benefit of
2574 -- adding the checks to a no action routine.
2576 or else (Nkind (Subp_Spec) = N_Procedure_Specification
2577 and then Null_Present (Subp_Spec))
2582 -- Inspect all the formals applying aliasing and scalar initialization
2583 -- checks where applicable.
2585 Formal := First_Formal (Subp);
2586 while Present (Formal) loop
2588 -- Generate the following scalar initialization checks for each
2589 -- formal parameter:
2591 -- mode IN - Pre => Formal'Valid[_Scalars]
2592 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2593 -- mode OUT - Post => Formal'Valid[_Scalars]
2595 if Check_Validity_Of_Parameters then
2596 if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
2597 Add_Validity_Check (Formal, Name_Precondition, False);
2600 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
2601 Add_Validity_Check (Formal, Name_Postcondition, False);
2605 Next_Formal (Formal);
2608 -- Generate following scalar initialization check for function result:
2610 -- Post => Subp'Result'Valid[_Scalars]
2612 if Check_Validity_Of_Parameters and then Ekind (Subp) = E_Function then
2613 Add_Validity_Check (Subp, Name_Postcondition, True);
2615 end Apply_Parameter_Validity_Checks;
2617 ---------------------------
2618 -- Apply_Predicate_Check --
2619 ---------------------------
2621 procedure Apply_Predicate_Check
2624 Fun : Entity_Id := Empty)
2629 if Predicate_Checks_Suppressed (Empty) then
2632 elsif Predicates_Ignored (Typ) then
2635 elsif Present (Predicate_Function (Typ)) then
2637 while Present (S) and then not Is_Subprogram (S) loop
2641 -- A predicate check does not apply within internally generated
2642 -- subprograms, such as TSS functions.
2644 if Within_Internal_Subprogram then
2647 -- If the check appears within the predicate function itself, it
2648 -- means that the user specified a check whose formal is the
2649 -- predicated subtype itself, rather than some covering type. This
2650 -- is likely to be a common error, and thus deserves a warning.
2652 elsif Present (S) and then S = Predicate_Function (Typ) then
2654 ("predicate check includes a call to& that requires a "
2655 & "predicate check??", Parent (N), Fun);
2657 ("\this will result in infinite recursion??", Parent (N));
2659 if Is_First_Subtype (Typ) then
2661 ("\use an explicit subtype of& to carry the predicate",
2666 Make_Raise_Storage_Error (Sloc (N),
2667 Reason => SE_Infinite_Recursion));
2669 -- Here for normal case of predicate active
2672 -- If the type has a static predicate and the expression is known
2673 -- at compile time, see if the expression satisfies the predicate.
2675 Check_Expression_Against_Static_Predicate (N, Typ);
2677 if not Expander_Active then
2681 -- For an entity of the type, generate a call to the predicate
2682 -- function, unless its type is an actual subtype, which is not
2683 -- visible outside of the enclosing subprogram.
2685 if Is_Entity_Name (N)
2686 and then not Is_Actual_Subtype (Typ)
2689 Make_Predicate_Check
2690 (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
2692 -- If the expression is not an entity it may have side effects,
2693 -- and the following call will create an object declaration for
2694 -- it. We disable checks during its analysis, to prevent an
2695 -- infinite recursion.
2699 Make_Predicate_Check
2700 (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
2704 end Apply_Predicate_Check;
2706 -----------------------
2707 -- Apply_Range_Check --
2708 -----------------------
2710 procedure Apply_Range_Check
2712 Target_Typ : Entity_Id;
2713 Source_Typ : Entity_Id := Empty)
2716 Apply_Selected_Range_Checks
2717 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2718 end Apply_Range_Check;
2720 ------------------------------
2721 -- Apply_Scalar_Range_Check --
2722 ------------------------------
2724 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2725 -- off if it is already set on.
2727 procedure Apply_Scalar_Range_Check
2729 Target_Typ : Entity_Id;
2730 Source_Typ : Entity_Id := Empty;
2731 Fixed_Int : Boolean := False)
2733 Parnt : constant Node_Id := Parent (Expr);
2735 Arr : Node_Id := Empty; -- initialize to prevent warning
2736 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
2739 Is_Subscr_Ref : Boolean;
2740 -- Set true if Expr is a subscript
2742 Is_Unconstrained_Subscr_Ref : Boolean;
2743 -- Set true if Expr is a subscript of an unconstrained array. In this
2744 -- case we do not attempt to do an analysis of the value against the
2745 -- range of the subscript, since we don't know the actual subtype.
2748 -- Set to True if Expr should be regarded as a real value even though
2749 -- the type of Expr might be discrete.
2751 procedure Bad_Value (Warn : Boolean := False);
2752 -- Procedure called if value is determined to be out of range. Warn is
2753 -- True to force a warning instead of an error, even when SPARK_Mode is
2760 procedure Bad_Value (Warn : Boolean := False) is
2762 Apply_Compile_Time_Constraint_Error
2763 (Expr, "value not in range of}??", CE_Range_Check_Failed,
2769 -- Start of processing for Apply_Scalar_Range_Check
2772 -- Return if check obviously not needed
2775 -- Not needed inside generic
2779 -- Not needed if previous error
2781 or else Target_Typ = Any_Type
2782 or else Nkind (Expr) = N_Error
2784 -- Not needed for non-scalar type
2786 or else not Is_Scalar_Type (Target_Typ)
2788 -- Not needed if we know node raises CE already
2790 or else Raises_Constraint_Error (Expr)
2795 -- Now, see if checks are suppressed
2798 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
2800 if Is_Subscr_Ref then
2801 Arr := Prefix (Parnt);
2802 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
2804 if Is_Access_Type (Arr_Typ) then
2805 Arr_Typ := Designated_Type (Arr_Typ);
2809 if not Do_Range_Check (Expr) then
2811 -- Subscript reference. Check for Index_Checks suppressed
2813 if Is_Subscr_Ref then
2815 -- Check array type and its base type
2817 if Index_Checks_Suppressed (Arr_Typ)
2818 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
2822 -- Check array itself if it is an entity name
2824 elsif Is_Entity_Name (Arr)
2825 and then Index_Checks_Suppressed (Entity (Arr))
2829 -- Check expression itself if it is an entity name
2831 elsif Is_Entity_Name (Expr)
2832 and then Index_Checks_Suppressed (Entity (Expr))
2837 -- All other cases, check for Range_Checks suppressed
2840 -- Check target type and its base type
2842 if Range_Checks_Suppressed (Target_Typ)
2843 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
2847 -- Check expression itself if it is an entity name
2849 elsif Is_Entity_Name (Expr)
2850 and then Range_Checks_Suppressed (Entity (Expr))
2854 -- If Expr is part of an assignment statement, then check left
2855 -- side of assignment if it is an entity name.
2857 elsif Nkind (Parnt) = N_Assignment_Statement
2858 and then Is_Entity_Name (Name (Parnt))
2859 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
2866 -- Do not set range checks if they are killed
2868 if Nkind (Expr) = N_Unchecked_Type_Conversion
2869 and then Kill_Range_Check (Expr)
2874 -- Do not set range checks for any values from System.Scalar_Values
2875 -- since the whole idea of such values is to avoid checking them.
2877 if Is_Entity_Name (Expr)
2878 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
2883 -- Now see if we need a check
2885 if No (Source_Typ) then
2886 S_Typ := Etype (Expr);
2888 S_Typ := Source_Typ;
2891 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
2895 Is_Unconstrained_Subscr_Ref :=
2896 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
2898 -- Special checks for floating-point type
2900 if Is_Floating_Point_Type (S_Typ) then
2902 -- Always do a range check if the source type includes infinities and
2903 -- the target type does not include infinities. We do not do this if
2904 -- range checks are killed.
2905 -- If the expression is a literal and the bounds of the type are
2906 -- static constants it may be possible to optimize the check.
2908 if Has_Infinities (S_Typ)
2909 and then not Has_Infinities (Target_Typ)
2911 -- If the expression is a literal and the bounds of the type are
2912 -- static constants it may be possible to optimize the check.
2914 if Nkind (Expr) = N_Real_Literal then
2916 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
2917 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
2920 if Compile_Time_Known_Value (Tlo)
2921 and then Compile_Time_Known_Value (Thi)
2922 and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo)
2923 and then Expr_Value_R (Expr) <= Expr_Value_R (Thi)
2927 Enable_Range_Check (Expr);
2932 Enable_Range_Check (Expr);
2937 -- Return if we know expression is definitely in the range of the target
2938 -- type as determined by Determine_Range. Right now we only do this for
2939 -- discrete types, and not fixed-point or floating-point types.
2941 -- The additional less-precise tests below catch these cases
2943 -- Note: skip this if we are given a source_typ, since the point of
2944 -- supplying a Source_Typ is to stop us looking at the expression.
2945 -- We could sharpen this test to be out parameters only ???
2947 if Is_Discrete_Type (Target_Typ)
2948 and then Is_Discrete_Type (Etype (Expr))
2949 and then not Is_Unconstrained_Subscr_Ref
2950 and then No (Source_Typ)
2953 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
2954 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
2959 if Compile_Time_Known_Value (Tlo)
2960 and then Compile_Time_Known_Value (Thi)
2963 Lov : constant Uint := Expr_Value (Tlo);
2964 Hiv : constant Uint := Expr_Value (Thi);
2967 -- If range is null, we for sure have a constraint error
2968 -- (we don't even need to look at the value involved,
2969 -- since all possible values will raise CE).
2973 -- When SPARK_Mode is On, force a warning instead of
2974 -- an error in that case, as this likely corresponds
2975 -- to deactivated code.
2977 Bad_Value (Warn => SPARK_Mode = On);
2979 -- In GNATprove mode, we enable the range check so that
2980 -- GNATprove will issue a message if it cannot be proved.
2982 if GNATprove_Mode then
2983 Enable_Range_Check (Expr);
2989 -- Otherwise determine range of value
2991 Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True);
2995 -- If definitely in range, all OK
2997 if Lo >= Lov and then Hi <= Hiv then
3000 -- If definitely not in range, warn
3002 elsif Lov > Hi or else Hiv < Lo then
3006 -- Otherwise we don't know
3018 Is_Floating_Point_Type (S_Typ)
3019 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
3021 -- Check if we can determine at compile time whether Expr is in the
3022 -- range of the target type. Note that if S_Typ is within the bounds
3023 -- of Target_Typ then this must be the case. This check is meaningful
3024 -- only if this is not a conversion between integer and real types.
3026 if not Is_Unconstrained_Subscr_Ref
3027 and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
3029 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
3031 -- Also check if the expression itself is in the range of the
3032 -- target type if it is a known at compile time value. We skip
3033 -- this test if S_Typ is set since for OUT and IN OUT parameters
3034 -- the Expr itself is not relevant to the checking.
3038 and then Is_In_Range (Expr, Target_Typ,
3039 Assume_Valid => True,
3040 Fixed_Int => Fixed_Int,
3041 Int_Real => Int_Real)))
3045 elsif Is_Out_Of_Range (Expr, Target_Typ,
3046 Assume_Valid => True,
3047 Fixed_Int => Fixed_Int,
3048 Int_Real => Int_Real)
3053 -- Floating-point case
3054 -- In the floating-point case, we only do range checks if the type is
3055 -- constrained. We definitely do NOT want range checks for unconstrained
3056 -- types, since we want to have infinities, except when
3057 -- Check_Float_Overflow is set.
3059 elsif Is_Floating_Point_Type (S_Typ) then
3060 if Is_Constrained (S_Typ) or else Check_Float_Overflow then
3061 Enable_Range_Check (Expr);
3064 -- For all other cases we enable a range check unconditionally
3067 Enable_Range_Check (Expr);
3070 end Apply_Scalar_Range_Check;
3072 ----------------------------------
3073 -- Apply_Selected_Length_Checks --
3074 ----------------------------------
3076 procedure Apply_Selected_Length_Checks
3078 Target_Typ : Entity_Id;
3079 Source_Typ : Entity_Id;
3080 Do_Static : Boolean)
3083 R_Result : Check_Result;
3086 Loc : constant Source_Ptr := Sloc (Ck_Node);
3087 Checks_On : constant Boolean :=
3088 (not Index_Checks_Suppressed (Target_Typ))
3089 or else (not Length_Checks_Suppressed (Target_Typ));
3092 -- Only apply checks when generating code
3094 -- Note: this means that we lose some useful warnings if the expander
3097 if not Expander_Active then
3102 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3104 for J in 1 .. 2 loop
3105 R_Cno := R_Result (J);
3106 exit when No (R_Cno);
3108 -- A length check may mention an Itype which is attached to a
3109 -- subsequent node. At the top level in a package this can cause
3110 -- an order-of-elaboration problem, so we make sure that the itype
3111 -- is referenced now.
3113 if Ekind (Current_Scope) = E_Package
3114 and then Is_Compilation_Unit (Current_Scope)
3116 Ensure_Defined (Target_Typ, Ck_Node);
3118 if Present (Source_Typ) then
3119 Ensure_Defined (Source_Typ, Ck_Node);
3121 elsif Is_Itype (Etype (Ck_Node)) then
3122 Ensure_Defined (Etype (Ck_Node), Ck_Node);
3126 -- If the item is a conditional raise of constraint error, then have
3127 -- a look at what check is being performed and ???
3129 if Nkind (R_Cno) = N_Raise_Constraint_Error
3130 and then Present (Condition (R_Cno))
3132 Cond := Condition (R_Cno);
3134 -- Case where node does not now have a dynamic check
3136 if not Has_Dynamic_Length_Check (Ck_Node) then
3138 -- If checks are on, just insert the check
3141 Insert_Action (Ck_Node, R_Cno);
3143 if not Do_Static then
3144 Set_Has_Dynamic_Length_Check (Ck_Node);
3147 -- If checks are off, then analyze the length check after
3148 -- temporarily attaching it to the tree in case the relevant
3149 -- condition can be evaluated at compile time. We still want a
3150 -- compile time warning in this case.
3153 Set_Parent (R_Cno, Ck_Node);
3158 -- Output a warning if the condition is known to be True
3160 if Is_Entity_Name (Cond)
3161 and then Entity (Cond) = Standard_True
3163 Apply_Compile_Time_Constraint_Error
3164 (Ck_Node, "wrong length for array of}??",
3165 CE_Length_Check_Failed,
3169 -- If we were only doing a static check, or if checks are not
3170 -- on, then we want to delete the check, since it is not needed.
3171 -- We do this by replacing the if statement by a null statement
3173 elsif Do_Static or else not Checks_On then
3174 Remove_Warning_Messages (R_Cno);
3175 Rewrite (R_Cno, Make_Null_Statement (Loc));
3179 Install_Static_Check (R_Cno, Loc);
3182 end Apply_Selected_Length_Checks;
3184 ---------------------------------
3185 -- Apply_Selected_Range_Checks --
3186 ---------------------------------
3188 procedure Apply_Selected_Range_Checks
3190 Target_Typ : Entity_Id;
3191 Source_Typ : Entity_Id;
3192 Do_Static : Boolean)
3194 Loc : constant Source_Ptr := Sloc (Ck_Node);
3195 Checks_On : constant Boolean :=
3196 not Index_Checks_Suppressed (Target_Typ)
3198 not Range_Checks_Suppressed (Target_Typ);
3202 R_Result : Check_Result;
3205 -- Only apply checks when generating code. In GNATprove mode, we do not
3206 -- apply the checks, but we still call Selected_Range_Checks to possibly
3207 -- issue errors on SPARK code when a run-time error can be detected at
3210 if not GNATprove_Mode then
3211 if not Expander_Active or not Checks_On then
3217 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3219 if GNATprove_Mode then
3223 for J in 1 .. 2 loop
3224 R_Cno := R_Result (J);
3225 exit when No (R_Cno);
3227 -- The range check requires runtime evaluation. Depending on what its
3228 -- triggering condition is, the check may be converted into a compile
3229 -- time constraint check.
3231 if Nkind (R_Cno) = N_Raise_Constraint_Error
3232 and then Present (Condition (R_Cno))
3234 Cond := Condition (R_Cno);
3236 -- Insert the range check before the related context. Note that
3237 -- this action analyses the triggering condition.
3239 Insert_Action (Ck_Node, R_Cno);
3241 -- This old code doesn't make sense, why is the context flagged as
3242 -- requiring dynamic range checks now in the middle of generating
3245 if not Do_Static then
3246 Set_Has_Dynamic_Range_Check (Ck_Node);
3249 -- The triggering condition evaluates to True, the range check
3250 -- can be converted into a compile time constraint check.
3252 if Is_Entity_Name (Cond)
3253 and then Entity (Cond) = Standard_True
3255 -- Since an N_Range is technically not an expression, we have
3256 -- to set one of the bounds to C_E and then just flag the
3257 -- N_Range. The warning message will point to the lower bound
3258 -- and complain about a range, which seems OK.
3260 if Nkind (Ck_Node) = N_Range then
3261 Apply_Compile_Time_Constraint_Error
3262 (Low_Bound (Ck_Node),
3263 "static range out of bounds of}??",
3264 CE_Range_Check_Failed,
3268 Set_Raises_Constraint_Error (Ck_Node);
3271 Apply_Compile_Time_Constraint_Error
3273 "static value out of range of}??",
3274 CE_Range_Check_Failed,
3279 -- If we were only doing a static check, or if checks are not
3280 -- on, then we want to delete the check, since it is not needed.
3281 -- We do this by replacing the if statement by a null statement
3283 elsif Do_Static then
3284 Remove_Warning_Messages (R_Cno);
3285 Rewrite (R_Cno, Make_Null_Statement (Loc));
3288 -- The range check raises Constraint_Error explicitly
3291 Install_Static_Check (R_Cno, Loc);
3294 end Apply_Selected_Range_Checks;
3296 -------------------------------
3297 -- Apply_Static_Length_Check --
3298 -------------------------------
3300 procedure Apply_Static_Length_Check
3302 Target_Typ : Entity_Id;
3303 Source_Typ : Entity_Id := Empty)
3306 Apply_Selected_Length_Checks
3307 (Expr, Target_Typ, Source_Typ, Do_Static => True);
3308 end Apply_Static_Length_Check;
3310 -------------------------------------
3311 -- Apply_Subscript_Validity_Checks --
3312 -------------------------------------
3314 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
3318 pragma Assert (Nkind (Expr) = N_Indexed_Component);
3320 -- Loop through subscripts
3322 Sub := First (Expressions (Expr));
3323 while Present (Sub) loop
3325 -- Check one subscript. Note that we do not worry about enumeration
3326 -- type with holes, since we will convert the value to a Pos value
3327 -- for the subscript, and that convert will do the necessary validity
3330 Ensure_Valid (Sub, Holes_OK => True);
3332 -- Move to next subscript
3336 end Apply_Subscript_Validity_Checks;
3338 ----------------------------------
3339 -- Apply_Type_Conversion_Checks --
3340 ----------------------------------
3342 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
3343 Target_Type : constant Entity_Id := Etype (N);
3344 Target_Base : constant Entity_Id := Base_Type (Target_Type);
3345 Expr : constant Node_Id := Expression (N);
3347 Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
3348 -- Note: if Etype (Expr) is a private type without discriminants, its
3349 -- full view might have discriminants with defaults, so we need the
3350 -- full view here to retrieve the constraints.
3353 if Inside_A_Generic then
3356 -- Skip these checks if serious errors detected, there are some nasty
3357 -- situations of incomplete trees that blow things up.
3359 elsif Serious_Errors_Detected > 0 then
3362 -- Never generate discriminant checks for Unchecked_Union types
3364 elsif Present (Expr_Type)
3365 and then Is_Unchecked_Union (Expr_Type)
3369 -- Scalar type conversions of the form Target_Type (Expr) require a
3370 -- range check if we cannot be sure that Expr is in the base type of
3371 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3372 -- are not quite the same condition from an implementation point of
3373 -- view, but clearly the second includes the first.
3375 elsif Is_Scalar_Type (Target_Type) then
3377 Conv_OK : constant Boolean := Conversion_OK (N);
3378 -- If the Conversion_OK flag on the type conversion is set and no
3379 -- floating-point type is involved in the type conversion then
3380 -- fixed-point values must be read as integral values.
3382 Float_To_Int : constant Boolean :=
3383 Is_Floating_Point_Type (Expr_Type)
3384 and then Is_Integer_Type (Target_Type);
3387 if not Overflow_Checks_Suppressed (Target_Base)
3388 and then not Overflow_Checks_Suppressed (Target_Type)
3390 In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
3391 and then not Float_To_Int
3393 Activate_Overflow_Check (N);
3396 if not Range_Checks_Suppressed (Target_Type)
3397 and then not Range_Checks_Suppressed (Expr_Type)
3399 if Float_To_Int then
3400 Apply_Float_Conversion_Check (Expr, Target_Type);
3402 Apply_Scalar_Range_Check
3403 (Expr, Target_Type, Fixed_Int => Conv_OK);
3405 -- If the target type has predicates, we need to indicate
3406 -- the need for a check, even if Determine_Range finds that
3407 -- the value is within bounds. This may be the case e.g for
3408 -- a division with a constant denominator.
3410 if Has_Predicates (Target_Type) then
3411 Enable_Range_Check (Expr);
3417 elsif Comes_From_Source (N)
3418 and then not Discriminant_Checks_Suppressed (Target_Type)
3419 and then Is_Record_Type (Target_Type)
3420 and then Is_Derived_Type (Target_Type)
3421 and then not Is_Tagged_Type (Target_Type)
3422 and then not Is_Constrained (Target_Type)
3423 and then Present (Stored_Constraint (Target_Type))
3425 -- An unconstrained derived type may have inherited discriminant.
3426 -- Build an actual discriminant constraint list using the stored
3427 -- constraint, to verify that the expression of the parent type
3428 -- satisfies the constraints imposed by the (unconstrained) derived
3429 -- type. This applies to value conversions, not to view conversions
3433 Loc : constant Source_Ptr := Sloc (N);
3435 Constraint : Elmt_Id;
3436 Discr_Value : Node_Id;
3439 New_Constraints : constant Elist_Id := New_Elmt_List;
3440 Old_Constraints : constant Elist_Id :=
3441 Discriminant_Constraint (Expr_Type);
3444 Constraint := First_Elmt (Stored_Constraint (Target_Type));
3445 while Present (Constraint) loop
3446 Discr_Value := Node (Constraint);
3448 if Is_Entity_Name (Discr_Value)
3449 and then Ekind (Entity (Discr_Value)) = E_Discriminant
3451 Discr := Corresponding_Discriminant (Entity (Discr_Value));
3454 and then Scope (Discr) = Base_Type (Expr_Type)
3456 -- Parent is constrained by new discriminant. Obtain
3457 -- Value of original discriminant in expression. If the
3458 -- new discriminant has been used to constrain more than
3459 -- one of the stored discriminants, this will provide the
3460 -- required consistency check.
3463 (Make_Selected_Component (Loc,
3465 Duplicate_Subexpr_No_Checks
3466 (Expr, Name_Req => True),
3468 Make_Identifier (Loc, Chars (Discr))),
3472 -- Discriminant of more remote ancestor ???
3477 -- Derived type definition has an explicit value for this
3478 -- stored discriminant.
3482 (Duplicate_Subexpr_No_Checks (Discr_Value),
3486 Next_Elmt (Constraint);
3489 -- Use the unconstrained expression type to retrieve the
3490 -- discriminants of the parent, and apply momentarily the
3491 -- discriminant constraint synthesized above.
3493 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
3494 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
3495 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
3498 Make_Raise_Constraint_Error (Loc,
3500 Reason => CE_Discriminant_Check_Failed));
3503 -- For arrays, checks are set now, but conversions are applied during
3504 -- expansion, to take into accounts changes of representation. The
3505 -- checks become range checks on the base type or length checks on the
3506 -- subtype, depending on whether the target type is unconstrained or
3507 -- constrained. Note that the range check is put on the expression of a
3508 -- type conversion, while the length check is put on the type conversion
3511 elsif Is_Array_Type (Target_Type) then
3512 if Is_Constrained (Target_Type) then
3513 Set_Do_Length_Check (N);
3515 Set_Do_Range_Check (Expr);
3518 end Apply_Type_Conversion_Checks;
3520 ----------------------------------------------
3521 -- Apply_Universal_Integer_Attribute_Checks --
3522 ----------------------------------------------
3524 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
3525 Loc : constant Source_Ptr := Sloc (N);
3526 Typ : constant Entity_Id := Etype (N);
3529 if Inside_A_Generic then
3532 -- Nothing to do if checks are suppressed
3534 elsif Range_Checks_Suppressed (Typ)
3535 and then Overflow_Checks_Suppressed (Typ)
3539 -- Nothing to do if the attribute does not come from source. The
3540 -- internal attributes we generate of this type do not need checks,
3541 -- and furthermore the attempt to check them causes some circular
3542 -- elaboration orders when dealing with packed types.
3544 elsif not Comes_From_Source (N) then
3547 -- If the prefix is a selected component that depends on a discriminant
3548 -- the check may improperly expose a discriminant instead of using
3549 -- the bounds of the object itself. Set the type of the attribute to
3550 -- the base type of the context, so that a check will be imposed when
3551 -- needed (e.g. if the node appears as an index).
3553 elsif Nkind (Prefix (N)) = N_Selected_Component
3554 and then Ekind (Typ) = E_Signed_Integer_Subtype
3555 and then Depends_On_Discriminant (Scalar_Range (Typ))
3557 Set_Etype (N, Base_Type (Typ));
3559 -- Otherwise, replace the attribute node with a type conversion node
3560 -- whose expression is the attribute, retyped to universal integer, and
3561 -- whose subtype mark is the target type. The call to analyze this
3562 -- conversion will set range and overflow checks as required for proper
3563 -- detection of an out of range value.
3566 Set_Etype (N, Universal_Integer);
3567 Set_Analyzed (N, True);
3570 Make_Type_Conversion (Loc,
3571 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
3572 Expression => Relocate_Node (N)));
3574 Analyze_And_Resolve (N, Typ);
3577 end Apply_Universal_Integer_Attribute_Checks;
3579 -------------------------------------
3580 -- Atomic_Synchronization_Disabled --
3581 -------------------------------------
3583 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3584 -- using a bogus check called Atomic_Synchronization. This is to make it
3585 -- more convenient to get exactly the same semantics as [Un]Suppress.
3587 function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
3589 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3590 -- looks enabled, since it is never disabled.
3592 if Debug_Flag_Dot_E then
3595 -- If debug flag d.d is set then always return True, i.e. all atomic
3596 -- sync looks disabled, since it always tests True.
3598 elsif Debug_Flag_Dot_D then
3601 -- If entity present, then check result for that entity
3603 elsif Present (E) and then Checks_May_Be_Suppressed (E) then
3604 return Is_Check_Suppressed (E, Atomic_Synchronization);
3606 -- Otherwise result depends on current scope setting
3609 return Scope_Suppress.Suppress (Atomic_Synchronization);
3611 end Atomic_Synchronization_Disabled;
3613 -------------------------------
3614 -- Build_Discriminant_Checks --
3615 -------------------------------
3617 function Build_Discriminant_Checks
3619 T_Typ : Entity_Id) return Node_Id
3621 Loc : constant Source_Ptr := Sloc (N);
3624 Disc_Ent : Entity_Id;
3628 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
3630 ----------------------------------
3631 -- Aggregate_Discriminant_Value --
3632 ----------------------------------
3634 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
3638 -- The aggregate has been normalized with named associations. We use
3639 -- the Chars field to locate the discriminant to take into account
3640 -- discriminants in derived types, which carry the same name as those
3643 Assoc := First (Component_Associations (N));
3644 while Present (Assoc) loop
3645 if Chars (First (Choices (Assoc))) = Chars (Disc) then
3646 return Expression (Assoc);
3652 -- Discriminant must have been found in the loop above
3654 raise Program_Error;
3655 end Aggregate_Discriminant_Val;
3657 -- Start of processing for Build_Discriminant_Checks
3660 -- Loop through discriminants evolving the condition
3663 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
3665 -- For a fully private type, use the discriminants of the parent type
3667 if Is_Private_Type (T_Typ)
3668 and then No (Full_View (T_Typ))
3670 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
3672 Disc_Ent := First_Discriminant (T_Typ);
3675 while Present (Disc) loop
3676 Dval := Node (Disc);
3678 if Nkind (Dval) = N_Identifier
3679 and then Ekind (Entity (Dval)) = E_Discriminant
3681 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
3683 Dval := Duplicate_Subexpr_No_Checks (Dval);
3686 -- If we have an Unchecked_Union node, we can infer the discriminants
3689 if Is_Unchecked_Union (Base_Type (T_Typ)) then
3691 Get_Discriminant_Value (
3692 First_Discriminant (T_Typ),
3694 Stored_Constraint (T_Typ)));
3696 elsif Nkind (N) = N_Aggregate then
3698 Duplicate_Subexpr_No_Checks
3699 (Aggregate_Discriminant_Val (Disc_Ent));
3703 Make_Selected_Component (Loc,
3705 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
3706 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
3708 Set_Is_In_Discriminant_Check (Dref);
3711 Evolve_Or_Else (Cond,
3714 Right_Opnd => Dval));
3717 Next_Discriminant (Disc_Ent);
3721 end Build_Discriminant_Checks;
3727 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
3734 function Left_Expression (Op : Node_Id) return Node_Id;
3735 -- Return the relevant expression from the left operand of the given
3736 -- short circuit form: this is LO itself, except if LO is a qualified
3737 -- expression, a type conversion, or an expression with actions, in
3738 -- which case this is Left_Expression (Expression (LO)).
3740 ---------------------
3741 -- Left_Expression --
3742 ---------------------
3744 function Left_Expression (Op : Node_Id) return Node_Id is
3745 LE : Node_Id := Left_Opnd (Op);
3747 while Nkind_In (LE, N_Qualified_Expression,
3749 N_Expression_With_Actions)
3751 LE := Expression (LE);
3755 end Left_Expression;
3757 -- Start of processing for Check_Needed
3760 -- Always check if not simple entity
3762 if Nkind (Nod) not in N_Has_Entity
3763 or else not Comes_From_Source (Nod)
3768 -- Look up tree for short circuit
3775 -- Done if out of subexpression (note that we allow generated stuff
3776 -- such as itype declarations in this context, to keep the loop going
3777 -- since we may well have generated such stuff in complex situations.
3778 -- Also done if no parent (probably an error condition, but no point
3779 -- in behaving nasty if we find it).
3782 or else (K not in N_Subexpr and then Comes_From_Source (P))
3786 -- Or/Or Else case, where test is part of the right operand, or is
3787 -- part of one of the actions associated with the right operand, and
3788 -- the left operand is an equality test.
3790 elsif K = N_Op_Or then
3791 exit when N = Right_Opnd (P)
3792 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3794 elsif K = N_Or_Else then
3795 exit when (N = Right_Opnd (P)
3798 and then List_Containing (N) = Actions (P)))
3799 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3801 -- Similar test for the And/And then case, where the left operand
3802 -- is an inequality test.
3804 elsif K = N_Op_And then
3805 exit when N = Right_Opnd (P)
3806 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3808 elsif K = N_And_Then then
3809 exit when (N = Right_Opnd (P)
3812 and then List_Containing (N) = Actions (P)))
3813 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3819 -- If we fall through the loop, then we have a conditional with an
3820 -- appropriate test as its left operand, so look further.
3822 L := Left_Expression (P);
3824 -- L is an "=" or "/=" operator: extract its operands
3826 R := Right_Opnd (L);
3829 -- Left operand of test must match original variable
3831 if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
3835 -- Right operand of test must be key value (zero or null)
3838 when Access_Check =>
3839 if not Known_Null (R) then
3843 when Division_Check =>
3844 if not Compile_Time_Known_Value (R)
3845 or else Expr_Value (R) /= Uint_0
3851 raise Program_Error;
3854 -- Here we have the optimizable case, warn if not short-circuited
3856 if K = N_Op_And or else K = N_Op_Or then
3857 Error_Msg_Warn := SPARK_Mode /= On;
3860 when Access_Check =>
3861 if GNATprove_Mode then
3863 ("Constraint_Error might have been raised (access check)",
3867 ("Constraint_Error may be raised (access check)??",
3871 when Division_Check =>
3872 if GNATprove_Mode then
3874 ("Constraint_Error might have been raised (zero divide)",
3878 ("Constraint_Error may be raised (zero divide)??",
3883 raise Program_Error;
3886 if K = N_Op_And then
3887 Error_Msg_N -- CODEFIX
3888 ("use `AND THEN` instead of AND??", P);
3890 Error_Msg_N -- CODEFIX
3891 ("use `OR ELSE` instead of OR??", P);
3894 -- If not short-circuited, we need the check
3898 -- If short-circuited, we can omit the check
3905 -----------------------------------
3906 -- Check_Valid_Lvalue_Subscripts --
3907 -----------------------------------
3909 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
3911 -- Skip this if range checks are suppressed
3913 if Range_Checks_Suppressed (Etype (Expr)) then
3916 -- Only do this check for expressions that come from source. We assume
3917 -- that expander generated assignments explicitly include any necessary
3918 -- checks. Note that this is not just an optimization, it avoids
3919 -- infinite recursions.
3921 elsif not Comes_From_Source (Expr) then
3924 -- For a selected component, check the prefix
3926 elsif Nkind (Expr) = N_Selected_Component then
3927 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3930 -- Case of indexed component
3932 elsif Nkind (Expr) = N_Indexed_Component then
3933 Apply_Subscript_Validity_Checks (Expr);
3935 -- Prefix may itself be or contain an indexed component, and these
3936 -- subscripts need checking as well.
3938 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3940 end Check_Valid_Lvalue_Subscripts;
3942 ----------------------------------
3943 -- Null_Exclusion_Static_Checks --
3944 ----------------------------------
3946 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
3947 Error_Node : Node_Id;
3949 Has_Null : constant Boolean := Has_Null_Exclusion (N);
3950 K : constant Node_Kind := Nkind (N);
3955 (Nkind_In (K, N_Component_Declaration,
3956 N_Discriminant_Specification,
3957 N_Function_Specification,
3958 N_Object_Declaration,
3959 N_Parameter_Specification));
3961 if K = N_Function_Specification then
3962 Typ := Etype (Defining_Entity (N));
3964 Typ := Etype (Defining_Identifier (N));
3968 when N_Component_Declaration =>
3969 if Present (Access_Definition (Component_Definition (N))) then
3970 Error_Node := Component_Definition (N);
3972 Error_Node := Subtype_Indication (Component_Definition (N));
3975 when N_Discriminant_Specification =>
3976 Error_Node := Discriminant_Type (N);
3978 when N_Function_Specification =>
3979 Error_Node := Result_Definition (N);
3981 when N_Object_Declaration =>
3982 Error_Node := Object_Definition (N);
3984 when N_Parameter_Specification =>
3985 Error_Node := Parameter_Type (N);
3988 raise Program_Error;
3993 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3994 -- applied to an access [sub]type.
3996 if not Is_Access_Type (Typ) then
3998 ("`NOT NULL` allowed only for an access type", Error_Node);
4000 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4001 -- be applied to a [sub]type that does not exclude null already.
4003 elsif Can_Never_Be_Null (Typ)
4004 and then Comes_From_Source (Typ)
4007 ("`NOT NULL` not allowed (& already excludes null)",
4012 -- Check that null-excluding objects are always initialized, except for
4013 -- deferred constants, for which the expression will appear in the full
4016 if K = N_Object_Declaration
4017 and then No (Expression (N))
4018 and then not Constant_Present (N)
4019 and then not No_Initialization (N)
4021 -- Add an expression that assigns null. This node is needed by
4022 -- Apply_Compile_Time_Constraint_Error, which will replace this with
4023 -- a Constraint_Error node.
4025 Set_Expression (N, Make_Null (Sloc (N)));
4026 Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
4028 Apply_Compile_Time_Constraint_Error
4029 (N => Expression (N),
4031 "(Ada 2005) null-excluding objects must be initialized??",
4032 Reason => CE_Null_Not_Allowed);
4035 -- Check that a null-excluding component, formal or object is not being
4036 -- assigned a null value. Otherwise generate a warning message and
4037 -- replace Expression (N) by an N_Constraint_Error node.
4039 if K /= N_Function_Specification then
4040 Expr := Expression (N);
4042 if Present (Expr) and then Known_Null (Expr) then
4044 when N_Component_Declaration |
4045 N_Discriminant_Specification =>
4046 Apply_Compile_Time_Constraint_Error
4048 Msg => "(Ada 2005) null not allowed "
4049 & "in null-excluding components??",
4050 Reason => CE_Null_Not_Allowed);
4052 when N_Object_Declaration =>
4053 Apply_Compile_Time_Constraint_Error
4055 Msg => "(Ada 2005) null not allowed "
4056 & "in null-excluding objects??",
4057 Reason => CE_Null_Not_Allowed);
4059 when N_Parameter_Specification =>
4060 Apply_Compile_Time_Constraint_Error
4062 Msg => "(Ada 2005) null not allowed "
4063 & "in null-excluding formals??",
4064 Reason => CE_Null_Not_Allowed);
4071 end Null_Exclusion_Static_Checks;
4073 ----------------------------------
4074 -- Conditional_Statements_Begin --
4075 ----------------------------------
4077 procedure Conditional_Statements_Begin is
4079 Saved_Checks_TOS := Saved_Checks_TOS + 1;
4081 -- If stack overflows, kill all checks, that way we know to simply reset
4082 -- the number of saved checks to zero on return. This should never occur
4085 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4088 -- In the normal case, we just make a new stack entry saving the current
4089 -- number of saved checks for a later restore.
4092 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
4094 if Debug_Flag_CC then
4095 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
4099 end Conditional_Statements_Begin;
4101 --------------------------------
4102 -- Conditional_Statements_End --
4103 --------------------------------
4105 procedure Conditional_Statements_End is
4107 pragma Assert (Saved_Checks_TOS > 0);
4109 -- If the saved checks stack overflowed, then we killed all checks, so
4110 -- setting the number of saved checks back to zero is correct. This
4111 -- should never occur in practice.
4113 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4114 Num_Saved_Checks := 0;
4116 -- In the normal case, restore the number of saved checks from the top
4120 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
4122 if Debug_Flag_CC then
4123 w ("Conditional_Statements_End: Num_Saved_Checks = ",
4128 Saved_Checks_TOS := Saved_Checks_TOS - 1;
4129 end Conditional_Statements_End;
4131 -------------------------
4132 -- Convert_From_Bignum --
4133 -------------------------
4135 function Convert_From_Bignum (N : Node_Id) return Node_Id is
4136 Loc : constant Source_Ptr := Sloc (N);
4139 pragma Assert (Is_RTE (Etype (N), RE_Bignum));
4141 -- Construct call From Bignum
4144 Make_Function_Call (Loc,
4146 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4147 Parameter_Associations => New_List (Relocate_Node (N)));
4148 end Convert_From_Bignum;
4150 -----------------------
4151 -- Convert_To_Bignum --
4152 -----------------------
4154 function Convert_To_Bignum (N : Node_Id) return Node_Id is
4155 Loc : constant Source_Ptr := Sloc (N);
4158 -- Nothing to do if Bignum already except call Relocate_Node
4160 if Is_RTE (Etype (N), RE_Bignum) then
4161 return Relocate_Node (N);
4163 -- Otherwise construct call to To_Bignum, converting the operand to the
4164 -- required Long_Long_Integer form.
4167 pragma Assert (Is_Signed_Integer_Type (Etype (N)));
4169 Make_Function_Call (Loc,
4171 New_Occurrence_Of (RTE (RE_To_Bignum), Loc),
4172 Parameter_Associations => New_List (
4173 Convert_To (Standard_Long_Long_Integer, Relocate_Node (N))));
4175 end Convert_To_Bignum;
4177 ---------------------
4178 -- Determine_Range --
4179 ---------------------
4181 Cache_Size : constant := 2 ** 10;
4182 type Cache_Index is range 0 .. Cache_Size - 1;
4183 -- Determine size of below cache (power of 2 is more efficient)
4185 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
4186 Determine_Range_Cache_V : array (Cache_Index) of Boolean;
4187 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
4188 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
4189 Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
4190 Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
4191 -- The above arrays are used to implement a small direct cache for
4192 -- Determine_Range and Determine_Range_R calls. Because of the way these
4193 -- subprograms recursively traces subexpressions, and because overflow
4194 -- checking calls the routine on the way up the tree, a quadratic behavior
4195 -- can otherwise be encountered in large expressions. The cache entry for
4196 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4197 -- by checking the actual node value stored there. The Range_Cache_V array
4198 -- records the setting of Assume_Valid for the cache entry.
4200 procedure Determine_Range
4205 Assume_Valid : Boolean := False)
4207 Typ : Entity_Id := Etype (N);
4208 -- Type to use, may get reset to base type for possibly invalid entity
4212 -- Lo and Hi bounds of left operand
4216 -- Lo and Hi bounds of right (or only) operand
4219 -- Temp variable used to hold a bound node
4222 -- High bound of base type of expression
4226 -- Refined values for low and high bounds, after tightening
4229 -- Used in lower level calls to indicate if call succeeded
4231 Cindex : Cache_Index;
4232 -- Used to search cache
4237 function OK_Operands return Boolean;
4238 -- Used for binary operators. Determines the ranges of the left and
4239 -- right operands, and if they are both OK, returns True, and puts
4240 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4246 function OK_Operands return Boolean is
4249 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4256 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4260 -- Start of processing for Determine_Range
4263 -- Prevent junk warnings by initializing range variables
4270 -- For temporary constants internally generated to remove side effects
4271 -- we must use the corresponding expression to determine the range of
4272 -- the expression. But note that the expander can also generate
4273 -- constants in other cases, including deferred constants.
4275 if Is_Entity_Name (N)
4276 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4277 and then Ekind (Entity (N)) = E_Constant
4278 and then Is_Internal_Name (Chars (Entity (N)))
4280 if Present (Expression (Parent (Entity (N)))) then
4282 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4284 elsif Present (Full_View (Entity (N))) then
4286 (Expression (Parent (Full_View (Entity (N)))),
4287 OK, Lo, Hi, Assume_Valid);
4295 -- If type is not defined, we can't determine its range
4299 -- We don't deal with anything except discrete types
4301 or else not Is_Discrete_Type (Typ)
4303 -- Ignore type for which an error has been posted, since range in
4304 -- this case may well be a bogosity deriving from the error. Also
4305 -- ignore if error posted on the reference node.
4307 or else Error_Posted (N) or else Error_Posted (Typ)
4313 -- For all other cases, we can determine the range
4317 -- If value is compile time known, then the possible range is the one
4318 -- value that we know this expression definitely has.
4320 if Compile_Time_Known_Value (N) then
4321 Lo := Expr_Value (N);
4326 -- Return if already in the cache
4328 Cindex := Cache_Index (N mod Cache_Size);
4330 if Determine_Range_Cache_N (Cindex) = N
4332 Determine_Range_Cache_V (Cindex) = Assume_Valid
4334 Lo := Determine_Range_Cache_Lo (Cindex);
4335 Hi := Determine_Range_Cache_Hi (Cindex);
4339 -- Otherwise, start by finding the bounds of the type of the expression,
4340 -- the value cannot be outside this range (if it is, then we have an
4341 -- overflow situation, which is a separate check, we are talking here
4342 -- only about the expression value).
4344 -- First a check, never try to find the bounds of a generic type, since
4345 -- these bounds are always junk values, and it is only valid to look at
4346 -- the bounds in an instance.
4348 if Is_Generic_Type (Typ) then
4353 -- First step, change to use base type unless we know the value is valid
4355 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4356 or else Assume_No_Invalid_Values
4357 or else Assume_Valid
4361 Typ := Underlying_Type (Base_Type (Typ));
4364 -- Retrieve the base type. Handle the case where the base type is a
4365 -- private enumeration type.
4367 Btyp := Base_Type (Typ);
4369 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4370 Btyp := Full_View (Btyp);
4373 -- We use the actual bound unless it is dynamic, in which case use the
4374 -- corresponding base type bound if possible. If we can't get a bound
4375 -- then we figure we can't determine the range (a peculiar case, that
4376 -- perhaps cannot happen, but there is no point in bombing in this
4377 -- optimization circuit.
4379 -- First the low bound
4381 Bound := Type_Low_Bound (Typ);
4383 if Compile_Time_Known_Value (Bound) then
4384 Lo := Expr_Value (Bound);
4386 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4387 Lo := Expr_Value (Type_Low_Bound (Btyp));
4394 -- Now the high bound
4396 Bound := Type_High_Bound (Typ);
4398 -- We need the high bound of the base type later on, and this should
4399 -- always be compile time known. Again, it is not clear that this
4400 -- can ever be false, but no point in bombing.
4402 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4403 Hbound := Expr_Value (Type_High_Bound (Btyp));
4411 -- If we have a static subtype, then that may have a tighter bound so
4412 -- use the upper bound of the subtype instead in this case.
4414 if Compile_Time_Known_Value (Bound) then
4415 Hi := Expr_Value (Bound);
4418 -- We may be able to refine this value in certain situations. If any
4419 -- refinement is possible, then Lor and Hir are set to possibly tighter
4420 -- bounds, and OK1 is set to True.
4424 -- For unary plus, result is limited by range of operand
4428 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4430 -- For unary minus, determine range of operand, and negate it
4434 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4441 -- For binary addition, get range of each operand and do the
4442 -- addition to get the result range.
4446 Lor := Lo_Left + Lo_Right;
4447 Hir := Hi_Left + Hi_Right;
4450 -- Division is tricky. The only case we consider is where the right
4451 -- operand is a positive constant, and in this case we simply divide
4452 -- the bounds of the left operand
4456 if Lo_Right = Hi_Right
4457 and then Lo_Right > 0
4459 Lor := Lo_Left / Lo_Right;
4460 Hir := Hi_Left / Lo_Right;
4466 -- For binary subtraction, get range of each operand and do the worst
4467 -- case subtraction to get the result range.
4469 when N_Op_Subtract =>
4471 Lor := Lo_Left - Hi_Right;
4472 Hir := Hi_Left - Lo_Right;
4475 -- For MOD, if right operand is a positive constant, then result must
4476 -- be in the allowable range of mod results.
4480 if Lo_Right = Hi_Right
4481 and then Lo_Right /= 0
4483 if Lo_Right > 0 then
4485 Hir := Lo_Right - 1;
4487 else -- Lo_Right < 0
4488 Lor := Lo_Right + 1;
4497 -- For REM, if right operand is a positive constant, then result must
4498 -- be in the allowable range of mod results.
4502 if Lo_Right = Hi_Right
4503 and then Lo_Right /= 0
4506 Dval : constant Uint := (abs Lo_Right) - 1;
4509 -- The sign of the result depends on the sign of the
4510 -- dividend (but not on the sign of the divisor, hence
4511 -- the abs operation above).
4531 -- Attribute reference cases
4533 when N_Attribute_Reference =>
4534 case Attribute_Name (N) is
4536 -- For Pos/Val attributes, we can refine the range using the
4537 -- possible range of values of the attribute expression.
4539 when Name_Pos | Name_Val =>
4541 (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
4543 -- For Length attribute, use the bounds of the corresponding
4544 -- index type to refine the range.
4548 Atyp : Entity_Id := Etype (Prefix (N));
4556 if Is_Access_Type (Atyp) then
4557 Atyp := Designated_Type (Atyp);
4560 -- For string literal, we know exact value
4562 if Ekind (Atyp) = E_String_Literal_Subtype then
4564 Lo := String_Literal_Length (Atyp);
4565 Hi := String_Literal_Length (Atyp);
4569 -- Otherwise check for expression given
4571 if No (Expressions (N)) then
4575 UI_To_Int (Expr_Value (First (Expressions (N))));
4578 Indx := First_Index (Atyp);
4579 for J in 2 .. Inum loop
4580 Indx := Next_Index (Indx);
4583 -- If the index type is a formal type or derived from
4584 -- one, the bounds are not static.
4586 if Is_Generic_Type (Root_Type (Etype (Indx))) then
4592 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
4597 (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
4602 -- The maximum value for Length is the biggest
4603 -- possible gap between the values of the bounds.
4604 -- But of course, this value cannot be negative.
4606 Hir := UI_Max (Uint_0, UU - LL + 1);
4608 -- For constrained arrays, the minimum value for
4609 -- Length is taken from the actual value of the
4610 -- bounds, since the index will be exactly of this
4613 if Is_Constrained (Atyp) then
4614 Lor := UI_Max (Uint_0, UL - LU + 1);
4616 -- For an unconstrained array, the minimum value
4617 -- for length is always zero.
4626 -- No special handling for other attributes
4627 -- Probably more opportunities exist here???
4634 -- For type conversion from one discrete type to another, we can
4635 -- refine the range using the converted value.
4637 when N_Type_Conversion =>
4638 Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
4640 -- Nothing special to do for all other expression kinds
4648 -- At this stage, if OK1 is true, then we know that the actual result of
4649 -- the computed expression is in the range Lor .. Hir. We can use this
4650 -- to restrict the possible range of results.
4654 -- If the refined value of the low bound is greater than the type
4655 -- low bound, then reset it to the more restrictive value. However,
4656 -- we do NOT do this for the case of a modular type where the
4657 -- possible upper bound on the value is above the base type high
4658 -- bound, because that means the result could wrap.
4661 and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound)
4666 -- Similarly, if the refined value of the high bound is less than the
4667 -- value so far, then reset it to the more restrictive value. Again,
4668 -- we do not do this if the refined low bound is negative for a
4669 -- modular type, since this would wrap.
4672 and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0)
4678 -- Set cache entry for future call and we are all done
4680 Determine_Range_Cache_N (Cindex) := N;
4681 Determine_Range_Cache_V (Cindex) := Assume_Valid;
4682 Determine_Range_Cache_Lo (Cindex) := Lo;
4683 Determine_Range_Cache_Hi (Cindex) := Hi;
4686 -- If any exception occurs, it means that we have some bug in the compiler,
4687 -- possibly triggered by a previous error, or by some unforeseen peculiar
4688 -- occurrence. However, this is only an optimization attempt, so there is
4689 -- really no point in crashing the compiler. Instead we just decide, too
4690 -- bad, we can't figure out a range in this case after all.
4695 -- Debug flag K disables this behavior (useful for debugging)
4697 if Debug_Flag_K then
4705 end Determine_Range;
4707 -----------------------
4708 -- Determine_Range_R --
4709 -----------------------
4711 procedure Determine_Range_R
4716 Assume_Valid : Boolean := False)
4718 Typ : Entity_Id := Etype (N);
4719 -- Type to use, may get reset to base type for possibly invalid entity
4723 -- Lo and Hi bounds of left operand
4727 -- Lo and Hi bounds of right (or only) operand
4730 -- Temp variable used to hold a bound node
4733 -- High bound of base type of expression
4737 -- Refined values for low and high bounds, after tightening
4740 -- Used in lower level calls to indicate if call succeeded
4742 Cindex : Cache_Index;
4743 -- Used to search cache
4748 function OK_Operands return Boolean;
4749 -- Used for binary operators. Determines the ranges of the left and
4750 -- right operands, and if they are both OK, returns True, and puts
4751 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4753 function Round_Machine (B : Ureal) return Ureal;
4754 -- B is a real bound. Round it using mode Round_Even.
4760 function OK_Operands return Boolean is
4763 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4770 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4778 function Round_Machine (B : Ureal) return Ureal is
4780 return Machine (Typ, B, Round_Even, N);
4783 -- Start of processing for Determine_Range_R
4786 -- Prevent junk warnings by initializing range variables
4793 -- For temporary constants internally generated to remove side effects
4794 -- we must use the corresponding expression to determine the range of
4795 -- the expression. But note that the expander can also generate
4796 -- constants in other cases, including deferred constants.
4798 if Is_Entity_Name (N)
4799 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4800 and then Ekind (Entity (N)) = E_Constant
4801 and then Is_Internal_Name (Chars (Entity (N)))
4803 if Present (Expression (Parent (Entity (N)))) then
4805 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4807 elsif Present (Full_View (Entity (N))) then
4809 (Expression (Parent (Full_View (Entity (N)))),
4810 OK, Lo, Hi, Assume_Valid);
4819 -- If type is not defined, we can't determine its range
4823 -- We don't deal with anything except IEEE floating-point types
4825 or else not Is_Floating_Point_Type (Typ)
4826 or else Float_Rep (Typ) /= IEEE_Binary
4828 -- Ignore type for which an error has been posted, since range in
4829 -- this case may well be a bogosity deriving from the error. Also
4830 -- ignore if error posted on the reference node.
4832 or else Error_Posted (N) or else Error_Posted (Typ)
4838 -- For all other cases, we can determine the range
4842 -- If value is compile time known, then the possible range is the one
4843 -- value that we know this expression definitely has.
4845 if Compile_Time_Known_Value (N) then
4846 Lo := Expr_Value_R (N);
4851 -- Return if already in the cache
4853 Cindex := Cache_Index (N mod Cache_Size);
4855 if Determine_Range_Cache_N (Cindex) = N
4857 Determine_Range_Cache_V (Cindex) = Assume_Valid
4859 Lo := Determine_Range_Cache_Lo_R (Cindex);
4860 Hi := Determine_Range_Cache_Hi_R (Cindex);
4864 -- Otherwise, start by finding the bounds of the type of the expression,
4865 -- the value cannot be outside this range (if it is, then we have an
4866 -- overflow situation, which is a separate check, we are talking here
4867 -- only about the expression value).
4869 -- First a check, never try to find the bounds of a generic type, since
4870 -- these bounds are always junk values, and it is only valid to look at
4871 -- the bounds in an instance.
4873 if Is_Generic_Type (Typ) then
4878 -- First step, change to use base type unless we know the value is valid
4880 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4881 or else Assume_No_Invalid_Values
4882 or else Assume_Valid
4886 Typ := Underlying_Type (Base_Type (Typ));
4889 -- Retrieve the base type. Handle the case where the base type is a
4892 Btyp := Base_Type (Typ);
4894 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4895 Btyp := Full_View (Btyp);
4898 -- We use the actual bound unless it is dynamic, in which case use the
4899 -- corresponding base type bound if possible. If we can't get a bound
4900 -- then we figure we can't determine the range (a peculiar case, that
4901 -- perhaps cannot happen, but there is no point in bombing in this
4902 -- optimization circuit).
4904 -- First the low bound
4906 Bound := Type_Low_Bound (Typ);
4908 if Compile_Time_Known_Value (Bound) then
4909 Lo := Expr_Value_R (Bound);
4911 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4912 Lo := Expr_Value_R (Type_Low_Bound (Btyp));
4919 -- Now the high bound
4921 Bound := Type_High_Bound (Typ);
4923 -- We need the high bound of the base type later on, and this should
4924 -- always be compile time known. Again, it is not clear that this
4925 -- can ever be false, but no point in bombing.
4927 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4928 Hbound := Expr_Value_R (Type_High_Bound (Btyp));
4936 -- If we have a static subtype, then that may have a tighter bound so
4937 -- use the upper bound of the subtype instead in this case.
4939 if Compile_Time_Known_Value (Bound) then
4940 Hi := Expr_Value_R (Bound);
4943 -- We may be able to refine this value in certain situations. If any
4944 -- refinement is possible, then Lor and Hir are set to possibly tighter
4945 -- bounds, and OK1 is set to True.
4949 -- For unary plus, result is limited by range of operand
4953 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4955 -- For unary minus, determine range of operand, and negate it
4959 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4966 -- For binary addition, get range of each operand and do the
4967 -- addition to get the result range.
4971 Lor := Round_Machine (Lo_Left + Lo_Right);
4972 Hir := Round_Machine (Hi_Left + Hi_Right);
4975 -- For binary subtraction, get range of each operand and do the worst
4976 -- case subtraction to get the result range.
4978 when N_Op_Subtract =>
4980 Lor := Round_Machine (Lo_Left - Hi_Right);
4981 Hir := Round_Machine (Hi_Left - Lo_Right);
4984 -- For multiplication, get range of each operand and do the
4985 -- four multiplications to get the result range.
4987 when N_Op_Multiply =>
4990 M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
4991 M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
4992 M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
4993 M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
4995 Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
4996 Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
5000 -- For division, consider separately the cases where the right
5001 -- operand is positive or negative. Otherwise, the right operand
5002 -- can be arbitrarily close to zero, so the result is likely to
5003 -- be unbounded in one direction, do not attempt to compute it.
5008 -- Right operand is positive
5010 if Lo_Right > Ureal_0 then
5012 -- If the low bound of the left operand is negative, obtain
5013 -- the overall low bound by dividing it by the smallest
5014 -- value of the right operand, and otherwise by the largest
5015 -- value of the right operand.
5017 if Lo_Left < Ureal_0 then
5018 Lor := Round_Machine (Lo_Left / Lo_Right);
5020 Lor := Round_Machine (Lo_Left / Hi_Right);
5023 -- If the high bound of the left operand is negative, obtain
5024 -- the overall high bound by dividing it by the largest
5025 -- value of the right operand, and otherwise by the
5026 -- smallest value of the right operand.
5028 if Hi_Left < Ureal_0 then
5029 Hir := Round_Machine (Hi_Left / Hi_Right);
5031 Hir := Round_Machine (Hi_Left / Lo_Right);
5034 -- Right operand is negative
5036 elsif Hi_Right < Ureal_0 then
5038 -- If the low bound of the left operand is negative, obtain
5039 -- the overall low bound by dividing it by the largest
5040 -- value of the right operand, and otherwise by the smallest
5041 -- value of the right operand.
5043 if Lo_Left < Ureal_0 then
5044 Lor := Round_Machine (Lo_Left / Hi_Right);
5046 Lor := Round_Machine (Lo_Left / Lo_Right);
5049 -- If the high bound of the left operand is negative, obtain
5050 -- the overall high bound by dividing it by the smallest
5051 -- value of the right operand, and otherwise by the
5052 -- largest value of the right operand.
5054 if Hi_Left < Ureal_0 then
5055 Hir := Round_Machine (Hi_Left / Lo_Right);
5057 Hir := Round_Machine (Hi_Left / Hi_Right);
5065 -- For type conversion from one floating-point type to another, we
5066 -- can refine the range using the converted value.
5068 when N_Type_Conversion =>
5069 Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
5071 -- Nothing special to do for all other expression kinds
5079 -- At this stage, if OK1 is true, then we know that the actual result of
5080 -- the computed expression is in the range Lor .. Hir. We can use this
5081 -- to restrict the possible range of results.
5085 -- If the refined value of the low bound is greater than the type
5086 -- low bound, then reset it to the more restrictive value.
5092 -- Similarly, if the refined value of the high bound is less than the
5093 -- value so far, then reset it to the more restrictive value.
5100 -- Set cache entry for future call and we are all done
5102 Determine_Range_Cache_N (Cindex) := N;
5103 Determine_Range_Cache_V (Cindex) := Assume_Valid;
5104 Determine_Range_Cache_Lo_R (Cindex) := Lo;
5105 Determine_Range_Cache_Hi_R (Cindex) := Hi;
5108 -- If any exception occurs, it means that we have some bug in the compiler,
5109 -- possibly triggered by a previous error, or by some unforeseen peculiar
5110 -- occurrence. However, this is only an optimization attempt, so there is
5111 -- really no point in crashing the compiler. Instead we just decide, too
5112 -- bad, we can't figure out a range in this case after all.
5117 -- Debug flag K disables this behavior (useful for debugging)
5119 if Debug_Flag_K then
5127 end Determine_Range_R;
5129 ------------------------------------
5130 -- Discriminant_Checks_Suppressed --
5131 ------------------------------------
5133 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
5136 if Is_Unchecked_Union (E) then
5138 elsif Checks_May_Be_Suppressed (E) then
5139 return Is_Check_Suppressed (E, Discriminant_Check);
5143 return Scope_Suppress.Suppress (Discriminant_Check);
5144 end Discriminant_Checks_Suppressed;
5146 --------------------------------
5147 -- Division_Checks_Suppressed --
5148 --------------------------------
5150 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
5152 if Present (E) and then Checks_May_Be_Suppressed (E) then
5153 return Is_Check_Suppressed (E, Division_Check);
5155 return Scope_Suppress.Suppress (Division_Check);
5157 end Division_Checks_Suppressed;
5159 --------------------------------------
5160 -- Duplicated_Tag_Checks_Suppressed --
5161 --------------------------------------
5163 function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
5165 if Present (E) and then Checks_May_Be_Suppressed (E) then
5166 return Is_Check_Suppressed (E, Duplicated_Tag_Check);
5168 return Scope_Suppress.Suppress (Duplicated_Tag_Check);
5170 end Duplicated_Tag_Checks_Suppressed;
5172 -----------------------------------
5173 -- Elaboration_Checks_Suppressed --
5174 -----------------------------------
5176 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
5178 -- The complication in this routine is that if we are in the dynamic
5179 -- model of elaboration, we also check All_Checks, since All_Checks
5180 -- does not set Elaboration_Check explicitly.
5183 if Kill_Elaboration_Checks (E) then
5186 elsif Checks_May_Be_Suppressed (E) then
5187 if Is_Check_Suppressed (E, Elaboration_Check) then
5189 elsif Dynamic_Elaboration_Checks then
5190 return Is_Check_Suppressed (E, All_Checks);
5197 if Scope_Suppress.Suppress (Elaboration_Check) then
5199 elsif Dynamic_Elaboration_Checks then
5200 return Scope_Suppress.Suppress (All_Checks);
5204 end Elaboration_Checks_Suppressed;
5206 ---------------------------
5207 -- Enable_Overflow_Check --
5208 ---------------------------
5210 procedure Enable_Overflow_Check (N : Node_Id) is
5211 Typ : constant Entity_Id := Base_Type (Etype (N));
5212 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
5220 Do_Ovflow_Check : Boolean;
5223 if Debug_Flag_CC then
5224 w ("Enable_Overflow_Check for node ", Int (N));
5225 Write_Str (" Source location = ");
5230 -- No check if overflow checks suppressed for type of node
5232 if Overflow_Checks_Suppressed (Etype (N)) then
5235 -- Nothing to do for unsigned integer types, which do not overflow
5237 elsif Is_Modular_Integer_Type (Typ) then
5241 -- This is the point at which processing for STRICT mode diverges
5242 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5243 -- probably more extreme that it needs to be, but what is going on here
5244 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5245 -- to leave the processing for STRICT mode untouched. There were
5246 -- two reasons for this. First it avoided any incompatible change of
5247 -- behavior. Second, it guaranteed that STRICT mode continued to be
5250 -- The big difference is that in STRICT mode there is a fair amount of
5251 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5252 -- know that no check is needed. We skip all that in the two new modes,
5253 -- since really overflow checking happens over a whole subtree, and we
5254 -- do the corresponding optimizations later on when applying the checks.
5256 if Mode in Minimized_Or_Eliminated then
5257 if not (Overflow_Checks_Suppressed (Etype (N)))
5258 and then not (Is_Entity_Name (N)
5259 and then Overflow_Checks_Suppressed (Entity (N)))
5261 Activate_Overflow_Check (N);
5264 if Debug_Flag_CC then
5265 w ("Minimized/Eliminated mode");
5271 -- Remainder of processing is for STRICT case, and is unchanged from
5272 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5274 -- Nothing to do if the range of the result is known OK. We skip this
5275 -- for conversions, since the caller already did the check, and in any
5276 -- case the condition for deleting the check for a type conversion is
5279 if Nkind (N) /= N_Type_Conversion then
5280 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
5282 -- Note in the test below that we assume that the range is not OK
5283 -- if a bound of the range is equal to that of the type. That's not
5284 -- quite accurate but we do this for the following reasons:
5286 -- a) The way that Determine_Range works, it will typically report
5287 -- the bounds of the value as being equal to the bounds of the
5288 -- type, because it either can't tell anything more precise, or
5289 -- does not think it is worth the effort to be more precise.
5291 -- b) It is very unusual to have a situation in which this would
5292 -- generate an unnecessary overflow check (an example would be
5293 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5294 -- literal value one is added).
5296 -- c) The alternative is a lot of special casing in this routine
5297 -- which would partially duplicate Determine_Range processing.
5300 Do_Ovflow_Check := True;
5302 -- Note that the following checks are quite deliberately > and <
5303 -- rather than >= and <= as explained above.
5305 if Lo > Expr_Value (Type_Low_Bound (Typ))
5307 Hi < Expr_Value (Type_High_Bound (Typ))
5309 Do_Ovflow_Check := False;
5311 -- Despite the comments above, it is worth dealing specially with
5312 -- division specially. The only case where integer division can
5313 -- overflow is (largest negative number) / (-1). So we will do
5314 -- an extra range analysis to see if this is possible.
5316 elsif Nkind (N) = N_Op_Divide then
5318 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5320 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then
5321 Do_Ovflow_Check := False;
5325 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5327 if OK and then (Lo > Uint_Minus_1
5331 Do_Ovflow_Check := False;
5336 -- If no overflow check required, we are done
5338 if not Do_Ovflow_Check then
5339 if Debug_Flag_CC then
5340 w ("No overflow check required");
5348 -- If not in optimizing mode, set flag and we are done. We are also done
5349 -- (and just set the flag) if the type is not a discrete type, since it
5350 -- is not worth the effort to eliminate checks for other than discrete
5351 -- types. In addition, we take this same path if we have stored the
5352 -- maximum number of checks possible already (a very unlikely situation,
5353 -- but we do not want to blow up).
5355 if Optimization_Level = 0
5356 or else not Is_Discrete_Type (Etype (N))
5357 or else Num_Saved_Checks = Saved_Checks'Last
5359 Activate_Overflow_Check (N);
5361 if Debug_Flag_CC then
5362 w ("Optimization off");
5368 -- Otherwise evaluate and check the expression
5373 Target_Type => Empty,
5379 if Debug_Flag_CC then
5380 w ("Called Find_Check");
5384 w (" Check_Num = ", Chk);
5385 w (" Ent = ", Int (Ent));
5386 Write_Str (" Ofs = ");
5391 -- If check is not of form to optimize, then set flag and we are done
5394 Activate_Overflow_Check (N);
5398 -- If check is already performed, then return without setting flag
5401 if Debug_Flag_CC then
5402 w ("Check suppressed!");
5408 -- Here we will make a new entry for the new check
5410 Activate_Overflow_Check (N);
5411 Num_Saved_Checks := Num_Saved_Checks + 1;
5412 Saved_Checks (Num_Saved_Checks) :=
5417 Target_Type => Empty);
5419 if Debug_Flag_CC then
5420 w ("Make new entry, check number = ", Num_Saved_Checks);
5421 w (" Entity = ", Int (Ent));
5422 Write_Str (" Offset = ");
5424 w (" Check_Type = O");
5425 w (" Target_Type = Empty");
5428 -- If we get an exception, then something went wrong, probably because of
5429 -- an error in the structure of the tree due to an incorrect program. Or
5430 -- it may be a bug in the optimization circuit. In either case the safest
5431 -- thing is simply to set the check flag unconditionally.
5435 Activate_Overflow_Check (N);
5437 if Debug_Flag_CC then
5438 w (" exception occurred, overflow flag set");
5442 end Enable_Overflow_Check;
5444 ------------------------
5445 -- Enable_Range_Check --
5446 ------------------------
5448 procedure Enable_Range_Check (N : Node_Id) is
5457 -- Return if unchecked type conversion with range check killed. In this
5458 -- case we never set the flag (that's what Kill_Range_Check is about).
5460 if Nkind (N) = N_Unchecked_Type_Conversion
5461 and then Kill_Range_Check (N)
5466 -- Do not set range check flag if parent is assignment statement or
5467 -- object declaration with Suppress_Assignment_Checks flag set
5469 if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
5470 and then Suppress_Assignment_Checks (Parent (N))
5475 -- Check for various cases where we should suppress the range check
5477 -- No check if range checks suppressed for type of node
5479 if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then
5482 -- No check if node is an entity name, and range checks are suppressed
5483 -- for this entity, or for the type of this entity.
5485 elsif Is_Entity_Name (N)
5486 and then (Range_Checks_Suppressed (Entity (N))
5487 or else Range_Checks_Suppressed (Etype (Entity (N))))
5491 -- No checks if index of array, and index checks are suppressed for
5492 -- the array object or the type of the array.
5494 elsif Nkind (Parent (N)) = N_Indexed_Component then
5496 Pref : constant Node_Id := Prefix (Parent (N));
5498 if Is_Entity_Name (Pref)
5499 and then Index_Checks_Suppressed (Entity (Pref))
5502 elsif Index_Checks_Suppressed (Etype (Pref)) then
5508 -- Debug trace output
5510 if Debug_Flag_CC then
5511 w ("Enable_Range_Check for node ", Int (N));
5512 Write_Str (" Source location = ");
5517 -- If not in optimizing mode, set flag and we are done. We are also done
5518 -- (and just set the flag) if the type is not a discrete type, since it
5519 -- is not worth the effort to eliminate checks for other than discrete
5520 -- types. In addition, we take this same path if we have stored the
5521 -- maximum number of checks possible already (a very unlikely situation,
5522 -- but we do not want to blow up).
5524 if Optimization_Level = 0
5525 or else No (Etype (N))
5526 or else not Is_Discrete_Type (Etype (N))
5527 or else Num_Saved_Checks = Saved_Checks'Last
5529 Activate_Range_Check (N);
5531 if Debug_Flag_CC then
5532 w ("Optimization off");
5538 -- Otherwise find out the target type
5542 -- For assignment, use left side subtype
5544 if Nkind (P) = N_Assignment_Statement
5545 and then Expression (P) = N
5547 Ttyp := Etype (Name (P));
5549 -- For indexed component, use subscript subtype
5551 elsif Nkind (P) = N_Indexed_Component then
5558 Atyp := Etype (Prefix (P));
5560 if Is_Access_Type (Atyp) then
5561 Atyp := Designated_Type (Atyp);
5563 -- If the prefix is an access to an unconstrained array,
5564 -- perform check unconditionally: it depends on the bounds of
5565 -- an object and we cannot currently recognize whether the test
5566 -- may be redundant.
5568 if not Is_Constrained (Atyp) then
5569 Activate_Range_Check (N);
5573 -- Ditto if prefix is simply an unconstrained array. We used
5574 -- to think this case was OK, if the prefix was not an explicit
5575 -- dereference, but we have now seen a case where this is not
5576 -- true, so it is safer to just suppress the optimization in this
5577 -- case. The back end is getting better at eliminating redundant
5578 -- checks in any case, so the loss won't be important.
5580 elsif Is_Array_Type (Atyp)
5581 and then not Is_Constrained (Atyp)
5583 Activate_Range_Check (N);
5587 Indx := First_Index (Atyp);
5588 Subs := First (Expressions (P));
5591 Ttyp := Etype (Indx);
5600 -- For now, ignore all other cases, they are not so interesting
5603 if Debug_Flag_CC then
5604 w (" target type not found, flag set");
5607 Activate_Range_Check (N);
5611 -- Evaluate and check the expression
5616 Target_Type => Ttyp,
5622 if Debug_Flag_CC then
5623 w ("Called Find_Check");
5624 w ("Target_Typ = ", Int (Ttyp));
5628 w (" Check_Num = ", Chk);
5629 w (" Ent = ", Int (Ent));
5630 Write_Str (" Ofs = ");
5635 -- If check is not of form to optimize, then set flag and we are done
5638 if Debug_Flag_CC then
5639 w (" expression not of optimizable type, flag set");
5642 Activate_Range_Check (N);
5646 -- If check is already performed, then return without setting flag
5649 if Debug_Flag_CC then
5650 w ("Check suppressed!");
5656 -- Here we will make a new entry for the new check
5658 Activate_Range_Check (N);
5659 Num_Saved_Checks := Num_Saved_Checks + 1;
5660 Saved_Checks (Num_Saved_Checks) :=
5665 Target_Type => Ttyp);
5667 if Debug_Flag_CC then
5668 w ("Make new entry, check number = ", Num_Saved_Checks);
5669 w (" Entity = ", Int (Ent));
5670 Write_Str (" Offset = ");
5672 w (" Check_Type = R");
5673 w (" Target_Type = ", Int (Ttyp));
5674 pg (Union_Id (Ttyp));
5677 -- If we get an exception, then something went wrong, probably because of
5678 -- an error in the structure of the tree due to an incorrect program. Or
5679 -- it may be a bug in the optimization circuit. In either case the safest
5680 -- thing is simply to set the check flag unconditionally.
5684 Activate_Range_Check (N);
5686 if Debug_Flag_CC then
5687 w (" exception occurred, range flag set");
5691 end Enable_Range_Check;
5697 procedure Ensure_Valid
5699 Holes_OK : Boolean := False;
5700 Related_Id : Entity_Id := Empty;
5701 Is_Low_Bound : Boolean := False;
5702 Is_High_Bound : Boolean := False)
5704 Typ : constant Entity_Id := Etype (Expr);
5707 -- Ignore call if we are not doing any validity checking
5709 if not Validity_Checks_On then
5712 -- Ignore call if range or validity checks suppressed on entity or type
5714 elsif Range_Or_Validity_Checks_Suppressed (Expr) then
5717 -- No check required if expression is from the expander, we assume the
5718 -- expander will generate whatever checks are needed. Note that this is
5719 -- not just an optimization, it avoids infinite recursions.
5721 -- Unchecked conversions must be checked, unless they are initialized
5722 -- scalar values, as in a component assignment in an init proc.
5724 -- In addition, we force a check if Force_Validity_Checks is set
5726 elsif not Comes_From_Source (Expr)
5727 and then not Force_Validity_Checks
5728 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
5729 or else Kill_Range_Check (Expr))
5733 -- No check required if expression is known to have valid value
5735 elsif Expr_Known_Valid (Expr) then
5738 -- No check needed within a generated predicate function. Validity
5739 -- of input value will have been checked earlier.
5741 elsif Ekind (Current_Scope) = E_Function
5742 and then Is_Predicate_Function (Current_Scope)
5746 -- Ignore case of enumeration with holes where the flag is set not to
5747 -- worry about holes, since no special validity check is needed
5749 elsif Is_Enumeration_Type (Typ)
5750 and then Has_Non_Standard_Rep (Typ)
5755 -- No check required on the left-hand side of an assignment
5757 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
5758 and then Expr = Name (Parent (Expr))
5762 -- No check on a universal real constant. The context will eventually
5763 -- convert it to a machine number for some target type, or report an
5766 elsif Nkind (Expr) = N_Real_Literal
5767 and then Etype (Expr) = Universal_Real
5771 -- If the expression denotes a component of a packed boolean array,
5772 -- no possible check applies. We ignore the old ACATS chestnuts that
5773 -- involve Boolean range True..True.
5775 -- Note: validity checks are generated for expressions that yield a
5776 -- scalar type, when it is possible to create a value that is outside of
5777 -- the type. If this is a one-bit boolean no such value exists. This is
5778 -- an optimization, and it also prevents compiler blowing up during the
5779 -- elaboration of improperly expanded packed array references.
5781 elsif Nkind (Expr) = N_Indexed_Component
5782 and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
5783 and then Root_Type (Etype (Expr)) = Standard_Boolean
5787 -- For an expression with actions, we want to insert the validity check
5788 -- on the final Expression.
5790 elsif Nkind (Expr) = N_Expression_With_Actions then
5791 Ensure_Valid (Expression (Expr));
5794 -- An annoying special case. If this is an out parameter of a scalar
5795 -- type, then the value is not going to be accessed, therefore it is
5796 -- inappropriate to do any validity check at the call site.
5799 -- Only need to worry about scalar types
5801 if Is_Scalar_Type (Typ) then
5811 -- Find actual argument (which may be a parameter association)
5812 -- and the parent of the actual argument (the call statement)
5817 if Nkind (P) = N_Parameter_Association then
5822 -- Only need to worry if we are argument of a procedure call
5823 -- since functions don't have out parameters. If this is an
5824 -- indirect or dispatching call, get signature from the
5827 if Nkind (P) = N_Procedure_Call_Statement then
5828 L := Parameter_Associations (P);
5830 if Is_Entity_Name (Name (P)) then
5831 E := Entity (Name (P));
5833 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
5834 E := Etype (Name (P));
5837 -- Only need to worry if there are indeed actuals, and if
5838 -- this could be a procedure call, otherwise we cannot get a
5839 -- match (either we are not an argument, or the mode of the
5840 -- formal is not OUT). This test also filters out the
5843 if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
5845 -- This is the loop through parameters, looking for an
5846 -- OUT parameter for which we are the argument.
5848 F := First_Formal (E);
5850 while Present (F) loop
5851 if Ekind (F) = E_Out_Parameter and then A = N then
5864 -- If this is a boolean expression, only its elementary operands need
5865 -- checking: if they are valid, a boolean or short-circuit operation
5866 -- with them will be valid as well.
5868 if Base_Type (Typ) = Standard_Boolean
5870 (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit)
5875 -- If we fall through, a validity check is required
5877 Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound);
5879 if Is_Entity_Name (Expr)
5880 and then Safe_To_Capture_Value (Expr, Entity (Expr))
5882 Set_Is_Known_Valid (Entity (Expr));
5886 ----------------------
5887 -- Expr_Known_Valid --
5888 ----------------------
5890 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
5891 Typ : constant Entity_Id := Etype (Expr);
5894 -- Non-scalar types are always considered valid, since they never give
5895 -- rise to the issues of erroneous or bounded error behavior that are
5896 -- the concern. In formal reference manual terms the notion of validity
5897 -- only applies to scalar types. Note that even when packed arrays are
5898 -- represented using modular types, they are still arrays semantically,
5899 -- so they are also always valid (in particular, the unused bits can be
5900 -- random rubbish without affecting the validity of the array value).
5902 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then
5905 -- If no validity checking, then everything is considered valid
5907 elsif not Validity_Checks_On then
5910 -- Floating-point types are considered valid unless floating-point
5911 -- validity checks have been specifically turned on.
5913 elsif Is_Floating_Point_Type (Typ)
5914 and then not Validity_Check_Floating_Point
5918 -- If the expression is the value of an object that is known to be
5919 -- valid, then clearly the expression value itself is valid.
5921 elsif Is_Entity_Name (Expr)
5922 and then Is_Known_Valid (Entity (Expr))
5924 -- Exclude volatile variables
5926 and then not Treat_As_Volatile (Entity (Expr))
5930 -- References to discriminants are always considered valid. The value
5931 -- of a discriminant gets checked when the object is built. Within the
5932 -- record, we consider it valid, and it is important to do so, since
5933 -- otherwise we can try to generate bogus validity checks which
5934 -- reference discriminants out of scope. Discriminants of concurrent
5935 -- types are excluded for the same reason.
5937 elsif Is_Entity_Name (Expr)
5938 and then Denotes_Discriminant (Expr, Check_Concurrent => True)
5942 -- If the type is one for which all values are known valid, then we are
5943 -- sure that the value is valid except in the slightly odd case where
5944 -- the expression is a reference to a variable whose size has been
5945 -- explicitly set to a value greater than the object size.
5947 elsif Is_Known_Valid (Typ) then
5948 if Is_Entity_Name (Expr)
5949 and then Ekind (Entity (Expr)) = E_Variable
5950 and then Esize (Entity (Expr)) > Esize (Typ)
5957 -- Integer and character literals always have valid values, where
5958 -- appropriate these will be range checked in any case.
5960 elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
5963 -- If we have a type conversion or a qualification of a known valid
5964 -- value, then the result will always be valid.
5966 elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
5967 return Expr_Known_Valid (Expression (Expr));
5969 -- Case of expression is a non-floating-point operator. In this case we
5970 -- can assume the result is valid the generated code for the operator
5971 -- will include whatever checks are needed (e.g. range checks) to ensure
5972 -- validity. This assumption does not hold for the floating-point case,
5973 -- since floating-point operators can generate Infinite or NaN results
5974 -- which are considered invalid.
5976 -- Historical note: in older versions, the exemption of floating-point
5977 -- types from this assumption was done only in cases where the parent
5978 -- was an assignment, function call or parameter association. Presumably
5979 -- the idea was that in other contexts, the result would be checked
5980 -- elsewhere, but this list of cases was missing tests (at least the
5981 -- N_Object_Declaration case, as shown by a reported missing validity
5982 -- check), and it is not clear why function calls but not procedure
5983 -- calls were tested for. It really seems more accurate and much
5984 -- safer to recognize that expressions which are the result of a
5985 -- floating-point operator can never be assumed to be valid.
5987 elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then
5990 -- The result of a membership test is always valid, since it is true or
5991 -- false, there are no other possibilities.
5993 elsif Nkind (Expr) in N_Membership_Test then
5996 -- For all other cases, we do not know the expression is valid
6001 end Expr_Known_Valid;
6007 procedure Find_Check
6009 Check_Type : Character;
6010 Target_Type : Entity_Id;
6011 Entry_OK : out Boolean;
6012 Check_Num : out Nat;
6013 Ent : out Entity_Id;
6016 function Within_Range_Of
6017 (Target_Type : Entity_Id;
6018 Check_Type : Entity_Id) return Boolean;
6019 -- Given a requirement for checking a range against Target_Type, and
6020 -- and a range Check_Type against which a check has already been made,
6021 -- determines if the check against check type is sufficient to ensure
6022 -- that no check against Target_Type is required.
6024 ---------------------
6025 -- Within_Range_Of --
6026 ---------------------
6028 function Within_Range_Of
6029 (Target_Type : Entity_Id;
6030 Check_Type : Entity_Id) return Boolean
6033 if Target_Type = Check_Type then
6038 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
6039 Thi : constant Node_Id := Type_High_Bound (Target_Type);
6040 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
6041 Chi : constant Node_Id := Type_High_Bound (Check_Type);
6045 or else (Compile_Time_Known_Value (Tlo)
6047 Compile_Time_Known_Value (Clo)
6049 Expr_Value (Clo) >= Expr_Value (Tlo)))
6052 or else (Compile_Time_Known_Value (Thi)
6054 Compile_Time_Known_Value (Chi)
6056 Expr_Value (Chi) <= Expr_Value (Clo)))
6064 end Within_Range_Of;
6066 -- Start of processing for Find_Check
6069 -- Establish default, in case no entry is found
6073 -- Case of expression is simple entity reference
6075 if Is_Entity_Name (Expr) then
6076 Ent := Entity (Expr);
6079 -- Case of expression is entity + known constant
6081 elsif Nkind (Expr) = N_Op_Add
6082 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6083 and then Is_Entity_Name (Left_Opnd (Expr))
6085 Ent := Entity (Left_Opnd (Expr));
6086 Ofs := Expr_Value (Right_Opnd (Expr));
6088 -- Case of expression is entity - known constant
6090 elsif Nkind (Expr) = N_Op_Subtract
6091 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6092 and then Is_Entity_Name (Left_Opnd (Expr))
6094 Ent := Entity (Left_Opnd (Expr));
6095 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
6097 -- Any other expression is not of the right form
6106 -- Come here with expression of appropriate form, check if entity is an
6107 -- appropriate one for our purposes.
6109 if (Ekind (Ent) = E_Variable
6110 or else Is_Constant_Object (Ent))
6111 and then not Is_Library_Level_Entity (Ent)
6119 -- See if there is matching check already
6121 for J in reverse 1 .. Num_Saved_Checks loop
6123 SC : Saved_Check renames Saved_Checks (J);
6125 if SC.Killed = False
6126 and then SC.Entity = Ent
6127 and then SC.Offset = Ofs
6128 and then SC.Check_Type = Check_Type
6129 and then Within_Range_Of (Target_Type, SC.Target_Type)
6137 -- If we fall through entry was not found
6142 ---------------------------------
6143 -- Generate_Discriminant_Check --
6144 ---------------------------------
6146 -- Note: the code for this procedure is derived from the
6147 -- Emit_Discriminant_Check Routine in trans.c.
6149 procedure Generate_Discriminant_Check (N : Node_Id) is
6150 Loc : constant Source_Ptr := Sloc (N);
6151 Pref : constant Node_Id := Prefix (N);
6152 Sel : constant Node_Id := Selector_Name (N);
6154 Orig_Comp : constant Entity_Id :=
6155 Original_Record_Component (Entity (Sel));
6156 -- The original component to be checked
6158 Discr_Fct : constant Entity_Id :=
6159 Discriminant_Checking_Func (Orig_Comp);
6160 -- The discriminant checking function
6163 -- One discriminant to be checked in the type
6165 Real_Discr : Entity_Id;
6166 -- Actual discriminant in the call
6168 Pref_Type : Entity_Id;
6169 -- Type of relevant prefix (ignoring private/access stuff)
6172 -- List of arguments for function call
6175 -- Keep track of the formal corresponding to the actual we build for
6176 -- each discriminant, in order to be able to perform the necessary type
6180 -- Selected component reference for checking function argument
6183 Pref_Type := Etype (Pref);
6185 -- Force evaluation of the prefix, so that it does not get evaluated
6186 -- twice (once for the check, once for the actual reference). Such a
6187 -- double evaluation is always a potential source of inefficiency, and
6188 -- is functionally incorrect in the volatile case, or when the prefix
6189 -- may have side effects. A nonvolatile entity or a component of a
6190 -- nonvolatile entity requires no evaluation.
6192 if Is_Entity_Name (Pref) then
6193 if Treat_As_Volatile (Entity (Pref)) then
6194 Force_Evaluation (Pref, Name_Req => True);
6197 elsif Treat_As_Volatile (Etype (Pref)) then
6198 Force_Evaluation (Pref, Name_Req => True);
6200 elsif Nkind (Pref) = N_Selected_Component
6201 and then Is_Entity_Name (Prefix (Pref))
6206 Force_Evaluation (Pref, Name_Req => True);
6209 -- For a tagged type, use the scope of the original component to
6210 -- obtain the type, because ???
6212 if Is_Tagged_Type (Scope (Orig_Comp)) then
6213 Pref_Type := Scope (Orig_Comp);
6215 -- For an untagged derived type, use the discriminants of the parent
6216 -- which have been renamed in the derivation, possibly by a one-to-many
6217 -- discriminant constraint. For untagged type, initially get the Etype
6221 if Is_Derived_Type (Pref_Type)
6222 and then Number_Discriminants (Pref_Type) /=
6223 Number_Discriminants (Etype (Base_Type (Pref_Type)))
6225 Pref_Type := Etype (Base_Type (Pref_Type));
6229 -- We definitely should have a checking function, This routine should
6230 -- not be called if no discriminant checking function is present.
6232 pragma Assert (Present (Discr_Fct));
6234 -- Create the list of the actual parameters for the call. This list
6235 -- is the list of the discriminant fields of the record expression to
6236 -- be discriminant checked.
6239 Formal := First_Formal (Discr_Fct);
6240 Discr := First_Discriminant (Pref_Type);
6241 while Present (Discr) loop
6243 -- If we have a corresponding discriminant field, and a parent
6244 -- subtype is present, then we want to use the corresponding
6245 -- discriminant since this is the one with the useful value.
6247 if Present (Corresponding_Discriminant (Discr))
6248 and then Ekind (Pref_Type) = E_Record_Type
6249 and then Present (Parent_Subtype (Pref_Type))
6251 Real_Discr := Corresponding_Discriminant (Discr);
6253 Real_Discr := Discr;
6256 -- Construct the reference to the discriminant
6259 Make_Selected_Component (Loc,
6261 Unchecked_Convert_To (Pref_Type,
6262 Duplicate_Subexpr (Pref)),
6263 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
6265 -- Manually analyze and resolve this selected component. We really
6266 -- want it just as it appears above, and do not want the expander
6267 -- playing discriminal games etc with this reference. Then we append
6268 -- the argument to the list we are gathering.
6270 Set_Etype (Scomp, Etype (Real_Discr));
6271 Set_Analyzed (Scomp, True);
6272 Append_To (Args, Convert_To (Etype (Formal), Scomp));
6274 Next_Formal_With_Extras (Formal);
6275 Next_Discriminant (Discr);
6278 -- Now build and insert the call
6281 Make_Raise_Constraint_Error (Loc,
6283 Make_Function_Call (Loc,
6284 Name => New_Occurrence_Of (Discr_Fct, Loc),
6285 Parameter_Associations => Args),
6286 Reason => CE_Discriminant_Check_Failed));
6287 end Generate_Discriminant_Check;
6289 ---------------------------
6290 -- Generate_Index_Checks --
6291 ---------------------------
6293 procedure Generate_Index_Checks (N : Node_Id) is
6295 function Entity_Of_Prefix return Entity_Id;
6296 -- Returns the entity of the prefix of N (or Empty if not found)
6298 ----------------------
6299 -- Entity_Of_Prefix --
6300 ----------------------
6302 function Entity_Of_Prefix return Entity_Id is
6307 while not Is_Entity_Name (P) loop
6308 if not Nkind_In (P, N_Selected_Component,
6309 N_Indexed_Component)
6318 end Entity_Of_Prefix;
6322 Loc : constant Source_Ptr := Sloc (N);
6323 A : constant Node_Id := Prefix (N);
6324 A_Ent : constant Entity_Id := Entity_Of_Prefix;
6327 -- Start of processing for Generate_Index_Checks
6330 -- Ignore call if the prefix is not an array since we have a serious
6331 -- error in the sources. Ignore it also if index checks are suppressed
6332 -- for array object or type.
6334 if not Is_Array_Type (Etype (A))
6335 or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent))
6336 or else Index_Checks_Suppressed (Etype (A))
6340 -- The indexed component we are dealing with contains 'Loop_Entry in its
6341 -- prefix. This case arises when analysis has determined that constructs
6344 -- Prefix'Loop_Entry (Expr)
6345 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6347 -- require rewriting for error detection purposes. A side effect of this
6348 -- action is the generation of index checks that mention 'Loop_Entry.
6349 -- Delay the generation of the check until 'Loop_Entry has been properly
6350 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6352 elsif Nkind (Prefix (N)) = N_Attribute_Reference
6353 and then Attribute_Name (Prefix (N)) = Name_Loop_Entry
6358 -- Generate a raise of constraint error with the appropriate reason and
6359 -- a condition of the form:
6361 -- Base_Type (Sub) not in Array'Range (Subscript)
6363 -- Note that the reason we generate the conversion to the base type here
6364 -- is that we definitely want the range check to take place, even if it
6365 -- looks like the subtype is OK. Optimization considerations that allow
6366 -- us to omit the check have already been taken into account in the
6367 -- setting of the Do_Range_Check flag earlier on.
6369 Sub := First (Expressions (N));
6371 -- Handle string literals
6373 if Ekind (Etype (A)) = E_String_Literal_Subtype then
6374 if Do_Range_Check (Sub) then
6375 Set_Do_Range_Check (Sub, False);
6377 -- For string literals we obtain the bounds of the string from the
6378 -- associated subtype.
6381 Make_Raise_Constraint_Error (Loc,
6385 Convert_To (Base_Type (Etype (Sub)),
6386 Duplicate_Subexpr_Move_Checks (Sub)),
6388 Make_Attribute_Reference (Loc,
6389 Prefix => New_Occurrence_Of (Etype (A), Loc),
6390 Attribute_Name => Name_Range)),
6391 Reason => CE_Index_Check_Failed));
6398 A_Idx : Node_Id := Empty;
6405 A_Idx := First_Index (Etype (A));
6407 while Present (Sub) loop
6408 if Do_Range_Check (Sub) then
6409 Set_Do_Range_Check (Sub, False);
6411 -- Force evaluation except for the case of a simple name of
6412 -- a nonvolatile entity.
6414 if not Is_Entity_Name (Sub)
6415 or else Treat_As_Volatile (Entity (Sub))
6417 Force_Evaluation (Sub);
6420 if Nkind (A_Idx) = N_Range then
6423 elsif Nkind (A_Idx) = N_Identifier
6424 or else Nkind (A_Idx) = N_Expanded_Name
6426 A_Range := Scalar_Range (Entity (A_Idx));
6428 else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication);
6429 A_Range := Range_Expression (Constraint (A_Idx));
6432 -- For array objects with constant bounds we can generate
6433 -- the index check using the bounds of the type of the index
6436 and then Ekind (A_Ent) = E_Variable
6437 and then Is_Constant_Bound (Low_Bound (A_Range))
6438 and then Is_Constant_Bound (High_Bound (A_Range))
6441 Make_Attribute_Reference (Loc,
6443 New_Occurrence_Of (Etype (A_Idx), Loc),
6444 Attribute_Name => Name_Range);
6446 -- For arrays with non-constant bounds we cannot generate
6447 -- the index check using the bounds of the type of the index
6448 -- since it may reference discriminants of some enclosing
6449 -- type. We obtain the bounds directly from the prefix
6456 Num := New_List (Make_Integer_Literal (Loc, Ind));
6460 Make_Attribute_Reference (Loc,
6462 Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
6463 Attribute_Name => Name_Range,
6464 Expressions => Num);
6468 Make_Raise_Constraint_Error (Loc,
6472 Convert_To (Base_Type (Etype (Sub)),
6473 Duplicate_Subexpr_Move_Checks (Sub)),
6474 Right_Opnd => Range_N),
6475 Reason => CE_Index_Check_Failed));
6478 A_Idx := Next_Index (A_Idx);
6484 end Generate_Index_Checks;
6486 --------------------------
6487 -- Generate_Range_Check --
6488 --------------------------
6490 procedure Generate_Range_Check
6492 Target_Type : Entity_Id;
6493 Reason : RT_Exception_Code)
6495 Loc : constant Source_Ptr := Sloc (N);
6496 Source_Type : constant Entity_Id := Etype (N);
6497 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
6498 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
6500 procedure Convert_And_Check_Range;
6501 -- Convert the conversion operand to the target base type and save in
6502 -- a temporary. Then check the converted value against the range of the
6505 -----------------------------
6506 -- Convert_And_Check_Range --
6507 -----------------------------
6509 procedure Convert_And_Check_Range is
6510 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6513 -- We make a temporary to hold the value of the converted value
6514 -- (converted to the base type), and then do the test against this
6515 -- temporary. The conversion itself is replaced by an occurrence of
6516 -- Tnn and followed by the explicit range check. Note that checks
6517 -- are suppressed for this code, since we don't want a recursive
6518 -- range check popping up.
6520 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6521 -- [constraint_error when Tnn not in Target_Type]
6523 Insert_Actions (N, New_List (
6524 Make_Object_Declaration (Loc,
6525 Defining_Identifier => Tnn,
6526 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
6527 Constant_Present => True,
6529 Make_Type_Conversion (Loc,
6530 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
6531 Expression => Duplicate_Subexpr (N))),
6533 Make_Raise_Constraint_Error (Loc,
6536 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6537 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6539 Suppress => All_Checks);
6541 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6543 -- Set the type of N, because the declaration for Tnn might not
6544 -- be analyzed yet, as is the case if N appears within a record
6545 -- declaration, as a discriminant constraint or expression.
6547 Set_Etype (N, Target_Base_Type);
6548 end Convert_And_Check_Range;
6550 -- Start of processing for Generate_Range_Check
6553 -- First special case, if the source type is already within the range
6554 -- of the target type, then no check is needed (probably we should have
6555 -- stopped Do_Range_Check from being set in the first place, but better
6556 -- late than never in preventing junk code and junk flag settings.
6558 if In_Subrange_Of (Source_Type, Target_Type)
6560 -- We do NOT apply this if the source node is a literal, since in this
6561 -- case the literal has already been labeled as having the subtype of
6565 (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal)
6568 and then Ekind (Entity (N)) = E_Enumeration_Literal))
6570 Set_Do_Range_Check (N, False);
6574 -- Here a check is needed. If the expander is not active, or if we are
6575 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6576 -- are done. In both these cases, we just want to see the range check
6577 -- flag set, we do not want to generate the explicit range check code.
6579 if GNATprove_Mode or else not Expander_Active then
6580 Set_Do_Range_Check (N, True);
6584 -- Here we will generate an explicit range check, so we don't want to
6585 -- set the Do_Range check flag, since the range check is taken care of
6586 -- by the code we will generate.
6588 Set_Do_Range_Check (N, False);
6590 -- Force evaluation of the node, so that it does not get evaluated twice
6591 -- (once for the check, once for the actual reference). Such a double
6592 -- evaluation is always a potential source of inefficiency, and is
6593 -- functionally incorrect in the volatile case.
6595 if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then
6596 Force_Evaluation (N);
6599 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6600 -- the same since in this case we can simply do a direct check of the
6601 -- value of N against the bounds of Target_Type.
6603 -- [constraint_error when N not in Target_Type]
6605 -- Note: this is by far the most common case, for example all cases of
6606 -- checks on the RHS of assignments are in this category, but not all
6607 -- cases are like this. Notably conversions can involve two types.
6609 if Source_Base_Type = Target_Base_Type then
6611 -- Insert the explicit range check. Note that we suppress checks for
6612 -- this code, since we don't want a recursive range check popping up.
6615 Make_Raise_Constraint_Error (Loc,
6618 Left_Opnd => Duplicate_Subexpr (N),
6619 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6621 Suppress => All_Checks);
6623 -- Next test for the case where the target type is within the bounds
6624 -- of the base type of the source type, since in this case we can
6625 -- simply convert these bounds to the base type of T to do the test.
6627 -- [constraint_error when N not in
6628 -- Source_Base_Type (Target_Type'First)
6630 -- Source_Base_Type(Target_Type'Last))]
6632 -- The conversions will always work and need no check
6634 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6635 -- of converting from an enumeration value to an integer type, such as
6636 -- occurs for the case of generating a range check on Enum'Val(Exp)
6637 -- (which used to be handled by gigi). This is OK, since the conversion
6638 -- itself does not require a check.
6640 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
6642 -- Insert the explicit range check. Note that we suppress checks for
6643 -- this code, since we don't want a recursive range check popping up.
6645 if Is_Discrete_Type (Source_Base_Type)
6647 Is_Discrete_Type (Target_Base_Type)
6650 Make_Raise_Constraint_Error (Loc,
6653 Left_Opnd => Duplicate_Subexpr (N),
6658 Unchecked_Convert_To (Source_Base_Type,
6659 Make_Attribute_Reference (Loc,
6661 New_Occurrence_Of (Target_Type, Loc),
6662 Attribute_Name => Name_First)),
6665 Unchecked_Convert_To (Source_Base_Type,
6666 Make_Attribute_Reference (Loc,
6668 New_Occurrence_Of (Target_Type, Loc),
6669 Attribute_Name => Name_Last)))),
6671 Suppress => All_Checks);
6673 -- For conversions involving at least one type that is not discrete,
6674 -- first convert to target type and then generate the range check.
6675 -- This avoids problems with values that are close to a bound of the
6676 -- target type that would fail a range check when done in a larger
6677 -- source type before converting but would pass if converted with
6678 -- rounding and then checked (such as in float-to-float conversions).
6681 Convert_And_Check_Range;
6684 -- Note that at this stage we now that the Target_Base_Type is not in
6685 -- the range of the Source_Base_Type (since even the Target_Type itself
6686 -- is not in this range). It could still be the case that Source_Type is
6687 -- in range of the target base type since we have not checked that case.
6689 -- If that is the case, we can freely convert the source to the target,
6690 -- and then test the target result against the bounds.
6692 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
6693 Convert_And_Check_Range;
6695 -- At this stage, we know that we have two scalar types, which are
6696 -- directly convertible, and where neither scalar type has a base
6697 -- range that is in the range of the other scalar type.
6699 -- The only way this can happen is with a signed and unsigned type.
6700 -- So test for these two cases:
6703 -- Case of the source is unsigned and the target is signed
6705 if Is_Unsigned_Type (Source_Base_Type)
6706 and then not Is_Unsigned_Type (Target_Base_Type)
6708 -- If the source is unsigned and the target is signed, then we
6709 -- know that the source is not shorter than the target (otherwise
6710 -- the source base type would be in the target base type range).
6712 -- In other words, the unsigned type is either the same size as
6713 -- the target, or it is larger. It cannot be smaller.
6716 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
6718 -- We only need to check the low bound if the low bound of the
6719 -- target type is non-negative. If the low bound of the target
6720 -- type is negative, then we know that we will fit fine.
6722 -- If the high bound of the target type is negative, then we
6723 -- know we have a constraint error, since we can't possibly
6724 -- have a negative source.
6726 -- With these two checks out of the way, we can do the check
6727 -- using the source type safely
6729 -- This is definitely the most annoying case.
6731 -- [constraint_error
6732 -- when (Target_Type'First >= 0
6734 -- N < Source_Base_Type (Target_Type'First))
6735 -- or else Target_Type'Last < 0
6736 -- or else N > Source_Base_Type (Target_Type'Last)];
6738 -- We turn off all checks since we know that the conversions
6739 -- will work fine, given the guards for negative values.
6742 Make_Raise_Constraint_Error (Loc,
6748 Left_Opnd => Make_Op_Ge (Loc,
6750 Make_Attribute_Reference (Loc,
6752 New_Occurrence_Of (Target_Type, Loc),
6753 Attribute_Name => Name_First),
6754 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6758 Left_Opnd => Duplicate_Subexpr (N),
6760 Convert_To (Source_Base_Type,
6761 Make_Attribute_Reference (Loc,
6763 New_Occurrence_Of (Target_Type, Loc),
6764 Attribute_Name => Name_First)))),
6769 Make_Attribute_Reference (Loc,
6770 Prefix => New_Occurrence_Of (Target_Type, Loc),
6771 Attribute_Name => Name_Last),
6772 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
6776 Left_Opnd => Duplicate_Subexpr (N),
6778 Convert_To (Source_Base_Type,
6779 Make_Attribute_Reference (Loc,
6780 Prefix => New_Occurrence_Of (Target_Type, Loc),
6781 Attribute_Name => Name_Last)))),
6784 Suppress => All_Checks);
6786 -- Only remaining possibility is that the source is signed and
6787 -- the target is unsigned.
6790 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
6791 and then Is_Unsigned_Type (Target_Base_Type));
6793 -- If the source is signed and the target is unsigned, then we
6794 -- know that the target is not shorter than the source (otherwise
6795 -- the target base type would be in the source base type range).
6797 -- In other words, the unsigned type is either the same size as
6798 -- the target, or it is larger. It cannot be smaller.
6800 -- Clearly we have an error if the source value is negative since
6801 -- no unsigned type can have negative values. If the source type
6802 -- is non-negative, then the check can be done using the target
6805 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6807 -- [constraint_error
6808 -- when N < 0 or else Tnn not in Target_Type];
6810 -- We turn off all checks for the conversion of N to the target
6811 -- base type, since we generate the explicit check to ensure that
6812 -- the value is non-negative
6815 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6818 Insert_Actions (N, New_List (
6819 Make_Object_Declaration (Loc,
6820 Defining_Identifier => Tnn,
6821 Object_Definition =>
6822 New_Occurrence_Of (Target_Base_Type, Loc),
6823 Constant_Present => True,
6825 Make_Unchecked_Type_Conversion (Loc,
6827 New_Occurrence_Of (Target_Base_Type, Loc),
6828 Expression => Duplicate_Subexpr (N))),
6830 Make_Raise_Constraint_Error (Loc,
6835 Left_Opnd => Duplicate_Subexpr (N),
6836 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6840 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6842 New_Occurrence_Of (Target_Type, Loc))),
6845 Suppress => All_Checks);
6847 -- Set the Etype explicitly, because Insert_Actions may have
6848 -- placed the declaration in the freeze list for an enclosing
6849 -- construct, and thus it is not analyzed yet.
6851 Set_Etype (Tnn, Target_Base_Type);
6852 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6856 end Generate_Range_Check;
6862 function Get_Check_Id (N : Name_Id) return Check_Id is
6864 -- For standard check name, we can do a direct computation
6866 if N in First_Check_Name .. Last_Check_Name then
6867 return Check_Id (N - (First_Check_Name - 1));
6869 -- For non-standard names added by pragma Check_Name, search table
6872 for J in All_Checks + 1 .. Check_Names.Last loop
6873 if Check_Names.Table (J) = N then
6879 -- No matching name found
6884 ---------------------
6885 -- Get_Discriminal --
6886 ---------------------
6888 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
6889 Loc : constant Source_Ptr := Sloc (E);
6894 -- The bound can be a bona fide parameter of a protected operation,
6895 -- rather than a prival encoded as an in-parameter.
6897 if No (Discriminal_Link (Entity (Bound))) then
6901 -- Climb the scope stack looking for an enclosing protected type. If
6902 -- we run out of scopes, return the bound itself.
6905 while Present (Sc) loop
6906 if Sc = Standard_Standard then
6908 elsif Ekind (Sc) = E_Protected_Type then
6915 D := First_Discriminant (Sc);
6916 while Present (D) loop
6917 if Chars (D) = Chars (Bound) then
6918 return New_Occurrence_Of (Discriminal (D), Loc);
6921 Next_Discriminant (D);
6925 end Get_Discriminal;
6927 ----------------------
6928 -- Get_Range_Checks --
6929 ----------------------
6931 function Get_Range_Checks
6933 Target_Typ : Entity_Id;
6934 Source_Typ : Entity_Id := Empty;
6935 Warn_Node : Node_Id := Empty) return Check_Result
6939 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
6940 end Get_Range_Checks;
6946 function Guard_Access
6949 Ck_Node : Node_Id) return Node_Id
6952 if Nkind (Cond) = N_Or_Else then
6953 Set_Paren_Count (Cond, 1);
6956 if Nkind (Ck_Node) = N_Allocator then
6964 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
6965 Right_Opnd => Make_Null (Loc)),
6966 Right_Opnd => Cond);
6970 -----------------------------
6971 -- Index_Checks_Suppressed --
6972 -----------------------------
6974 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
6976 if Present (E) and then Checks_May_Be_Suppressed (E) then
6977 return Is_Check_Suppressed (E, Index_Check);
6979 return Scope_Suppress.Suppress (Index_Check);
6981 end Index_Checks_Suppressed;
6987 procedure Initialize is
6989 for J in Determine_Range_Cache_N'Range loop
6990 Determine_Range_Cache_N (J) := Empty;
6995 for J in Int range 1 .. All_Checks loop
6996 Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
7000 -------------------------
7001 -- Insert_Range_Checks --
7002 -------------------------
7004 procedure Insert_Range_Checks
7005 (Checks : Check_Result;
7007 Suppress_Typ : Entity_Id;
7008 Static_Sloc : Source_Ptr := No_Location;
7009 Flag_Node : Node_Id := Empty;
7010 Do_Before : Boolean := False)
7012 Internal_Flag_Node : Node_Id := Flag_Node;
7013 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
7015 Check_Node : Node_Id;
7016 Checks_On : constant Boolean :=
7017 (not Index_Checks_Suppressed (Suppress_Typ))
7018 or else (not Range_Checks_Suppressed (Suppress_Typ));
7021 -- For now we just return if Checks_On is false, however this should be
7022 -- enhanced to check for an always True value in the condition and to
7023 -- generate a compilation warning???
7025 if not Expander_Active or not Checks_On then
7029 if Static_Sloc = No_Location then
7030 Internal_Static_Sloc := Sloc (Node);
7033 if No (Flag_Node) then
7034 Internal_Flag_Node := Node;
7037 for J in 1 .. 2 loop
7038 exit when No (Checks (J));
7040 if Nkind (Checks (J)) = N_Raise_Constraint_Error
7041 and then Present (Condition (Checks (J)))
7043 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
7044 Check_Node := Checks (J);
7045 Mark_Rewrite_Insertion (Check_Node);
7048 Insert_Before_And_Analyze (Node, Check_Node);
7050 Insert_After_And_Analyze (Node, Check_Node);
7053 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
7058 Make_Raise_Constraint_Error (Internal_Static_Sloc,
7059 Reason => CE_Range_Check_Failed);
7060 Mark_Rewrite_Insertion (Check_Node);
7063 Insert_Before_And_Analyze (Node, Check_Node);
7065 Insert_After_And_Analyze (Node, Check_Node);
7069 end Insert_Range_Checks;
7071 ------------------------
7072 -- Insert_Valid_Check --
7073 ------------------------
7075 procedure Insert_Valid_Check
7077 Related_Id : Entity_Id := Empty;
7078 Is_Low_Bound : Boolean := False;
7079 Is_High_Bound : Boolean := False)
7081 Loc : constant Source_Ptr := Sloc (Expr);
7082 Typ : constant Entity_Id := Etype (Expr);
7086 -- Do not insert if checks off, or if not checking validity or if
7087 -- expression is known to be valid.
7089 if not Validity_Checks_On
7090 or else Range_Or_Validity_Checks_Suppressed (Expr)
7091 or else Expr_Known_Valid (Expr)
7096 -- Do not insert checks within a predicate function. This will arise
7097 -- if the current unit and the predicate function are being compiled
7098 -- with validity checks enabled.
7100 if Present (Predicate_Function (Typ))
7101 and then Current_Scope = Predicate_Function (Typ)
7106 -- If the expression is a packed component of a modular type of the
7107 -- right size, the data is always valid.
7109 if Nkind (Expr) = N_Selected_Component
7110 and then Present (Component_Clause (Entity (Selector_Name (Expr))))
7111 and then Is_Modular_Integer_Type (Typ)
7112 and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr)))
7117 -- If we have a checked conversion, then validity check applies to
7118 -- the expression inside the conversion, not the result, since if
7119 -- the expression inside is valid, then so is the conversion result.
7122 while Nkind (Exp) = N_Type_Conversion loop
7123 Exp := Expression (Exp);
7126 -- We are about to insert the validity check for Exp. We save and
7127 -- reset the Do_Range_Check flag over this validity check, and then
7128 -- put it back for the final original reference (Exp may be rewritten).
7131 DRC : constant Boolean := Do_Range_Check (Exp);
7136 Set_Do_Range_Check (Exp, False);
7138 -- Force evaluation to avoid multiple reads for atomic/volatile
7140 -- Note: we set Name_Req to False. We used to set it to True, with
7141 -- the thinking that a name is required as the prefix of the 'Valid
7142 -- call, but in fact the check that the prefix of an attribute is
7143 -- a name is in the parser, and we just don't require it here.
7144 -- Moreover, when we set Name_Req to True, that interfered with the
7145 -- checking for Volatile, since we couldn't just capture the value.
7147 if Is_Entity_Name (Exp)
7148 and then Is_Volatile (Entity (Exp))
7150 -- Same reasoning as above for setting Name_Req to False
7152 Force_Evaluation (Exp, Name_Req => False);
7155 -- Build the prefix for the 'Valid call
7158 Duplicate_Subexpr_No_Checks
7161 Related_Id => Related_Id,
7162 Is_Low_Bound => Is_Low_Bound,
7163 Is_High_Bound => Is_High_Bound);
7165 -- A rather specialized test. If PV is an analyzed expression which
7166 -- is an indexed component of a packed array that has not been
7167 -- properly expanded, turn off its Analyzed flag to make sure it
7168 -- gets properly reexpanded. If the prefix is an access value,
7169 -- the dereference will be added later.
7171 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7172 -- an analyze with the old parent pointer. This may point e.g. to
7173 -- a subprogram call, which deactivates this expansion.
7176 and then Nkind (PV) = N_Indexed_Component
7177 and then Is_Array_Type (Etype (Prefix (PV)))
7178 and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV))))
7180 Set_Analyzed (PV, False);
7183 -- Build the raise CE node to check for validity. We build a type
7184 -- qualification for the prefix, since it may not be of the form of
7185 -- a name, and we don't care in this context!
7188 Make_Raise_Constraint_Error (Loc,
7192 Make_Attribute_Reference (Loc,
7194 Attribute_Name => Name_Valid)),
7195 Reason => CE_Invalid_Data);
7197 -- Insert the validity check. Note that we do this with validity
7198 -- checks turned off, to avoid recursion, we do not want validity
7199 -- checks on the validity checking code itself.
7201 Insert_Action (Expr, CE, Suppress => Validity_Check);
7203 -- If the expression is a reference to an element of a bit-packed
7204 -- array, then it is rewritten as a renaming declaration. If the
7205 -- expression is an actual in a call, it has not been expanded,
7206 -- waiting for the proper point at which to do it. The same happens
7207 -- with renamings, so that we have to force the expansion now. This
7208 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7211 if Is_Entity_Name (Exp)
7212 and then Nkind (Parent (Entity (Exp))) =
7213 N_Object_Renaming_Declaration
7216 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
7218 if Nkind (Old_Exp) = N_Indexed_Component
7219 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
7221 Expand_Packed_Element_Reference (Old_Exp);
7226 -- Put back the Do_Range_Check flag on the resulting (possibly
7227 -- rewritten) expression.
7229 -- Note: it might be thought that a validity check is not required
7230 -- when a range check is present, but that's not the case, because
7231 -- the back end is allowed to assume for the range check that the
7232 -- operand is within its declared range (an assumption that validity
7233 -- checking is all about NOT assuming).
7235 -- Note: no need to worry about Possible_Local_Raise here, it will
7236 -- already have been called if original node has Do_Range_Check set.
7238 Set_Do_Range_Check (Exp, DRC);
7240 end Insert_Valid_Check;
7242 -------------------------------------
7243 -- Is_Signed_Integer_Arithmetic_Op --
7244 -------------------------------------
7246 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
7249 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
7250 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
7251 N_Op_Rem | N_Op_Subtract =>
7252 return Is_Signed_Integer_Type (Etype (N));
7254 when N_If_Expression | N_Case_Expression =>
7255 return Is_Signed_Integer_Type (Etype (N));
7260 end Is_Signed_Integer_Arithmetic_Op;
7262 ----------------------------------
7263 -- Install_Null_Excluding_Check --
7264 ----------------------------------
7266 procedure Install_Null_Excluding_Check (N : Node_Id) is
7267 Loc : constant Source_Ptr := Sloc (Parent (N));
7268 Typ : constant Entity_Id := Etype (N);
7270 function Safe_To_Capture_In_Parameter_Value return Boolean;
7271 -- Determines if it is safe to capture Known_Non_Null status for an
7272 -- the entity referenced by node N. The caller ensures that N is indeed
7273 -- an entity name. It is safe to capture the non-null status for an IN
7274 -- parameter when the reference occurs within a declaration that is sure
7275 -- to be executed as part of the declarative region.
7277 procedure Mark_Non_Null;
7278 -- After installation of check, if the node in question is an entity
7279 -- name, then mark this entity as non-null if possible.
7281 function Safe_To_Capture_In_Parameter_Value return Boolean is
7282 E : constant Entity_Id := Entity (N);
7283 S : constant Entity_Id := Current_Scope;
7287 if Ekind (E) /= E_In_Parameter then
7291 -- Two initial context checks. We must be inside a subprogram body
7292 -- with declarations and reference must not appear in nested scopes.
7294 if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure)
7295 or else Scope (E) /= S
7300 S_Par := Parent (Parent (S));
7302 if Nkind (S_Par) /= N_Subprogram_Body
7303 or else No (Declarations (S_Par))
7313 -- Retrieve the declaration node of N (if any). Note that N
7314 -- may be a part of a complex initialization expression.
7318 while Present (P) loop
7320 -- If we have a short circuit form, and we are within the right
7321 -- hand expression, we return false, since the right hand side
7322 -- is not guaranteed to be elaborated.
7324 if Nkind (P) in N_Short_Circuit
7325 and then N = Right_Opnd (P)
7330 -- Similarly, if we are in an if expression and not part of the
7331 -- condition, then we return False, since neither the THEN or
7332 -- ELSE dependent expressions will always be elaborated.
7334 if Nkind (P) = N_If_Expression
7335 and then N /= First (Expressions (P))
7340 -- If within a case expression, and not part of the expression,
7341 -- then return False, since a particular dependent expression
7342 -- may not always be elaborated
7344 if Nkind (P) = N_Case_Expression
7345 and then N /= Expression (P)
7350 -- While traversing the parent chain, if node N belongs to a
7351 -- statement, then it may never appear in a declarative region.
7353 if Nkind (P) in N_Statement_Other_Than_Procedure_Call
7354 or else Nkind (P) = N_Procedure_Call_Statement
7359 -- If we are at a declaration, record it and exit
7361 if Nkind (P) in N_Declaration
7362 and then Nkind (P) not in N_Subprogram_Specification
7375 return List_Containing (N_Decl) = Declarations (S_Par);
7377 end Safe_To_Capture_In_Parameter_Value;
7383 procedure Mark_Non_Null is
7385 -- Only case of interest is if node N is an entity name
7387 if Is_Entity_Name (N) then
7389 -- For sure, we want to clear an indication that this is known to
7390 -- be null, since if we get past this check, it definitely is not.
7392 Set_Is_Known_Null (Entity (N), False);
7394 -- We can mark the entity as known to be non-null if either it is
7395 -- safe to capture the value, or in the case of an IN parameter,
7396 -- which is a constant, if the check we just installed is in the
7397 -- declarative region of the subprogram body. In this latter case,
7398 -- a check is decisive for the rest of the body if the expression
7399 -- is sure to be elaborated, since we know we have to elaborate
7400 -- all declarations before executing the body.
7402 -- Couldn't this always be part of Safe_To_Capture_Value ???
7404 if Safe_To_Capture_Value (N, Entity (N))
7405 or else Safe_To_Capture_In_Parameter_Value
7407 Set_Is_Known_Non_Null (Entity (N));
7412 -- Start of processing for Install_Null_Excluding_Check
7415 pragma Assert (Is_Access_Type (Typ));
7417 -- No check inside a generic, check will be emitted in instance
7419 if Inside_A_Generic then
7423 -- No check needed if known to be non-null
7425 if Known_Non_Null (N) then
7429 -- If known to be null, here is where we generate a compile time check
7431 if Known_Null (N) then
7433 -- Avoid generating warning message inside init procs. In SPARK mode
7434 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7435 -- since it will be turned into an error in any case.
7437 if (not Inside_Init_Proc or else SPARK_Mode = On)
7439 -- Do not emit the warning within a conditional expression,
7440 -- where the expression might not be evaluated, and the warning
7441 -- appear as extraneous noise.
7443 and then not Within_Case_Or_If_Expression (N)
7445 Apply_Compile_Time_Constraint_Error
7446 (N, "null value not allowed here??", CE_Access_Check_Failed);
7448 -- Remaining cases, where we silently insert the raise
7452 Make_Raise_Constraint_Error (Loc,
7453 Reason => CE_Access_Check_Failed));
7460 -- If entity is never assigned, for sure a warning is appropriate
7462 if Is_Entity_Name (N) then
7463 Check_Unset_Reference (N);
7466 -- No check needed if checks are suppressed on the range. Note that we
7467 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7468 -- so, since the program is erroneous, but we don't like to casually
7469 -- propagate such conclusions from erroneosity).
7471 if Access_Checks_Suppressed (Typ) then
7475 -- No check needed for access to concurrent record types generated by
7476 -- the expander. This is not just an optimization (though it does indeed
7477 -- remove junk checks). It also avoids generation of junk warnings.
7479 if Nkind (N) in N_Has_Chars
7480 and then Chars (N) = Name_uObject
7481 and then Is_Concurrent_Record_Type
7482 (Directly_Designated_Type (Etype (N)))
7487 -- No check needed in interface thunks since the runtime check is
7488 -- already performed at the caller side.
7490 if Is_Thunk (Current_Scope) then
7494 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7495 -- the expander within exception handlers, since we know that the value
7496 -- can never be null.
7498 -- Is this really the right way to do this? Normally we generate such
7499 -- code in the expander with checks off, and that's how we suppress this
7500 -- kind of junk check ???
7502 if Nkind (N) = N_Function_Call
7503 and then Nkind (Name (N)) = N_Explicit_Dereference
7504 and then Nkind (Prefix (Name (N))) = N_Identifier
7505 and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
7510 -- Otherwise install access check
7513 Make_Raise_Constraint_Error (Loc,
7516 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
7517 Right_Opnd => Make_Null (Loc)),
7518 Reason => CE_Access_Check_Failed));
7521 end Install_Null_Excluding_Check;
7523 --------------------------
7524 -- Install_Static_Check --
7525 --------------------------
7527 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
7528 Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
7529 Typ : constant Entity_Id := Etype (R_Cno);
7533 Make_Raise_Constraint_Error (Loc,
7534 Reason => CE_Range_Check_Failed));
7535 Set_Analyzed (R_Cno);
7536 Set_Etype (R_Cno, Typ);
7537 Set_Raises_Constraint_Error (R_Cno);
7538 Set_Is_Static_Expression (R_Cno, Stat);
7540 -- Now deal with possible local raise handling
7542 Possible_Local_Raise (R_Cno, Standard_Constraint_Error);
7543 end Install_Static_Check;
7545 -------------------------
7546 -- Is_Check_Suppressed --
7547 -------------------------
7549 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
7550 Ptr : Suppress_Stack_Entry_Ptr;
7553 -- First search the local entity suppress stack. We search this from the
7554 -- top of the stack down so that we get the innermost entry that applies
7555 -- to this case if there are nested entries.
7557 Ptr := Local_Suppress_Stack_Top;
7558 while Ptr /= null loop
7559 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7560 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7562 return Ptr.Suppress;
7568 -- Now search the global entity suppress table for a matching entry.
7569 -- We also search this from the top down so that if there are multiple
7570 -- pragmas for the same entity, the last one applies (not clear what
7571 -- or whether the RM specifies this handling, but it seems reasonable).
7573 Ptr := Global_Suppress_Stack_Top;
7574 while Ptr /= null loop
7575 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7576 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7578 return Ptr.Suppress;
7584 -- If we did not find a matching entry, then use the normal scope
7585 -- suppress value after all (actually this will be the global setting
7586 -- since it clearly was not overridden at any point). For a predefined
7587 -- check, we test the specific flag. For a user defined check, we check
7588 -- the All_Checks flag. The Overflow flag requires special handling to
7589 -- deal with the General vs Assertion case
7591 if C = Overflow_Check then
7592 return Overflow_Checks_Suppressed (Empty);
7593 elsif C in Predefined_Check_Id then
7594 return Scope_Suppress.Suppress (C);
7596 return Scope_Suppress.Suppress (All_Checks);
7598 end Is_Check_Suppressed;
7600 ---------------------
7601 -- Kill_All_Checks --
7602 ---------------------
7604 procedure Kill_All_Checks is
7606 if Debug_Flag_CC then
7607 w ("Kill_All_Checks");
7610 -- We reset the number of saved checks to zero, and also modify all
7611 -- stack entries for statement ranges to indicate that the number of
7612 -- checks at each level is now zero.
7614 Num_Saved_Checks := 0;
7616 -- Note: the Int'Min here avoids any possibility of J being out of
7617 -- range when called from e.g. Conditional_Statements_Begin.
7619 for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
7620 Saved_Checks_Stack (J) := 0;
7622 end Kill_All_Checks;
7628 procedure Kill_Checks (V : Entity_Id) is
7630 if Debug_Flag_CC then
7631 w ("Kill_Checks for entity", Int (V));
7634 for J in 1 .. Num_Saved_Checks loop
7635 if Saved_Checks (J).Entity = V then
7636 if Debug_Flag_CC then
7637 w (" Checks killed for saved check ", J);
7640 Saved_Checks (J).Killed := True;
7645 ------------------------------
7646 -- Length_Checks_Suppressed --
7647 ------------------------------
7649 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
7651 if Present (E) and then Checks_May_Be_Suppressed (E) then
7652 return Is_Check_Suppressed (E, Length_Check);
7654 return Scope_Suppress.Suppress (Length_Check);
7656 end Length_Checks_Suppressed;
7658 -----------------------
7659 -- Make_Bignum_Block --
7660 -----------------------
7662 function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is
7663 M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM);
7666 Make_Block_Statement (Loc,
7668 New_List (Build_SS_Mark_Call (Loc, M)),
7669 Handled_Statement_Sequence =>
7670 Make_Handled_Sequence_Of_Statements (Loc,
7671 Statements => New_List (Build_SS_Release_Call (Loc, M))));
7672 end Make_Bignum_Block;
7674 ----------------------------------
7675 -- Minimize_Eliminate_Overflows --
7676 ----------------------------------
7678 -- This is a recursive routine that is called at the top of an expression
7679 -- tree to properly process overflow checking for a whole subtree by making
7680 -- recursive calls to process operands. This processing may involve the use
7681 -- of bignum or long long integer arithmetic, which will change the types
7682 -- of operands and results. That's why we can't do this bottom up (since
7683 -- it would interfere with semantic analysis).
7685 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
7686 -- the operator expansion routines, as well as the expansion routines for
7687 -- if/case expression, do nothing (for the moment) except call the routine
7688 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
7689 -- routine does nothing for non top-level nodes, so at the point where the
7690 -- call is made for the top level node, the entire expression subtree has
7691 -- not been expanded, or processed for overflow. All that has to happen as
7692 -- a result of the top level call to this routine.
7694 -- As noted above, the overflow processing works by making recursive calls
7695 -- for the operands, and figuring out what to do, based on the processing
7696 -- of these operands (e.g. if a bignum operand appears, the parent op has
7697 -- to be done in bignum mode), and the determined ranges of the operands.
7699 -- After possible rewriting of a constituent subexpression node, a call is
7700 -- made to either reexpand the node (if nothing has changed) or reanalyze
7701 -- the node (if it has been modified by the overflow check processing). The
7702 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
7703 -- a recursive call into the whole overflow apparatus, an important rule
7704 -- for this call is that the overflow handling mode must be temporarily set
7707 procedure Minimize_Eliminate_Overflows
7711 Top_Level : Boolean)
7713 Rtyp : constant Entity_Id := Etype (N);
7714 pragma Assert (Is_Signed_Integer_Type (Rtyp));
7715 -- Result type, must be a signed integer type
7717 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
7718 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
7720 Loc : constant Source_Ptr := Sloc (N);
7723 -- Ranges of values for right operand (operator case)
7726 -- Ranges of values for left operand (operator case)
7728 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
7729 -- Operands and results are of this type when we convert
7731 LLLo : constant Uint := Intval (Type_Low_Bound (LLIB));
7732 LLHi : constant Uint := Intval (Type_High_Bound (LLIB));
7733 -- Bounds of Long_Long_Integer
7735 Binary : constant Boolean := Nkind (N) in N_Binary_Op;
7736 -- Indicates binary operator case
7739 -- Used in call to Determine_Range
7741 Bignum_Operands : Boolean;
7742 -- Set True if one or more operands is already of type Bignum, meaning
7743 -- that for sure (regardless of Top_Level setting) we are committed to
7744 -- doing the operation in Bignum mode (or in the case of a case or if
7745 -- expression, converting all the dependent expressions to Bignum).
7747 Long_Long_Integer_Operands : Boolean;
7748 -- Set True if one or more operands is already of type Long_Long_Integer
7749 -- which means that if the result is known to be in the result type
7750 -- range, then we must convert such operands back to the result type.
7752 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False);
7753 -- This is called when we have modified the node and we therefore need
7754 -- to reanalyze it. It is important that we reset the mode to STRICT for
7755 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7756 -- we would reenter this routine recursively which would not be good.
7757 -- The argument Suppress is set True if we also want to suppress
7758 -- overflow checking for the reexpansion (this is set when we know
7759 -- overflow is not possible). Typ is the type for the reanalysis.
7761 procedure Reexpand (Suppress : Boolean := False);
7762 -- This is like Reanalyze, but does not do the Analyze step, it only
7763 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7764 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7765 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7766 -- Note that skipping reanalysis is not just an optimization, testing
7767 -- has showed up several complex cases in which reanalyzing an already
7768 -- analyzed node causes incorrect behavior.
7770 function In_Result_Range return Boolean;
7771 -- Returns True iff Lo .. Hi are within range of the result type
7773 procedure Max (A : in out Uint; B : Uint);
7774 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7776 procedure Min (A : in out Uint; B : Uint);
7777 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7779 ---------------------
7780 -- In_Result_Range --
7781 ---------------------
7783 function In_Result_Range return Boolean is
7785 if Lo = No_Uint or else Hi = No_Uint then
7788 elsif Is_OK_Static_Subtype (Etype (N)) then
7789 return Lo >= Expr_Value (Type_Low_Bound (Rtyp))
7791 Hi <= Expr_Value (Type_High_Bound (Rtyp));
7794 return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp)))
7796 Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp)));
7798 end In_Result_Range;
7804 procedure Max (A : in out Uint; B : Uint) is
7806 if A = No_Uint or else B > A then
7815 procedure Min (A : in out Uint; B : Uint) is
7817 if A = No_Uint or else B < A then
7826 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is
7827 Svg : constant Overflow_Mode_Type :=
7828 Scope_Suppress.Overflow_Mode_General;
7829 Sva : constant Overflow_Mode_Type :=
7830 Scope_Suppress.Overflow_Mode_Assertions;
7831 Svo : constant Boolean :=
7832 Scope_Suppress.Suppress (Overflow_Check);
7835 Scope_Suppress.Overflow_Mode_General := Strict;
7836 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7839 Scope_Suppress.Suppress (Overflow_Check) := True;
7842 Analyze_And_Resolve (N, Typ);
7844 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7845 Scope_Suppress.Overflow_Mode_General := Svg;
7846 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7853 procedure Reexpand (Suppress : Boolean := False) is
7854 Svg : constant Overflow_Mode_Type :=
7855 Scope_Suppress.Overflow_Mode_General;
7856 Sva : constant Overflow_Mode_Type :=
7857 Scope_Suppress.Overflow_Mode_Assertions;
7858 Svo : constant Boolean :=
7859 Scope_Suppress.Suppress (Overflow_Check);
7862 Scope_Suppress.Overflow_Mode_General := Strict;
7863 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7864 Set_Analyzed (N, False);
7867 Scope_Suppress.Suppress (Overflow_Check) := True;
7872 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7873 Scope_Suppress.Overflow_Mode_General := Svg;
7874 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7877 -- Start of processing for Minimize_Eliminate_Overflows
7880 -- Case where we do not have a signed integer arithmetic operation
7882 if not Is_Signed_Integer_Arithmetic_Op (N) then
7884 -- Use the normal Determine_Range routine to get the range. We
7885 -- don't require operands to be valid, invalid values may result in
7886 -- rubbish results where the result has not been properly checked for
7887 -- overflow, that's fine.
7889 Determine_Range (N, OK, Lo, Hi, Assume_Valid => False);
7891 -- If Determine_Range did not work (can this in fact happen? Not
7892 -- clear but might as well protect), use type bounds.
7895 Lo := Intval (Type_Low_Bound (Base_Type (Etype (N))));
7896 Hi := Intval (Type_High_Bound (Base_Type (Etype (N))));
7899 -- If we don't have a binary operator, all we have to do is to set
7900 -- the Hi/Lo range, so we are done.
7904 -- Processing for if expression
7906 elsif Nkind (N) = N_If_Expression then
7908 Then_DE : constant Node_Id := Next (First (Expressions (N)));
7909 Else_DE : constant Node_Id := Next (Then_DE);
7912 Bignum_Operands := False;
7914 Minimize_Eliminate_Overflows
7915 (Then_DE, Lo, Hi, Top_Level => False);
7917 if Lo = No_Uint then
7918 Bignum_Operands := True;
7921 Minimize_Eliminate_Overflows
7922 (Else_DE, Rlo, Rhi, Top_Level => False);
7924 if Rlo = No_Uint then
7925 Bignum_Operands := True;
7927 Long_Long_Integer_Operands :=
7928 Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB;
7934 -- If at least one of our operands is now Bignum, we must rebuild
7935 -- the if expression to use Bignum operands. We will analyze the
7936 -- rebuilt if expression with overflow checks off, since once we
7937 -- are in bignum mode, we are all done with overflow checks.
7939 if Bignum_Operands then
7941 Make_If_Expression (Loc,
7942 Expressions => New_List (
7943 Remove_Head (Expressions (N)),
7944 Convert_To_Bignum (Then_DE),
7945 Convert_To_Bignum (Else_DE)),
7946 Is_Elsif => Is_Elsif (N)));
7948 Reanalyze (RTE (RE_Bignum), Suppress => True);
7950 -- If we have no Long_Long_Integer operands, then we are in result
7951 -- range, since it means that none of our operands felt the need
7952 -- to worry about overflow (otherwise it would have already been
7953 -- converted to long long integer or bignum). We reexpand to
7954 -- complete the expansion of the if expression (but we do not
7955 -- need to reanalyze).
7957 elsif not Long_Long_Integer_Operands then
7958 Set_Do_Overflow_Check (N, False);
7961 -- Otherwise convert us to long long integer mode. Note that we
7962 -- don't need any further overflow checking at this level.
7965 Convert_To_And_Rewrite (LLIB, Then_DE);
7966 Convert_To_And_Rewrite (LLIB, Else_DE);
7967 Set_Etype (N, LLIB);
7969 -- Now reanalyze with overflow checks off
7971 Set_Do_Overflow_Check (N, False);
7972 Reanalyze (LLIB, Suppress => True);
7978 -- Here for case expression
7980 elsif Nkind (N) = N_Case_Expression then
7981 Bignum_Operands := False;
7982 Long_Long_Integer_Operands := False;
7988 -- Loop through expressions applying recursive call
7990 Alt := First (Alternatives (N));
7991 while Present (Alt) loop
7993 Aexp : constant Node_Id := Expression (Alt);
7996 Minimize_Eliminate_Overflows
7997 (Aexp, Lo, Hi, Top_Level => False);
7999 if Lo = No_Uint then
8000 Bignum_Operands := True;
8001 elsif Etype (Aexp) = LLIB then
8002 Long_Long_Integer_Operands := True;
8009 -- If we have no bignum or long long integer operands, it means
8010 -- that none of our dependent expressions could raise overflow.
8011 -- In this case, we simply return with no changes except for
8012 -- resetting the overflow flag, since we are done with overflow
8013 -- checks for this node. We will reexpand to get the needed
8014 -- expansion for the case expression, but we do not need to
8015 -- reanalyze, since nothing has changed.
8017 if not (Bignum_Operands or Long_Long_Integer_Operands) then
8018 Set_Do_Overflow_Check (N, False);
8019 Reexpand (Suppress => True);
8021 -- Otherwise we are going to rebuild the case expression using
8022 -- either bignum or long long integer operands throughout.
8031 New_Alts := New_List;
8032 Alt := First (Alternatives (N));
8033 while Present (Alt) loop
8034 if Bignum_Operands then
8035 New_Exp := Convert_To_Bignum (Expression (Alt));
8036 Rtype := RTE (RE_Bignum);
8038 New_Exp := Convert_To (LLIB, Expression (Alt));
8042 Append_To (New_Alts,
8043 Make_Case_Expression_Alternative (Sloc (Alt),
8045 Discrete_Choices => Discrete_Choices (Alt),
8046 Expression => New_Exp));
8052 Make_Case_Expression (Loc,
8053 Expression => Expression (N),
8054 Alternatives => New_Alts));
8056 Reanalyze (Rtype, Suppress => True);
8064 -- If we have an arithmetic operator we make recursive calls on the
8065 -- operands to get the ranges (and to properly process the subtree
8066 -- that lies below us).
8068 Minimize_Eliminate_Overflows
8069 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
8072 Minimize_Eliminate_Overflows
8073 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
8076 -- Record if we have Long_Long_Integer operands
8078 Long_Long_Integer_Operands :=
8079 Etype (Right_Opnd (N)) = LLIB
8080 or else (Binary and then Etype (Left_Opnd (N)) = LLIB);
8082 -- If either operand is a bignum, then result will be a bignum and we
8083 -- don't need to do any range analysis. As previously discussed we could
8084 -- do range analysis in such cases, but it could mean working with giant
8085 -- numbers at compile time for very little gain (the number of cases
8086 -- in which we could slip back from bignum mode is small).
8088 if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
8091 Bignum_Operands := True;
8093 -- Otherwise compute result range
8096 Bignum_Operands := False;
8104 Hi := UI_Max (abs Rlo, abs Rhi);
8116 -- If the right operand can only be zero, set 0..0
8118 if Rlo = 0 and then Rhi = 0 then
8122 -- Possible bounds of division must come from dividing end
8123 -- values of the input ranges (four possibilities), provided
8124 -- zero is not included in the possible values of the right
8127 -- Otherwise, we just consider two intervals of values for
8128 -- the right operand: the interval of negative values (up to
8129 -- -1) and the interval of positive values (starting at 1).
8130 -- Since division by 1 is the identity, and division by -1
8131 -- is negation, we get all possible bounds of division in that
8132 -- case by considering:
8133 -- - all values from the division of end values of input
8135 -- - the end values of the left operand;
8136 -- - the negation of the end values of the left operand.
8140 Mrk : constant Uintp.Save_Mark := Mark;
8141 -- Mark so we can release the RR and Ev values
8149 -- Discard extreme values of zero for the divisor, since
8150 -- they will simply result in an exception in any case.
8158 -- Compute possible bounds coming from dividing end
8159 -- values of the input ranges.
8166 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8167 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8169 -- If the right operand can be both negative or positive,
8170 -- include the end values of the left operand in the
8171 -- extreme values, as well as their negation.
8173 if Rlo < 0 and then Rhi > 0 then
8180 UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
8182 UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
8185 -- Release the RR and Ev values
8187 Release_And_Save (Mrk, Lo, Hi);
8195 -- Discard negative values for the exponent, since they will
8196 -- simply result in an exception in any case.
8204 -- Estimate number of bits in result before we go computing
8205 -- giant useless bounds. Basically the number of bits in the
8206 -- result is the number of bits in the base multiplied by the
8207 -- value of the exponent. If this is big enough that the result
8208 -- definitely won't fit in Long_Long_Integer, switch to bignum
8209 -- mode immediately, and avoid computing giant bounds.
8211 -- The comparison here is approximate, but conservative, it
8212 -- only clicks on cases that are sure to exceed the bounds.
8214 if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
8218 -- If right operand is zero then result is 1
8225 -- High bound comes either from exponentiation of largest
8226 -- positive value to largest exponent value, or from
8227 -- the exponentiation of most negative value to an
8241 if Rhi mod 2 = 0 then
8244 Hi2 := Llo ** (Rhi - 1);
8250 Hi := UI_Max (Hi1, Hi2);
8253 -- Result can only be negative if base can be negative
8256 if Rhi mod 2 = 0 then
8257 Lo := Llo ** (Rhi - 1);
8262 -- Otherwise low bound is minimum ** minimum
8279 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8280 -- This is the maximum absolute value of the result
8286 -- The result depends only on the sign and magnitude of
8287 -- the right operand, it does not depend on the sign or
8288 -- magnitude of the left operand.
8301 when N_Op_Multiply =>
8303 -- Possible bounds of multiplication must come from multiplying
8304 -- end values of the input ranges (four possibilities).
8307 Mrk : constant Uintp.Save_Mark := Mark;
8308 -- Mark so we can release the Ev values
8310 Ev1 : constant Uint := Llo * Rlo;
8311 Ev2 : constant Uint := Llo * Rhi;
8312 Ev3 : constant Uint := Lhi * Rlo;
8313 Ev4 : constant Uint := Lhi * Rhi;
8316 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8317 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8319 -- Release the Ev values
8321 Release_And_Save (Mrk, Lo, Hi);
8324 -- Plus operator (affirmation)
8334 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8335 -- This is the maximum absolute value of the result. Note
8336 -- that the result range does not depend on the sign of the
8343 -- Case of left operand negative, which results in a range
8344 -- of -Maxabs .. 0 for those negative values. If there are
8345 -- no negative values then Lo value of result is always 0.
8351 -- Case of left operand positive
8360 when N_Op_Subtract =>
8364 -- Nothing else should be possible
8367 raise Program_Error;
8371 -- Here for the case where we have not rewritten anything (no bignum
8372 -- operands or long long integer operands), and we know the result.
8373 -- If we know we are in the result range, and we do not have Bignum
8374 -- operands or Long_Long_Integer operands, we can just reexpand with
8375 -- overflow checks turned off (since we know we cannot have overflow).
8376 -- As always the reexpansion is required to complete expansion of the
8377 -- operator, but we do not need to reanalyze, and we prevent recursion
8378 -- by suppressing the check.
8380 if not (Bignum_Operands or Long_Long_Integer_Operands)
8381 and then In_Result_Range
8383 Set_Do_Overflow_Check (N, False);
8384 Reexpand (Suppress => True);
8387 -- Here we know that we are not in the result range, and in the general
8388 -- case we will move into either the Bignum or Long_Long_Integer domain
8389 -- to compute the result. However, there is one exception. If we are
8390 -- at the top level, and we do not have Bignum or Long_Long_Integer
8391 -- operands, we will have to immediately convert the result back to
8392 -- the result type, so there is no point in Bignum/Long_Long_Integer
8396 and then not (Bignum_Operands or Long_Long_Integer_Operands)
8398 -- One further refinement. If we are at the top level, but our parent
8399 -- is a type conversion, then go into bignum or long long integer node
8400 -- since the result will be converted to that type directly without
8401 -- going through the result type, and we may avoid an overflow. This
8402 -- is the case for example of Long_Long_Integer (A ** 4), where A is
8403 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
8404 -- but does not fit in Integer.
8406 and then Nkind (Parent (N)) /= N_Type_Conversion
8408 -- Here keep original types, but we need to complete analysis
8410 -- One subtlety. We can't just go ahead and do an analyze operation
8411 -- here because it will cause recursion into the whole MINIMIZED/
8412 -- ELIMINATED overflow processing which is not what we want. Here
8413 -- we are at the top level, and we need a check against the result
8414 -- mode (i.e. we want to use STRICT mode). So do exactly that.
8415 -- Also, we have not modified the node, so this is a case where
8416 -- we need to reexpand, but not reanalyze.
8421 -- Cases where we do the operation in Bignum mode. This happens either
8422 -- because one of our operands is in Bignum mode already, or because
8423 -- the computed bounds are outside the bounds of Long_Long_Integer,
8424 -- which in some cases can be indicated by Hi and Lo being No_Uint.
8426 -- Note: we could do better here and in some cases switch back from
8427 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
8428 -- 0 .. 1, but the cases are rare and it is not worth the effort.
8429 -- Failing to do this switching back is only an efficiency issue.
8431 elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
8433 -- OK, we are definitely outside the range of Long_Long_Integer. The
8434 -- question is whether to move to Bignum mode, or stay in the domain
8435 -- of Long_Long_Integer, signalling that an overflow check is needed.
8437 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
8438 -- the Bignum business. In ELIMINATED mode, we will normally move
8439 -- into Bignum mode, but there is an exception if neither of our
8440 -- operands is Bignum now, and we are at the top level (Top_Level
8441 -- set True). In this case, there is no point in moving into Bignum
8442 -- mode to prevent overflow if the caller will immediately convert
8443 -- the Bignum value back to LLI with an overflow check. It's more
8444 -- efficient to stay in LLI mode with an overflow check (if needed)
8446 if Check_Mode = Minimized
8447 or else (Top_Level and not Bignum_Operands)
8449 if Do_Overflow_Check (N) then
8450 Enable_Overflow_Check (N);
8453 -- The result now has to be in Long_Long_Integer mode, so adjust
8454 -- the possible range to reflect this. Note these calls also
8455 -- change No_Uint values from the top level case to LLI bounds.
8460 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
8463 pragma Assert (Check_Mode = Eliminated);
8472 Fent := RTE (RE_Big_Abs);
8475 Fent := RTE (RE_Big_Add);
8478 Fent := RTE (RE_Big_Div);
8481 Fent := RTE (RE_Big_Exp);
8484 Fent := RTE (RE_Big_Neg);
8487 Fent := RTE (RE_Big_Mod);
8489 when N_Op_Multiply =>
8490 Fent := RTE (RE_Big_Mul);
8493 Fent := RTE (RE_Big_Rem);
8495 when N_Op_Subtract =>
8496 Fent := RTE (RE_Big_Sub);
8498 -- Anything else is an internal error, this includes the
8499 -- N_Op_Plus case, since how can plus cause the result
8500 -- to be out of range if the operand is in range?
8503 raise Program_Error;
8506 -- Construct argument list for Bignum call, converting our
8507 -- operands to Bignum form if they are not already there.
8512 Append_To (Args, Convert_To_Bignum (Left_Opnd (N)));
8515 Append_To (Args, Convert_To_Bignum (Right_Opnd (N)));
8517 -- Now rewrite the arithmetic operator with a call to the
8518 -- corresponding bignum function.
8521 Make_Function_Call (Loc,
8522 Name => New_Occurrence_Of (Fent, Loc),
8523 Parameter_Associations => Args));
8524 Reanalyze (RTE (RE_Bignum), Suppress => True);
8526 -- Indicate result is Bignum mode
8534 -- Otherwise we are in range of Long_Long_Integer, so no overflow
8535 -- check is required, at least not yet.
8538 Set_Do_Overflow_Check (N, False);
8541 -- Here we are not in Bignum territory, but we may have long long
8542 -- integer operands that need special handling. First a special check:
8543 -- If an exponentiation operator exponent is of type Long_Long_Integer,
8544 -- it means we converted it to prevent overflow, but exponentiation
8545 -- requires a Natural right operand, so convert it back to Natural.
8546 -- This conversion may raise an exception which is fine.
8548 if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then
8549 Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N));
8552 -- Here we will do the operation in Long_Long_Integer. We do this even
8553 -- if we know an overflow check is required, better to do this in long
8554 -- long integer mode, since we are less likely to overflow.
8556 -- Convert right or only operand to Long_Long_Integer, except that
8557 -- we do not touch the exponentiation right operand.
8559 if Nkind (N) /= N_Op_Expon then
8560 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
8563 -- Convert left operand to Long_Long_Integer for binary case
8566 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
8569 -- Reset node to unanalyzed
8571 Set_Analyzed (N, False);
8572 Set_Etype (N, Empty);
8573 Set_Entity (N, Empty);
8575 -- Now analyze this new node. This reanalysis will complete processing
8576 -- for the node. In particular we will complete the expansion of an
8577 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
8578 -- we will complete any division checks (since we have not changed the
8579 -- setting of the Do_Division_Check flag).
8581 -- We do this reanalysis in STRICT mode to avoid recursion into the
8582 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
8585 SG : constant Overflow_Mode_Type :=
8586 Scope_Suppress.Overflow_Mode_General;
8587 SA : constant Overflow_Mode_Type :=
8588 Scope_Suppress.Overflow_Mode_Assertions;
8591 Scope_Suppress.Overflow_Mode_General := Strict;
8592 Scope_Suppress.Overflow_Mode_Assertions := Strict;
8594 if not Do_Overflow_Check (N) then
8595 Reanalyze (LLIB, Suppress => True);
8600 Scope_Suppress.Overflow_Mode_General := SG;
8601 Scope_Suppress.Overflow_Mode_Assertions := SA;
8603 end Minimize_Eliminate_Overflows;
8605 -------------------------
8606 -- Overflow_Check_Mode --
8607 -------------------------
8609 function Overflow_Check_Mode return Overflow_Mode_Type is
8611 if In_Assertion_Expr = 0 then
8612 return Scope_Suppress.Overflow_Mode_General;
8614 return Scope_Suppress.Overflow_Mode_Assertions;
8616 end Overflow_Check_Mode;
8618 --------------------------------
8619 -- Overflow_Checks_Suppressed --
8620 --------------------------------
8622 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
8624 if Present (E) and then Checks_May_Be_Suppressed (E) then
8625 return Is_Check_Suppressed (E, Overflow_Check);
8627 return Scope_Suppress.Suppress (Overflow_Check);
8629 end Overflow_Checks_Suppressed;
8631 ---------------------------------
8632 -- Predicate_Checks_Suppressed --
8633 ---------------------------------
8635 function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
8637 if Present (E) and then Checks_May_Be_Suppressed (E) then
8638 return Is_Check_Suppressed (E, Predicate_Check);
8640 return Scope_Suppress.Suppress (Predicate_Check);
8642 end Predicate_Checks_Suppressed;
8644 -----------------------------
8645 -- Range_Checks_Suppressed --
8646 -----------------------------
8648 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
8651 if Kill_Range_Checks (E) then
8654 elsif Checks_May_Be_Suppressed (E) then
8655 return Is_Check_Suppressed (E, Range_Check);
8659 return Scope_Suppress.Suppress (Range_Check);
8660 end Range_Checks_Suppressed;
8662 -----------------------------------------
8663 -- Range_Or_Validity_Checks_Suppressed --
8664 -----------------------------------------
8666 -- Note: the coding would be simpler here if we simply made appropriate
8667 -- calls to Range/Validity_Checks_Suppressed, but that would result in
8668 -- duplicated checks which we prefer to avoid.
8670 function Range_Or_Validity_Checks_Suppressed
8671 (Expr : Node_Id) return Boolean
8674 -- Immediate return if scope checks suppressed for either check
8676 if Scope_Suppress.Suppress (Range_Check)
8678 Scope_Suppress.Suppress (Validity_Check)
8683 -- If no expression, that's odd, decide that checks are suppressed,
8684 -- since we don't want anyone trying to do checks in this case, which
8685 -- is most likely the result of some other error.
8691 -- Expression is present, so perform suppress checks on type
8694 Typ : constant Entity_Id := Etype (Expr);
8696 if Checks_May_Be_Suppressed (Typ)
8697 and then (Is_Check_Suppressed (Typ, Range_Check)
8699 Is_Check_Suppressed (Typ, Validity_Check))
8705 -- If expression is an entity name, perform checks on this entity
8707 if Is_Entity_Name (Expr) then
8709 Ent : constant Entity_Id := Entity (Expr);
8711 if Checks_May_Be_Suppressed (Ent) then
8712 return Is_Check_Suppressed (Ent, Range_Check)
8713 or else Is_Check_Suppressed (Ent, Validity_Check);
8718 -- If we fall through, no checks suppressed
8721 end Range_Or_Validity_Checks_Suppressed;
8727 procedure Remove_Checks (Expr : Node_Id) is
8728 function Process (N : Node_Id) return Traverse_Result;
8729 -- Process a single node during the traversal
8731 procedure Traverse is new Traverse_Proc (Process);
8732 -- The traversal procedure itself
8738 function Process (N : Node_Id) return Traverse_Result is
8740 if Nkind (N) not in N_Subexpr then
8744 Set_Do_Range_Check (N, False);
8748 Traverse (Left_Opnd (N));
8751 when N_Attribute_Reference =>
8752 Set_Do_Overflow_Check (N, False);
8754 when N_Function_Call =>
8755 Set_Do_Tag_Check (N, False);
8758 Set_Do_Overflow_Check (N, False);
8762 Set_Do_Division_Check (N, False);
8765 Set_Do_Length_Check (N, False);
8768 Set_Do_Division_Check (N, False);
8771 Set_Do_Length_Check (N, False);
8774 Set_Do_Division_Check (N, False);
8777 Set_Do_Length_Check (N, False);
8784 Traverse (Left_Opnd (N));
8787 when N_Selected_Component =>
8788 Set_Do_Discriminant_Check (N, False);
8790 when N_Type_Conversion =>
8791 Set_Do_Length_Check (N, False);
8792 Set_Do_Tag_Check (N, False);
8793 Set_Do_Overflow_Check (N, False);
8802 -- Start of processing for Remove_Checks
8808 ----------------------------
8809 -- Selected_Length_Checks --
8810 ----------------------------
8812 function Selected_Length_Checks
8814 Target_Typ : Entity_Id;
8815 Source_Typ : Entity_Id;
8816 Warn_Node : Node_Id) return Check_Result
8818 Loc : constant Source_Ptr := Sloc (Ck_Node);
8821 Expr_Actual : Node_Id;
8823 Cond : Node_Id := Empty;
8824 Do_Access : Boolean := False;
8825 Wnode : Node_Id := Warn_Node;
8826 Ret_Result : Check_Result := (Empty, Empty);
8827 Num_Checks : Natural := 0;
8829 procedure Add_Check (N : Node_Id);
8830 -- Adds the action given to Ret_Result if N is non-Empty
8832 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
8833 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
8834 -- Comments required ???
8836 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
8837 -- True for equal literals and for nodes that denote the same constant
8838 -- entity, even if its value is not a static constant. This includes the
8839 -- case of a discriminal reference within an init proc. Removes some
8840 -- obviously superfluous checks.
8842 function Length_E_Cond
8843 (Exptyp : Entity_Id;
8845 Indx : Nat) return Node_Id;
8846 -- Returns expression to compute:
8847 -- Typ'Length /= Exptyp'Length
8849 function Length_N_Cond
8852 Indx : Nat) return Node_Id;
8853 -- Returns expression to compute:
8854 -- Typ'Length /= Expr'Length
8860 procedure Add_Check (N : Node_Id) is
8864 -- For now, ignore attempt to place more than two checks ???
8865 -- This is really worrisome, are we really discarding checks ???
8867 if Num_Checks = 2 then
8871 pragma Assert (Num_Checks <= 1);
8872 Num_Checks := Num_Checks + 1;
8873 Ret_Result (Num_Checks) := N;
8881 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
8882 SE : constant Entity_Id := Scope (E);
8884 E1 : Entity_Id := E;
8887 if Ekind (Scope (E)) = E_Record_Type
8888 and then Has_Discriminants (Scope (E))
8890 N := Build_Discriminal_Subtype_Of_Component (E);
8893 Insert_Action (Ck_Node, N);
8894 E1 := Defining_Identifier (N);
8898 if Ekind (E1) = E_String_Literal_Subtype then
8900 Make_Integer_Literal (Loc,
8901 Intval => String_Literal_Length (E1));
8903 elsif SE /= Standard_Standard
8904 and then Ekind (Scope (SE)) = E_Protected_Type
8905 and then Has_Discriminants (Scope (SE))
8906 and then Has_Completion (Scope (SE))
8907 and then not Inside_Init_Proc
8909 -- If the type whose length is needed is a private component
8910 -- constrained by a discriminant, we must expand the 'Length
8911 -- attribute into an explicit computation, using the discriminal
8912 -- of the current protected operation. This is because the actual
8913 -- type of the prival is constructed after the protected opera-
8914 -- tion has been fully expanded.
8917 Indx_Type : Node_Id;
8920 Do_Expand : Boolean := False;
8923 Indx_Type := First_Index (E);
8925 for J in 1 .. Indx - 1 loop
8926 Next_Index (Indx_Type);
8929 Get_Index_Bounds (Indx_Type, Lo, Hi);
8931 if Nkind (Lo) = N_Identifier
8932 and then Ekind (Entity (Lo)) = E_In_Parameter
8934 Lo := Get_Discriminal (E, Lo);
8938 if Nkind (Hi) = N_Identifier
8939 and then Ekind (Entity (Hi)) = E_In_Parameter
8941 Hi := Get_Discriminal (E, Hi);
8946 if not Is_Entity_Name (Lo) then
8947 Lo := Duplicate_Subexpr_No_Checks (Lo);
8950 if not Is_Entity_Name (Hi) then
8951 Lo := Duplicate_Subexpr_No_Checks (Hi);
8957 Make_Op_Subtract (Loc,
8961 Right_Opnd => Make_Integer_Literal (Loc, 1));
8966 Make_Attribute_Reference (Loc,
8967 Attribute_Name => Name_Length,
8969 New_Occurrence_Of (E1, Loc));
8972 Set_Expressions (N, New_List (
8973 Make_Integer_Literal (Loc, Indx)));
8982 Make_Attribute_Reference (Loc,
8983 Attribute_Name => Name_Length,
8985 New_Occurrence_Of (E1, Loc));
8988 Set_Expressions (N, New_List (
8989 Make_Integer_Literal (Loc, Indx)));
9000 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
9003 Make_Attribute_Reference (Loc,
9004 Attribute_Name => Name_Length,
9006 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9007 Expressions => New_List (
9008 Make_Integer_Literal (Loc, Indx)));
9015 function Length_E_Cond
9016 (Exptyp : Entity_Id;
9018 Indx : Nat) return Node_Id
9023 Left_Opnd => Get_E_Length (Typ, Indx),
9024 Right_Opnd => Get_E_Length (Exptyp, Indx));
9031 function Length_N_Cond
9034 Indx : Nat) return Node_Id
9039 Left_Opnd => Get_E_Length (Typ, Indx),
9040 Right_Opnd => Get_N_Length (Expr, Indx));
9047 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
9050 (Nkind (L) = N_Integer_Literal
9051 and then Nkind (R) = N_Integer_Literal
9052 and then Intval (L) = Intval (R))
9056 and then Ekind (Entity (L)) = E_Constant
9057 and then ((Is_Entity_Name (R)
9058 and then Entity (L) = Entity (R))
9060 (Nkind (R) = N_Type_Conversion
9061 and then Is_Entity_Name (Expression (R))
9062 and then Entity (L) = Entity (Expression (R)))))
9066 and then Ekind (Entity (R)) = E_Constant
9067 and then Nkind (L) = N_Type_Conversion
9068 and then Is_Entity_Name (Expression (L))
9069 and then Entity (R) = Entity (Expression (L)))
9073 and then Is_Entity_Name (R)
9074 and then Entity (L) = Entity (R)
9075 and then Ekind (Entity (L)) = E_In_Parameter
9076 and then Inside_Init_Proc);
9079 -- Start of processing for Selected_Length_Checks
9082 -- Checks will be applied only when generating code
9084 if not Expander_Active then
9088 if Target_Typ = Any_Type
9089 or else Target_Typ = Any_Composite
9090 or else Raises_Constraint_Error (Ck_Node)
9099 T_Typ := Target_Typ;
9101 if No (Source_Typ) then
9102 S_Typ := Etype (Ck_Node);
9104 S_Typ := Source_Typ;
9107 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9111 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9112 S_Typ := Designated_Type (S_Typ);
9113 T_Typ := Designated_Type (T_Typ);
9116 -- A simple optimization for the null case
9118 if Known_Null (Ck_Node) then
9123 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9124 if Is_Constrained (T_Typ) then
9126 -- The checking code to be generated will freeze the corresponding
9127 -- array type. However, we must freeze the type now, so that the
9128 -- freeze node does not appear within the generated if expression,
9131 Freeze_Before (Ck_Node, T_Typ);
9133 Expr_Actual := Get_Referenced_Object (Ck_Node);
9134 Exptyp := Get_Actual_Subtype (Ck_Node);
9136 if Is_Access_Type (Exptyp) then
9137 Exptyp := Designated_Type (Exptyp);
9140 -- String_Literal case. This needs to be handled specially be-
9141 -- cause no index types are available for string literals. The
9142 -- condition is simply:
9144 -- T_Typ'Length = string-literal-length
9146 if Nkind (Expr_Actual) = N_String_Literal
9147 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
9151 Left_Opnd => Get_E_Length (T_Typ, 1),
9153 Make_Integer_Literal (Loc,
9155 String_Literal_Length (Etype (Expr_Actual))));
9157 -- General array case. Here we have a usable actual subtype for
9158 -- the expression, and the condition is built from the two types
9161 -- T_Typ'Length /= Exptyp'Length or else
9162 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9163 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9166 elsif Is_Constrained (Exptyp) then
9168 Ndims : constant Nat := Number_Dimensions (T_Typ);
9181 -- At the library level, we need to ensure that the type of
9182 -- the object is elaborated before the check itself is
9183 -- emitted. This is only done if the object is in the
9184 -- current compilation unit, otherwise the type is frozen
9185 -- and elaborated in its unit.
9187 if Is_Itype (Exptyp)
9189 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
9191 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
9192 and then In_Open_Scopes (Scope (Exptyp))
9194 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
9195 Set_Itype (Ref_Node, Exptyp);
9196 Insert_Action (Ck_Node, Ref_Node);
9199 L_Index := First_Index (T_Typ);
9200 R_Index := First_Index (Exptyp);
9202 for Indx in 1 .. Ndims loop
9203 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9205 Nkind (R_Index) = N_Raise_Constraint_Error)
9207 Get_Index_Bounds (L_Index, L_Low, L_High);
9208 Get_Index_Bounds (R_Index, R_Low, R_High);
9210 -- Deal with compile time length check. Note that we
9211 -- skip this in the access case, because the access
9212 -- value may be null, so we cannot know statically.
9215 and then Compile_Time_Known_Value (L_Low)
9216 and then Compile_Time_Known_Value (L_High)
9217 and then Compile_Time_Known_Value (R_Low)
9218 and then Compile_Time_Known_Value (R_High)
9220 if Expr_Value (L_High) >= Expr_Value (L_Low) then
9221 L_Length := Expr_Value (L_High) -
9222 Expr_Value (L_Low) + 1;
9224 L_Length := UI_From_Int (0);
9227 if Expr_Value (R_High) >= Expr_Value (R_Low) then
9228 R_Length := Expr_Value (R_High) -
9229 Expr_Value (R_Low) + 1;
9231 R_Length := UI_From_Int (0);
9234 if L_Length > R_Length then
9236 (Compile_Time_Constraint_Error
9237 (Wnode, "too few elements for}??", T_Typ));
9239 elsif L_Length < R_Length then
9241 (Compile_Time_Constraint_Error
9242 (Wnode, "too many elements for}??", T_Typ));
9245 -- The comparison for an individual index subtype
9246 -- is omitted if the corresponding index subtypes
9247 -- statically match, since the result is known to
9248 -- be true. Note that this test is worth while even
9249 -- though we do static evaluation, because non-static
9250 -- subtypes can statically match.
9253 Subtypes_Statically_Match
9254 (Etype (L_Index), Etype (R_Index))
9257 (Same_Bounds (L_Low, R_Low)
9258 and then Same_Bounds (L_High, R_High))
9261 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
9270 -- Handle cases where we do not get a usable actual subtype that
9271 -- is constrained. This happens for example in the function call
9272 -- and explicit dereference cases. In these cases, we have to get
9273 -- the length or range from the expression itself, making sure we
9274 -- do not evaluate it more than once.
9276 -- Here Ck_Node is the original expression, or more properly the
9277 -- result of applying Duplicate_Expr to the original tree, forcing
9278 -- the result to be a name.
9282 Ndims : constant Nat := Number_Dimensions (T_Typ);
9285 -- Build the condition for the explicit dereference case
9287 for Indx in 1 .. Ndims loop
9289 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
9296 -- Construct the test and insert into the tree
9298 if Present (Cond) then
9300 Cond := Guard_Access (Cond, Loc, Ck_Node);
9304 (Make_Raise_Constraint_Error (Loc,
9306 Reason => CE_Length_Check_Failed));
9310 end Selected_Length_Checks;
9312 ---------------------------
9313 -- Selected_Range_Checks --
9314 ---------------------------
9316 function Selected_Range_Checks
9318 Target_Typ : Entity_Id;
9319 Source_Typ : Entity_Id;
9320 Warn_Node : Node_Id) return Check_Result
9322 Loc : constant Source_Ptr := Sloc (Ck_Node);
9325 Expr_Actual : Node_Id;
9327 Cond : Node_Id := Empty;
9328 Do_Access : Boolean := False;
9329 Wnode : Node_Id := Warn_Node;
9330 Ret_Result : Check_Result := (Empty, Empty);
9331 Num_Checks : Integer := 0;
9333 procedure Add_Check (N : Node_Id);
9334 -- Adds the action given to Ret_Result if N is non-Empty
9336 function Discrete_Range_Cond
9338 Typ : Entity_Id) return Node_Id;
9339 -- Returns expression to compute:
9340 -- Low_Bound (Expr) < Typ'First
9342 -- High_Bound (Expr) > Typ'Last
9344 function Discrete_Expr_Cond
9346 Typ : Entity_Id) return Node_Id;
9347 -- Returns expression to compute:
9352 function Get_E_First_Or_Last
9356 Nam : Name_Id) return Node_Id;
9357 -- Returns an attribute reference
9358 -- E'First or E'Last
9359 -- with a source location of Loc.
9361 -- Nam is Name_First or Name_Last, according to which attribute is
9362 -- desired. If Indx is non-zero, it is passed as a literal in the
9363 -- Expressions of the attribute reference (identifying the desired
9364 -- array dimension).
9366 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
9367 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
9368 -- Returns expression to compute:
9369 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9371 function Range_E_Cond
9372 (Exptyp : Entity_Id;
9376 -- Returns expression to compute:
9377 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9379 function Range_Equal_E_Cond
9380 (Exptyp : Entity_Id;
9382 Indx : Nat) return Node_Id;
9383 -- Returns expression to compute:
9384 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9386 function Range_N_Cond
9389 Indx : Nat) return Node_Id;
9390 -- Return expression to compute:
9391 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
9397 procedure Add_Check (N : Node_Id) is
9401 -- For now, ignore attempt to place more than 2 checks ???
9403 if Num_Checks = 2 then
9407 pragma Assert (Num_Checks <= 1);
9408 Num_Checks := Num_Checks + 1;
9409 Ret_Result (Num_Checks) := N;
9413 -------------------------
9414 -- Discrete_Expr_Cond --
9415 -------------------------
9417 function Discrete_Expr_Cond
9419 Typ : Entity_Id) return Node_Id
9427 Convert_To (Base_Type (Typ),
9428 Duplicate_Subexpr_No_Checks (Expr)),
9430 Convert_To (Base_Type (Typ),
9431 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
9436 Convert_To (Base_Type (Typ),
9437 Duplicate_Subexpr_No_Checks (Expr)),
9441 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
9442 end Discrete_Expr_Cond;
9444 -------------------------
9445 -- Discrete_Range_Cond --
9446 -------------------------
9448 function Discrete_Range_Cond
9450 Typ : Entity_Id) return Node_Id
9452 LB : Node_Id := Low_Bound (Expr);
9453 HB : Node_Id := High_Bound (Expr);
9455 Left_Opnd : Node_Id;
9456 Right_Opnd : Node_Id;
9459 if Nkind (LB) = N_Identifier
9460 and then Ekind (Entity (LB)) = E_Discriminant
9462 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9469 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
9474 Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
9476 if Nkind (HB) = N_Identifier
9477 and then Ekind (Entity (HB)) = E_Discriminant
9479 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9486 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
9491 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
9493 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
9494 end Discrete_Range_Cond;
9496 -------------------------
9497 -- Get_E_First_Or_Last --
9498 -------------------------
9500 function Get_E_First_Or_Last
9504 Nam : Name_Id) return Node_Id
9509 Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
9514 return Make_Attribute_Reference (Loc,
9515 Prefix => New_Occurrence_Of (E, Loc),
9516 Attribute_Name => Nam,
9517 Expressions => Exprs);
9518 end Get_E_First_Or_Last;
9524 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
9527 Make_Attribute_Reference (Loc,
9528 Attribute_Name => Name_First,
9530 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9531 Expressions => New_List (
9532 Make_Integer_Literal (Loc, Indx)));
9539 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
9542 Make_Attribute_Reference (Loc,
9543 Attribute_Name => Name_Last,
9545 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9546 Expressions => New_List (
9547 Make_Integer_Literal (Loc, Indx)));
9554 function Range_E_Cond
9555 (Exptyp : Entity_Id;
9557 Indx : Nat) return Node_Id
9565 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9567 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9572 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9574 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9577 ------------------------
9578 -- Range_Equal_E_Cond --
9579 ------------------------
9581 function Range_Equal_E_Cond
9582 (Exptyp : Entity_Id;
9584 Indx : Nat) return Node_Id
9592 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9594 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9599 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9601 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9602 end Range_Equal_E_Cond;
9608 function Range_N_Cond
9611 Indx : Nat) return Node_Id
9619 Get_N_First (Expr, Indx),
9621 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9626 Get_N_Last (Expr, Indx),
9628 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9631 -- Start of processing for Selected_Range_Checks
9634 -- Checks will be applied only when generating code. In GNATprove mode,
9635 -- we do not apply the checks, but we still call Selected_Range_Checks
9636 -- to possibly issue errors on SPARK code when a run-time error can be
9637 -- detected at compile time.
9639 if not Expander_Active and not GNATprove_Mode then
9643 if Target_Typ = Any_Type
9644 or else Target_Typ = Any_Composite
9645 or else Raises_Constraint_Error (Ck_Node)
9654 T_Typ := Target_Typ;
9656 if No (Source_Typ) then
9657 S_Typ := Etype (Ck_Node);
9659 S_Typ := Source_Typ;
9662 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9666 -- The order of evaluating T_Typ before S_Typ seems to be critical
9667 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
9668 -- in, and since Node can be an N_Range node, it might be invalid.
9669 -- Should there be an assert check somewhere for taking the Etype of
9670 -- an N_Range node ???
9672 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9673 S_Typ := Designated_Type (S_Typ);
9674 T_Typ := Designated_Type (T_Typ);
9677 -- A simple optimization for the null case
9679 if Known_Null (Ck_Node) then
9684 -- For an N_Range Node, check for a null range and then if not
9685 -- null generate a range check action.
9687 if Nkind (Ck_Node) = N_Range then
9689 -- There's no point in checking a range against itself
9691 if Ck_Node = Scalar_Range (T_Typ) then
9696 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
9697 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
9698 Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
9699 Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
9701 LB : Node_Id := Low_Bound (Ck_Node);
9702 HB : Node_Id := High_Bound (Ck_Node);
9703 Known_LB : Boolean := False;
9704 Known_HB : Boolean := False;
9706 Null_Range : Boolean;
9707 Out_Of_Range_L : Boolean;
9708 Out_Of_Range_H : Boolean;
9711 -- Compute what is known at compile time
9713 if Known_T_LB and Known_T_HB then
9714 if Compile_Time_Known_Value (LB) then
9717 -- There's no point in checking that a bound is within its
9718 -- own range so pretend that it is known in this case. First
9719 -- deal with low bound.
9721 elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype
9722 and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ)
9728 -- Likewise for the high bound
9730 if Compile_Time_Known_Value (HB) then
9733 elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype
9734 and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ)
9741 -- Check for case where everything is static and we can do the
9742 -- check at compile time. This is skipped if we have an access
9743 -- type, since the access value may be null.
9745 -- ??? This code can be improved since you only need to know that
9746 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9747 -- compile time to emit pertinent messages.
9749 if Known_T_LB and Known_T_HB and Known_LB and Known_HB
9752 -- Floating-point case
9754 if Is_Floating_Point_Type (S_Typ) then
9755 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
9757 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
9759 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
9762 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
9764 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
9766 -- Fixed or discrete type case
9769 Null_Range := Expr_Value (HB) < Expr_Value (LB);
9771 (Expr_Value (LB) < Expr_Value (T_LB))
9773 (Expr_Value (LB) > Expr_Value (T_HB));
9776 (Expr_Value (HB) > Expr_Value (T_HB))
9778 (Expr_Value (HB) < Expr_Value (T_LB));
9781 if not Null_Range then
9782 if Out_Of_Range_L then
9783 if No (Warn_Node) then
9785 (Compile_Time_Constraint_Error
9786 (Low_Bound (Ck_Node),
9787 "static value out of range of}??", T_Typ));
9791 (Compile_Time_Constraint_Error
9793 "static range out of bounds of}??", T_Typ));
9797 if Out_Of_Range_H then
9798 if No (Warn_Node) then
9800 (Compile_Time_Constraint_Error
9801 (High_Bound (Ck_Node),
9802 "static value out of range of}??", T_Typ));
9806 (Compile_Time_Constraint_Error
9808 "static range out of bounds of}??", T_Typ));
9815 LB : Node_Id := Low_Bound (Ck_Node);
9816 HB : Node_Id := High_Bound (Ck_Node);
9819 -- If either bound is a discriminant and we are within the
9820 -- record declaration, it is a use of the discriminant in a
9821 -- constraint of a component, and nothing can be checked
9822 -- here. The check will be emitted within the init proc.
9823 -- Before then, the discriminal has no real meaning.
9824 -- Similarly, if the entity is a discriminal, there is no
9825 -- check to perform yet.
9827 -- The same holds within a discriminated synchronized type,
9828 -- where the discriminant may constrain a component or an
9831 if Nkind (LB) = N_Identifier
9832 and then Denotes_Discriminant (LB, True)
9834 if Current_Scope = Scope (Entity (LB))
9835 or else Is_Concurrent_Type (Current_Scope)
9836 or else Ekind (Entity (LB)) /= E_Discriminant
9841 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9845 if Nkind (HB) = N_Identifier
9846 and then Denotes_Discriminant (HB, True)
9848 if Current_Scope = Scope (Entity (HB))
9849 or else Is_Concurrent_Type (Current_Scope)
9850 or else Ekind (Entity (HB)) /= E_Discriminant
9855 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9859 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
9860 Set_Paren_Count (Cond, 1);
9867 Convert_To (Base_Type (Etype (HB)),
9868 Duplicate_Subexpr_No_Checks (HB)),
9870 Convert_To (Base_Type (Etype (LB)),
9871 Duplicate_Subexpr_No_Checks (LB))),
9872 Right_Opnd => Cond);
9877 elsif Is_Scalar_Type (S_Typ) then
9879 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9880 -- except the above simply sets a flag in the node and lets
9881 -- gigi generate the check base on the Etype of the expression.
9882 -- Sometimes, however we want to do a dynamic check against an
9883 -- arbitrary target type, so we do that here.
9885 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
9886 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9888 -- For literals, we can tell if the constraint error will be
9889 -- raised at compile time, so we never need a dynamic check, but
9890 -- if the exception will be raised, then post the usual warning,
9891 -- and replace the literal with a raise constraint error
9892 -- expression. As usual, skip this for access types
9894 elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
9896 LB : constant Node_Id := Type_Low_Bound (T_Typ);
9897 UB : constant Node_Id := Type_High_Bound (T_Typ);
9899 Out_Of_Range : Boolean;
9900 Static_Bounds : constant Boolean :=
9901 Compile_Time_Known_Value (LB)
9902 and Compile_Time_Known_Value (UB);
9905 -- Following range tests should use Sem_Eval routine ???
9907 if Static_Bounds then
9908 if Is_Floating_Point_Type (S_Typ) then
9910 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
9912 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
9914 -- Fixed or discrete type
9918 Expr_Value (Ck_Node) < Expr_Value (LB)
9920 Expr_Value (Ck_Node) > Expr_Value (UB);
9923 -- Bounds of the type are static and the literal is out of
9924 -- range so output a warning message.
9926 if Out_Of_Range then
9927 if No (Warn_Node) then
9929 (Compile_Time_Constraint_Error
9931 "static value out of range of}??", T_Typ));
9935 (Compile_Time_Constraint_Error
9937 "static value out of range of}??", T_Typ));
9942 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9946 -- Here for the case of a non-static expression, we need a runtime
9947 -- check unless the source type range is guaranteed to be in the
9948 -- range of the target type.
9951 if not In_Subrange_Of (S_Typ, T_Typ) then
9952 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9957 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9958 if Is_Constrained (T_Typ) then
9960 Expr_Actual := Get_Referenced_Object (Ck_Node);
9961 Exptyp := Get_Actual_Subtype (Expr_Actual);
9963 if Is_Access_Type (Exptyp) then
9964 Exptyp := Designated_Type (Exptyp);
9967 -- String_Literal case. This needs to be handled specially be-
9968 -- cause no index types are available for string literals. The
9969 -- condition is simply:
9971 -- T_Typ'Length = string-literal-length
9973 if Nkind (Expr_Actual) = N_String_Literal then
9976 -- General array case. Here we have a usable actual subtype for
9977 -- the expression, and the condition is built from the two types
9979 -- T_Typ'First < Exptyp'First or else
9980 -- T_Typ'Last > Exptyp'Last or else
9981 -- T_Typ'First(1) < Exptyp'First(1) or else
9982 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9985 elsif Is_Constrained (Exptyp) then
9987 Ndims : constant Nat := Number_Dimensions (T_Typ);
9993 L_Index := First_Index (T_Typ);
9994 R_Index := First_Index (Exptyp);
9996 for Indx in 1 .. Ndims loop
9997 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9999 Nkind (R_Index) = N_Raise_Constraint_Error)
10001 -- Deal with compile time length check. Note that we
10002 -- skip this in the access case, because the access
10003 -- value may be null, so we cannot know statically.
10006 Subtypes_Statically_Match
10007 (Etype (L_Index), Etype (R_Index))
10009 -- If the target type is constrained then we
10010 -- have to check for exact equality of bounds
10011 -- (required for qualified expressions).
10013 if Is_Constrained (T_Typ) then
10016 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
10019 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
10029 -- Handle cases where we do not get a usable actual subtype that
10030 -- is constrained. This happens for example in the function call
10031 -- and explicit dereference cases. In these cases, we have to get
10032 -- the length or range from the expression itself, making sure we
10033 -- do not evaluate it more than once.
10035 -- Here Ck_Node is the original expression, or more properly the
10036 -- result of applying Duplicate_Expr to the original tree,
10037 -- forcing the result to be a name.
10041 Ndims : constant Nat := Number_Dimensions (T_Typ);
10044 -- Build the condition for the explicit dereference case
10046 for Indx in 1 .. Ndims loop
10048 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
10054 -- For a conversion to an unconstrained array type, generate an
10055 -- Action to check that the bounds of the source value are within
10056 -- the constraints imposed by the target type (RM 4.6(38)). No
10057 -- check is needed for a conversion to an access to unconstrained
10058 -- array type, as 4.6(24.15/2) requires the designated subtypes
10059 -- of the two access types to statically match.
10061 if Nkind (Parent (Ck_Node)) = N_Type_Conversion
10062 and then not Do_Access
10065 Opnd_Index : Node_Id;
10066 Targ_Index : Node_Id;
10067 Opnd_Range : Node_Id;
10070 Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
10071 Targ_Index := First_Index (T_Typ);
10072 while Present (Opnd_Index) loop
10074 -- If the index is a range, use its bounds. If it is an
10075 -- entity (as will be the case if it is a named subtype
10076 -- or an itype created for a slice) retrieve its range.
10078 if Is_Entity_Name (Opnd_Index)
10079 and then Is_Type (Entity (Opnd_Index))
10081 Opnd_Range := Scalar_Range (Entity (Opnd_Index));
10083 Opnd_Range := Opnd_Index;
10086 if Nkind (Opnd_Range) = N_Range then
10088 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10089 Assume_Valid => True)
10092 (High_Bound (Opnd_Range), Etype (Targ_Index),
10093 Assume_Valid => True)
10097 -- If null range, no check needed
10100 Compile_Time_Known_Value (High_Bound (Opnd_Range))
10102 Compile_Time_Known_Value (Low_Bound (Opnd_Range))
10104 Expr_Value (High_Bound (Opnd_Range)) <
10105 Expr_Value (Low_Bound (Opnd_Range))
10109 elsif Is_Out_Of_Range
10110 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10111 Assume_Valid => True)
10114 (High_Bound (Opnd_Range), Etype (Targ_Index),
10115 Assume_Valid => True)
10118 (Compile_Time_Constraint_Error
10119 (Wnode, "value out of range of}??", T_Typ));
10124 Discrete_Range_Cond
10125 (Opnd_Range, Etype (Targ_Index)));
10129 Next_Index (Opnd_Index);
10130 Next_Index (Targ_Index);
10137 -- Construct the test and insert into the tree
10139 if Present (Cond) then
10141 Cond := Guard_Access (Cond, Loc, Ck_Node);
10145 (Make_Raise_Constraint_Error (Loc,
10147 Reason => CE_Range_Check_Failed));
10151 end Selected_Range_Checks;
10153 -------------------------------
10154 -- Storage_Checks_Suppressed --
10155 -------------------------------
10157 function Storage_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, Storage_Check);
10162 return Scope_Suppress.Suppress (Storage_Check);
10164 end Storage_Checks_Suppressed;
10166 ---------------------------
10167 -- Tag_Checks_Suppressed --
10168 ---------------------------
10170 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
10173 and then Checks_May_Be_Suppressed (E)
10175 return Is_Check_Suppressed (E, Tag_Check);
10177 return Scope_Suppress.Suppress (Tag_Check);
10179 end Tag_Checks_Suppressed;
10181 ---------------------------------------
10182 -- Validate_Alignment_Check_Warnings --
10183 ---------------------------------------
10185 procedure Validate_Alignment_Check_Warnings is
10187 for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop
10189 AWR : Alignment_Warnings_Record
10190 renames Alignment_Warnings.Table (J);
10192 if Known_Alignment (AWR.E)
10193 and then AWR.A mod Alignment (AWR.E) = 0
10195 Delete_Warning_And_Continuations (AWR.W);
10199 end Validate_Alignment_Check_Warnings;
10201 --------------------------
10202 -- Validity_Check_Range --
10203 --------------------------
10205 procedure Validity_Check_Range
10207 Related_Id : Entity_Id := Empty)
10210 if Validity_Checks_On and Validity_Check_Operands then
10211 if Nkind (N) = N_Range then
10213 (Expr => Low_Bound (N),
10214 Related_Id => Related_Id,
10215 Is_Low_Bound => True);
10218 (Expr => High_Bound (N),
10219 Related_Id => Related_Id,
10220 Is_High_Bound => True);
10223 end Validity_Check_Range;
10225 --------------------------------
10226 -- Validity_Checks_Suppressed --
10227 --------------------------------
10229 function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
10231 if Present (E) and then Checks_May_Be_Suppressed (E) then
10232 return Is_Check_Suppressed (E, Validity_Check);
10234 return Scope_Suppress.Suppress (Validity_Check);
10236 end Validity_Checks_Suppressed;