1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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_Disp; use Sem_Disp;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Mech; use Sem_Mech;
54 with Sem_Res; use Sem_Res;
55 with Sem_Util; use Sem_Util;
56 with Sem_Warn; use Sem_Warn;
57 with Sinfo; use Sinfo;
58 with Sinput; use Sinput;
59 with Snames; use Snames;
60 with Sprint; use Sprint;
61 with Stand; use Stand;
62 with Stringt; use Stringt;
63 with Targparm; use Targparm;
64 with Tbuild; use Tbuild;
65 with Ttypes; use Ttypes;
66 with Validsw; use Validsw;
68 package body Checks is
70 -- General note: many of these routines are concerned with generating
71 -- checking code to make sure that constraint error is raised at runtime.
72 -- Clearly this code is only needed if the expander is active, since
73 -- otherwise we will not be generating code or going into the runtime
76 -- We therefore disconnect most of these checks if the expander is
77 -- inactive. This has the additional benefit that we do not need to
78 -- worry about the tree being messed up by previous errors (since errors
79 -- turn off expansion anyway).
81 -- There are a few exceptions to the above rule. For instance routines
82 -- such as Apply_Scalar_Range_Check that do not insert any code can be
83 -- safely called even when the Expander is inactive (but Errors_Detected
84 -- is 0). The benefit of executing this code when expansion is off, is
85 -- the ability to emit constraint error warning for static expressions
86 -- even when we are not generating code.
88 -- The above is modified in gnatprove mode to ensure that proper check
89 -- flags are always placed, even if expansion is off.
91 -------------------------------------
92 -- Suppression of Redundant Checks --
93 -------------------------------------
95 -- This unit implements a limited circuit for removal of redundant
96 -- checks. The processing is based on a tracing of simple sequential
97 -- flow. For any sequence of statements, we save expressions that are
98 -- marked to be checked, and then if the same expression appears later
99 -- with the same check, then under certain circumstances, the second
100 -- check can be suppressed.
102 -- Basically, we can suppress the check if we know for certain that
103 -- the previous expression has been elaborated (together with its
104 -- check), and we know that the exception frame is the same, and that
105 -- nothing has happened to change the result of the exception.
107 -- Let us examine each of these three conditions in turn to describe
108 -- how we ensure that this condition is met.
110 -- First, we need to know for certain that the previous expression has
111 -- been executed. This is done principally by the mechanism of calling
112 -- Conditional_Statements_Begin at the start of any statement sequence
113 -- and Conditional_Statements_End at the end. The End call causes all
114 -- checks remembered since the Begin call to be discarded. This does
115 -- miss a few cases, notably the case of a nested BEGIN-END block with
116 -- no exception handlers. But the important thing is to be conservative.
117 -- The other protection is that all checks are discarded if a label
118 -- is encountered, since then the assumption of sequential execution
119 -- is violated, and we don't know enough about the flow.
121 -- Second, we need to know that the exception frame is the same. We
122 -- do this by killing all remembered checks when we enter a new frame.
123 -- Again, that's over-conservative, but generally the cases we can help
124 -- with are pretty local anyway (like the body of a loop for example).
126 -- Third, we must be sure to forget any checks which are no longer valid.
127 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
128 -- used to note any changes to local variables. We only attempt to deal
129 -- with checks involving local variables, so we do not need to worry
130 -- about global variables. Second, a call to any non-global procedure
131 -- causes us to abandon all stored checks, since such a all may affect
132 -- the values of any local variables.
134 -- The following define the data structures used to deal with remembering
135 -- checks so that redundant checks can be eliminated as described above.
137 -- Right now, the only expressions that we deal with are of the form of
138 -- simple local objects (either declared locally, or IN parameters) or
139 -- such objects plus/minus a compile time known constant. We can do
140 -- more later on if it seems worthwhile, but this catches many simple
141 -- cases in practice.
143 -- The following record type reflects a single saved check. An entry
144 -- is made in the stack of saved checks if and only if the expression
145 -- has been elaborated with the indicated checks.
147 type Saved_Check is record
149 -- Set True if entry is killed by Kill_Checks
152 -- The entity involved in the expression that is checked
155 -- A compile time value indicating the result of adding or
156 -- subtracting a compile time value. This value is to be
157 -- added to the value of the Entity. A value of zero is
158 -- used for the case of a simple entity reference.
160 Check_Type : Character;
161 -- This is set to 'R' for a range check (in which case Target_Type
162 -- is set to the target type for the range check) or to 'O' for an
163 -- overflow check (in which case Target_Type is set to Empty).
165 Target_Type : Entity_Id;
166 -- Used only if Do_Range_Check is set. Records the target type for
167 -- the check. We need this, because a check is a duplicate only if
168 -- it has the same target type (or more accurately one with a
169 -- range that is smaller or equal to the stored target type of a
173 -- The following table keeps track of saved checks. Rather than use an
174 -- extensible table, we just use a table of fixed size, and we discard
175 -- any saved checks that do not fit. That's very unlikely to happen and
176 -- this is only an optimization in any case.
178 Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
179 -- Array of saved checks
181 Num_Saved_Checks : Nat := 0;
182 -- Number of saved checks
184 -- The following stack keeps track of statement ranges. It is treated
185 -- as a stack. When Conditional_Statements_Begin is called, an entry
186 -- is pushed onto this stack containing the value of Num_Saved_Checks
187 -- at the time of the call. Then when Conditional_Statements_End is
188 -- called, this value is popped off and used to reset Num_Saved_Checks.
190 -- Note: again, this is a fixed length stack with a size that should
191 -- always be fine. If the value of the stack pointer goes above the
192 -- limit, then we just forget all saved checks.
194 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
195 Saved_Checks_TOS : Nat := 0;
197 -----------------------
198 -- Local Subprograms --
199 -----------------------
201 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id);
202 -- Used to apply arithmetic overflow checks for all cases except operators
203 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
204 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
205 -- signed integer arithmetic operator (but not an if or case expression).
206 -- It is also called for types other than signed integers.
208 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id);
209 -- Used to apply arithmetic overflow checks for the case where the overflow
210 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
211 -- arithmetic op (which includes the case of if and case expressions). Note
212 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
213 -- we have work to do even if overflow checking is suppressed.
215 procedure Apply_Division_Check
220 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
221 -- division checks as required if the Do_Division_Check flag is set.
222 -- Rlo and Rhi give the possible range of the right operand, these values
223 -- can be referenced and trusted only if ROK is set True.
225 procedure Apply_Float_Conversion_Check
227 Target_Typ : Entity_Id);
228 -- The checks on a conversion from a floating-point type to an integer
229 -- type are delicate. They have to be performed before conversion, they
230 -- have to raise an exception when the operand is a NaN, and rounding must
231 -- be taken into account to determine the safe bounds of the operand.
233 procedure Apply_Selected_Length_Checks
235 Target_Typ : Entity_Id;
236 Source_Typ : Entity_Id;
237 Do_Static : Boolean);
238 -- This is the subprogram that does all the work for Apply_Length_Check
239 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
240 -- described for the above routines. The Do_Static flag indicates that
241 -- only a static check is to be done.
243 procedure Apply_Selected_Range_Checks
245 Target_Typ : Entity_Id;
246 Source_Typ : Entity_Id;
247 Do_Static : Boolean);
248 -- This is the subprogram that does all the work for Apply_Range_Check.
249 -- Expr, Target_Typ and Source_Typ are as described for the above
250 -- routine. The Do_Static flag indicates that only a static check is
253 type Check_Type is new Check_Id range Access_Check .. Division_Check;
254 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
255 -- This function is used to see if an access or division by zero check is
256 -- needed. The check is to be applied to a single variable appearing in the
257 -- source, and N is the node for the reference. If N is not of this form,
258 -- True is returned with no further processing. If N is of the right form,
259 -- then further processing determines if the given Check is needed.
261 -- The particular circuit is to see if we have the case of a check that is
262 -- not needed because it appears in the right operand of a short circuited
263 -- conditional where the left operand guards the check. For example:
265 -- if Var = 0 or else Q / Var > 12 then
269 -- In this example, the division check is not required. At the same time
270 -- we can issue warnings for suspicious use of non-short-circuited forms,
273 -- if Var = 0 or Q / Var > 12 then
279 Check_Type : Character;
280 Target_Type : Entity_Id;
281 Entry_OK : out Boolean;
285 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
286 -- to see if a check is of the form for optimization, and if so, to see
287 -- if it has already been performed. Expr is the expression to check,
288 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
289 -- Target_Type is the target type for a range check, and Empty for an
290 -- overflow check. If the entry is not of the form for optimization,
291 -- then Entry_OK is set to False, and the remaining out parameters
292 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
293 -- entity and offset from the expression. Check_Num is the number of
294 -- a matching saved entry in Saved_Checks, or zero if no such entry
297 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
298 -- If a discriminal is used in constraining a prival, Return reference
299 -- to the discriminal of the protected body (which renames the parameter
300 -- of the enclosing protected operation). This clumsy transformation is
301 -- needed because privals are created too late and their actual subtypes
302 -- are not available when analysing the bodies of the protected operations.
303 -- This function is called whenever the bound is an entity and the scope
304 -- indicates a protected operation. If the bound is an in-parameter of
305 -- a protected operation that is not a prival, the function returns the
307 -- To be cleaned up???
309 function Guard_Access
312 Ck_Node : Node_Id) return Node_Id;
313 -- In the access type case, guard the test with a test to ensure
314 -- that the access value is non-null, since the checks do not
315 -- not apply to null access values.
317 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
318 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
319 -- Constraint_Error node.
321 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean;
322 -- Returns True if node N is for an arithmetic operation with signed
323 -- integer operands. This includes unary and binary operators, and also
324 -- if and case expression nodes where the dependent expressions are of
325 -- a signed integer type. These are the kinds of nodes for which special
326 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
328 function Range_Or_Validity_Checks_Suppressed
329 (Expr : Node_Id) return Boolean;
330 -- Returns True if either range or validity checks or both are suppressed
331 -- for the type of the given expression, or, if the expression is the name
332 -- of an entity, if these checks are suppressed for the entity.
334 function Selected_Length_Checks
336 Target_Typ : Entity_Id;
337 Source_Typ : Entity_Id;
338 Warn_Node : Node_Id) return Check_Result;
339 -- Like Apply_Selected_Length_Checks, except it doesn't modify
340 -- anything, just returns a list of nodes as described in the spec of
341 -- this package for the Range_Check function.
342 -- ??? In fact it does construct the test and insert it into the tree,
343 -- and insert actions in various ways (calling Insert_Action directly
344 -- in particular) so we do not call it in GNATprove mode, contrary to
345 -- Selected_Range_Checks.
347 function Selected_Range_Checks
349 Target_Typ : Entity_Id;
350 Source_Typ : Entity_Id;
351 Warn_Node : Node_Id) return Check_Result;
352 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
353 -- just returns a list of nodes as described in the spec of this package
354 -- for the Range_Check function.
356 ------------------------------
357 -- Access_Checks_Suppressed --
358 ------------------------------
360 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
362 if Present (E) and then Checks_May_Be_Suppressed (E) then
363 return Is_Check_Suppressed (E, Access_Check);
365 return Scope_Suppress.Suppress (Access_Check);
367 end Access_Checks_Suppressed;
369 -------------------------------------
370 -- Accessibility_Checks_Suppressed --
371 -------------------------------------
373 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
375 if Present (E) and then Checks_May_Be_Suppressed (E) then
376 return Is_Check_Suppressed (E, Accessibility_Check);
378 return Scope_Suppress.Suppress (Accessibility_Check);
380 end Accessibility_Checks_Suppressed;
382 -----------------------------
383 -- Activate_Division_Check --
384 -----------------------------
386 procedure Activate_Division_Check (N : Node_Id) is
388 Set_Do_Division_Check (N, True);
389 Possible_Local_Raise (N, Standard_Constraint_Error);
390 end Activate_Division_Check;
392 -----------------------------
393 -- Activate_Overflow_Check --
394 -----------------------------
396 procedure Activate_Overflow_Check (N : Node_Id) is
397 Typ : constant Entity_Id := Etype (N);
400 -- Floating-point case. If Etype is not set (this can happen when we
401 -- activate a check on a node that has not yet been analyzed), then
402 -- we assume we do not have a floating-point type (as per our spec).
404 if Present (Typ) and then Is_Floating_Point_Type (Typ) then
406 -- Ignore call if we have no automatic overflow checks on the target
407 -- and Check_Float_Overflow mode is not set. These are the cases in
408 -- which we expect to generate infinities and NaN's with no check.
410 if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
413 -- Ignore for unary operations ("+", "-", abs) since these can never
414 -- result in overflow for floating-point cases.
416 elsif Nkind (N) in N_Unary_Op then
419 -- Otherwise we will set the flag
428 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
429 -- for zero-divide is a divide check, not an overflow check).
431 if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
436 -- Fall through for cases where we do set the flag
438 Set_Do_Overflow_Check (N);
439 Possible_Local_Raise (N, Standard_Constraint_Error);
440 end Activate_Overflow_Check;
442 --------------------------
443 -- Activate_Range_Check --
444 --------------------------
446 procedure Activate_Range_Check (N : Node_Id) is
448 Set_Do_Range_Check (N);
449 Possible_Local_Raise (N, Standard_Constraint_Error);
450 end Activate_Range_Check;
452 ---------------------------------
453 -- Alignment_Checks_Suppressed --
454 ---------------------------------
456 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
458 if Present (E) and then Checks_May_Be_Suppressed (E) then
459 return Is_Check_Suppressed (E, Alignment_Check);
461 return Scope_Suppress.Suppress (Alignment_Check);
463 end Alignment_Checks_Suppressed;
465 ----------------------------------
466 -- Allocation_Checks_Suppressed --
467 ----------------------------------
469 -- Note: at the current time there are no calls to this function, because
470 -- the relevant check is in the run-time, so it is not a check that the
471 -- compiler can suppress anyway, but we still have to recognize the check
472 -- name Allocation_Check since it is part of the standard.
474 function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
476 if Present (E) and then Checks_May_Be_Suppressed (E) then
477 return Is_Check_Suppressed (E, Allocation_Check);
479 return Scope_Suppress.Suppress (Allocation_Check);
481 end Allocation_Checks_Suppressed;
483 -------------------------
484 -- Append_Range_Checks --
485 -------------------------
487 procedure Append_Range_Checks
488 (Checks : Check_Result;
490 Suppress_Typ : Entity_Id;
491 Static_Sloc : Source_Ptr;
494 Checks_On : constant Boolean :=
495 not Index_Checks_Suppressed (Suppress_Typ)
497 not Range_Checks_Suppressed (Suppress_Typ);
499 Internal_Flag_Node : constant Node_Id := Flag_Node;
500 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
503 -- For now we just return if Checks_On is false, however this should be
504 -- enhanced to check for an always True value in the condition and to
505 -- generate a compilation warning???
507 if not Checks_On then
512 exit when No (Checks (J));
514 if Nkind (Checks (J)) = N_Raise_Constraint_Error
515 and then Present (Condition (Checks (J)))
517 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
518 Append_To (Stmts, Checks (J));
519 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
525 Make_Raise_Constraint_Error (Internal_Static_Sloc,
526 Reason => CE_Range_Check_Failed));
529 end Append_Range_Checks;
531 ------------------------
532 -- Apply_Access_Check --
533 ------------------------
535 procedure Apply_Access_Check (N : Node_Id) is
536 P : constant Node_Id := Prefix (N);
539 -- We do not need checks if we are not generating code (i.e. the
540 -- expander is not active). This is not just an optimization, there
541 -- are cases (e.g. with pragma Debug) where generating the checks
542 -- can cause real trouble).
544 if not Expander_Active then
548 -- No check if short circuiting makes check unnecessary
550 if not Check_Needed (P, Access_Check) then
554 -- No check if accessing the Offset_To_Top component of a dispatch
555 -- table. They are safe by construction.
557 if Tagged_Type_Expansion
558 and then Present (Etype (P))
559 and then RTU_Loaded (Ada_Tags)
560 and then RTE_Available (RE_Offset_To_Top_Ptr)
561 and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
566 -- Otherwise go ahead and install the check
568 Install_Null_Excluding_Check (P);
569 end Apply_Access_Check;
571 -------------------------------
572 -- Apply_Accessibility_Check --
573 -------------------------------
575 procedure Apply_Accessibility_Check
578 Insert_Node : Node_Id)
580 Loc : constant Source_Ptr := Sloc (N);
582 Check_Cond : Node_Id;
583 Param_Ent : Entity_Id := Param_Entity (N);
584 Param_Level : Node_Id;
585 Type_Level : Node_Id;
588 if Ada_Version >= Ada_2012
589 and then not Present (Param_Ent)
590 and then Is_Entity_Name (N)
591 and then Ekind_In (Entity (N), E_Constant, E_Variable)
592 and then Present (Effective_Extra_Accessibility (Entity (N)))
594 Param_Ent := Entity (N);
595 while Present (Renamed_Object (Param_Ent)) loop
597 -- Renamed_Object must return an Entity_Name here
598 -- because of preceding "Present (E_E_A (...))" test.
600 Param_Ent := Entity (Renamed_Object (Param_Ent));
604 if Inside_A_Generic then
607 -- Only apply the run-time check if the access parameter has an
608 -- associated extra access level parameter and when the level of the
609 -- type is less deep than the level of the access parameter, and
610 -- accessibility checks are not suppressed.
612 elsif Present (Param_Ent)
613 and then Present (Extra_Accessibility (Param_Ent))
614 and then UI_Gt (Object_Access_Level (N),
615 Deepest_Type_Access_Level (Typ))
616 and then not Accessibility_Checks_Suppressed (Param_Ent)
617 and then not Accessibility_Checks_Suppressed (Typ)
620 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
622 -- Use the dynamic accessibility parameter for the function's result
623 -- when one has been created instead of statically referring to the
624 -- deepest type level so as to appropriatly handle the rules for
625 -- RM 3.10.2 (10.1/3).
627 if Ekind_In (Scope (Param_Ent), E_Function,
630 and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent)))
634 (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
637 Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
640 -- Raise Program_Error if the accessibility level of the access
641 -- parameter is deeper than the level of the target access type.
645 Left_Opnd => Param_Level,
646 Right_Opnd => Type_Level);
648 Insert_Action (Insert_Node,
649 Make_Raise_Program_Error (Loc,
650 Condition => Check_Cond,
651 Reason => PE_Accessibility_Check_Failed));
653 Analyze_And_Resolve (N);
655 -- If constant folding has happened on the condition for the
656 -- generated error, then warn about it being unconditional.
658 if Nkind (Check_Cond) = N_Identifier
659 and then Entity (Check_Cond) = Standard_True
661 Error_Msg_Warn := SPARK_Mode /= On;
662 Error_Msg_N ("accessibility check fails<<", N);
663 Error_Msg_N ("\Program_Error [<<", N);
666 end Apply_Accessibility_Check;
668 --------------------------------
669 -- Apply_Address_Clause_Check --
670 --------------------------------
672 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
673 pragma Assert (Nkind (N) = N_Freeze_Entity);
675 AC : constant Node_Id := Address_Clause (E);
676 Loc : constant Source_Ptr := Sloc (AC);
677 Typ : constant Entity_Id := Etype (E);
680 -- Address expression (not necessarily the same as Aexp, for example
681 -- when Aexp is a reference to a constant, in which case Expr gets
682 -- reset to reference the value expression of the constant).
685 -- See if alignment check needed. Note that we never need a check if the
686 -- maximum alignment is one, since the check will always succeed.
688 -- Note: we do not check for checks suppressed here, since that check
689 -- was done in Sem_Ch13 when the address clause was processed. We are
690 -- only called if checks were not suppressed. The reason for this is
691 -- that we have to delay the call to Apply_Alignment_Check till freeze
692 -- time (so that all types etc are elaborated), but we have to check
693 -- the status of check suppressing at the point of the address clause.
696 or else not Check_Address_Alignment (AC)
697 or else Maximum_Alignment = 1
702 -- Obtain expression from address clause
704 Expr := Address_Value (Expression (AC));
706 -- See if we know that Expr has an acceptable value at compile time. If
707 -- it hasn't or we don't know, we defer issuing the warning until the
708 -- end of the compilation to take into account back end annotations.
710 if Compile_Time_Known_Value (Expr)
711 and then (Known_Alignment (E) or else Known_Alignment (Typ))
714 AL : Uint := Alignment (Typ);
717 -- The object alignment might be more restrictive than the type
720 if Known_Alignment (E) then
724 if Expr_Value (Expr) mod AL = 0 then
729 -- If the expression has the form X'Address, then we can find out if the
730 -- object X has an alignment that is compatible with the object E. If it
731 -- hasn't or we don't know, we defer issuing the warning until the end
732 -- of the compilation to take into account back end annotations.
734 elsif Nkind (Expr) = N_Attribute_Reference
735 and then Attribute_Name (Expr) = Name_Address
737 Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible
742 -- Here we do not know if the value is acceptable. Strictly we don't
743 -- have to do anything, since if the alignment is bad, we have an
744 -- erroneous program. However we are allowed to check for erroneous
745 -- conditions and we decide to do this by default if the check is not
748 -- However, don't do the check if elaboration code is unwanted
750 if Restriction_Active (No_Elaboration_Code) then
753 -- Generate a check to raise PE if alignment may be inappropriate
756 -- If the original expression is a nonstatic constant, use the name
757 -- of the constant itself rather than duplicating its initialization
758 -- expression, which was extracted above.
760 -- Note: Expr is empty if the address-clause is applied to in-mode
761 -- actuals (allowed by 13.1(22)).
763 if not Present (Expr)
765 (Is_Entity_Name (Expression (AC))
766 and then Ekind (Entity (Expression (AC))) = E_Constant
767 and then Nkind (Parent (Entity (Expression (AC)))) =
768 N_Object_Declaration)
770 Expr := New_Copy_Tree (Expression (AC));
772 Remove_Side_Effects (Expr);
775 if No (Actions (N)) then
776 Set_Actions (N, New_List);
779 Prepend_To (Actions (N),
780 Make_Raise_Program_Error (Loc,
787 (RTE (RE_Integer_Address), Expr),
789 Make_Attribute_Reference (Loc,
790 Prefix => New_Occurrence_Of (E, Loc),
791 Attribute_Name => Name_Alignment)),
792 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
793 Reason => PE_Misaligned_Address_Value));
795 Warning_Msg := No_Error_Msg;
796 Analyze (First (Actions (N)), Suppress => All_Checks);
798 -- If the above raise action generated a warning message (for example
799 -- from Warn_On_Non_Local_Exception mode with the active restriction
800 -- No_Exception_Propagation).
802 if Warning_Msg /= No_Error_Msg then
804 -- If the expression has a known at compile time value, then
805 -- once we know the alignment of the type, we can check if the
806 -- exception will be raised or not, and if not, we don't need
807 -- the warning so we will kill the warning later on.
809 if Compile_Time_Known_Value (Expr) then
810 Alignment_Warnings.Append
811 ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
813 -- Add explanation of the warning generated by the check
817 ("\address value may be incompatible with alignment of "
827 -- If we have some missing run time component in configurable run time
828 -- mode then just skip the check (it is not required in any case).
830 when RE_Not_Available =>
832 end Apply_Address_Clause_Check;
834 -------------------------------------
835 -- Apply_Arithmetic_Overflow_Check --
836 -------------------------------------
838 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
840 -- Use old routine in almost all cases (the only case we are treating
841 -- specially is the case of a signed integer arithmetic op with the
842 -- overflow checking mode set to MINIMIZED or ELIMINATED).
844 if Overflow_Check_Mode = Strict
845 or else not Is_Signed_Integer_Arithmetic_Op (N)
847 Apply_Arithmetic_Overflow_Strict (N);
849 -- Otherwise use the new routine for the case of a signed integer
850 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
851 -- mode is MINIMIZED or ELIMINATED.
854 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
856 end Apply_Arithmetic_Overflow_Check;
858 --------------------------------------
859 -- Apply_Arithmetic_Overflow_Strict --
860 --------------------------------------
862 -- This routine is called only if the type is an integer type and an
863 -- arithmetic overflow check may be needed for op (add, subtract, or
864 -- multiply). This check is performed if Backend_Overflow_Checks_On_Target
865 -- is not enabled and Do_Overflow_Check is set. In this case we expand the
866 -- operation into a more complex sequence of tests that ensures that
867 -- overflow is properly caught.
869 -- This is used in CHECKED modes. It is identical to the code for this
870 -- cases before the big overflow earthquake, thus ensuring that in this
871 -- modes we have compatible behavior (and reliability) to what was there
872 -- before. It is also called for types other than signed integers, and if
873 -- the Do_Overflow_Check flag is off.
875 -- Note: we also call this routine if we decide in the MINIMIZED case
876 -- to give up and just generate an overflow check without any fuss.
878 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
879 Loc : constant Source_Ptr := Sloc (N);
880 Typ : constant Entity_Id := Etype (N);
881 Rtyp : constant Entity_Id := Root_Type (Typ);
884 -- Nothing to do if Do_Overflow_Check not set or overflow checks
887 if not Do_Overflow_Check (N) then
891 -- An interesting special case. If the arithmetic operation appears as
892 -- the operand of a type conversion:
896 -- and all the following conditions apply:
898 -- arithmetic operation is for a signed integer type
899 -- target type type1 is a static integer subtype
900 -- range of x and y are both included in the range of type1
901 -- range of x op y is included in the range of type1
902 -- size of type1 is at least twice the result size of op
904 -- then we don't do an overflow check in any case. Instead, we transform
905 -- the operation so that we end up with:
907 -- type1 (type1 (x) op type1 (y))
909 -- This avoids intermediate overflow before the conversion. It is
910 -- explicitly permitted by RM 3.5.4(24):
912 -- For the execution of a predefined operation of a signed integer
913 -- type, the implementation need not raise Constraint_Error if the
914 -- result is outside the base range of the type, so long as the
915 -- correct result is produced.
917 -- It's hard to imagine that any programmer counts on the exception
918 -- being raised in this case, and in any case it's wrong coding to
919 -- have this expectation, given the RM permission. Furthermore, other
920 -- Ada compilers do allow such out of range results.
922 -- Note that we do this transformation even if overflow checking is
923 -- off, since this is precisely about giving the "right" result and
924 -- avoiding the need for an overflow check.
926 -- Note: this circuit is partially redundant with respect to the similar
927 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
928 -- with cases that do not come through here. We still need the following
929 -- processing even with the Exp_Ch4 code in place, since we want to be
930 -- sure not to generate the arithmetic overflow check in these cases
931 -- (Exp_Ch4 would have a hard time removing them once generated).
933 if Is_Signed_Integer_Type (Typ)
934 and then Nkind (Parent (N)) = N_Type_Conversion
936 Conversion_Optimization : declare
937 Target_Type : constant Entity_Id :=
938 Base_Type (Entity (Subtype_Mark (Parent (N))));
952 if Is_Integer_Type (Target_Type)
953 and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
955 Tlo := Expr_Value (Type_Low_Bound (Target_Type));
956 Thi := Expr_Value (Type_High_Bound (Target_Type));
959 (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
961 (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
964 and then Tlo <= Llo and then Lhi <= Thi
965 and then Tlo <= Rlo and then Rhi <= Thi
967 Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
969 if VOK and then Tlo <= Vlo and then Vhi <= Thi then
970 Rewrite (Left_Opnd (N),
971 Make_Type_Conversion (Loc,
972 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
973 Expression => Relocate_Node (Left_Opnd (N))));
975 Rewrite (Right_Opnd (N),
976 Make_Type_Conversion (Loc,
977 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
978 Expression => Relocate_Node (Right_Opnd (N))));
980 -- Rewrite the conversion operand so that the original
981 -- node is retained, in order to avoid the warning for
982 -- redundant conversions in Resolve_Type_Conversion.
984 Rewrite (N, Relocate_Node (N));
986 Set_Etype (N, Target_Type);
988 Analyze_And_Resolve (Left_Opnd (N), Target_Type);
989 Analyze_And_Resolve (Right_Opnd (N), Target_Type);
991 -- Given that the target type is twice the size of the
992 -- source type, overflow is now impossible, so we can
993 -- safely kill the overflow check and return.
995 Set_Do_Overflow_Check (N, False);
1000 end Conversion_Optimization;
1003 -- Now see if an overflow check is required
1006 Siz : constant Int := UI_To_Int (Esize (Rtyp));
1007 Dsiz : constant Int := Siz * 2;
1014 -- Skip check if back end does overflow checks, or the overflow flag
1015 -- is not set anyway, or we are not doing code expansion, or the
1016 -- parent node is a type conversion whose operand is an arithmetic
1017 -- operation on signed integers on which the expander can promote
1018 -- later the operands to type Integer (see Expand_N_Type_Conversion).
1020 if Backend_Overflow_Checks_On_Target
1021 or else not Do_Overflow_Check (N)
1022 or else not Expander_Active
1023 or else (Present (Parent (N))
1024 and then Nkind (Parent (N)) = N_Type_Conversion
1025 and then Integer_Promotion_Possible (Parent (N)))
1030 -- Otherwise, generate the full general code for front end overflow
1031 -- detection, which works by doing arithmetic in a larger type:
1037 -- Typ (Checktyp (x) op Checktyp (y));
1039 -- where Typ is the type of the original expression, and Checktyp is
1040 -- an integer type of sufficient length to hold the largest possible
1043 -- If the size of check type exceeds the size of Long_Long_Integer,
1044 -- we use a different approach, expanding to:
1046 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1048 -- where xxx is Add, Multiply or Subtract as appropriate
1050 -- Find check type if one exists
1052 if Dsiz <= Standard_Integer_Size then
1053 Ctyp := Standard_Integer;
1055 elsif Dsiz <= Standard_Long_Long_Integer_Size then
1056 Ctyp := Standard_Long_Long_Integer;
1058 -- No check type exists, use runtime call
1061 if Nkind (N) = N_Op_Add then
1062 Cent := RE_Add_With_Ovflo_Check;
1064 elsif Nkind (N) = N_Op_Multiply then
1065 Cent := RE_Multiply_With_Ovflo_Check;
1068 pragma Assert (Nkind (N) = N_Op_Subtract);
1069 Cent := RE_Subtract_With_Ovflo_Check;
1074 Make_Function_Call (Loc,
1075 Name => New_Occurrence_Of (RTE (Cent), Loc),
1076 Parameter_Associations => New_List (
1077 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
1078 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
1080 Analyze_And_Resolve (N, Typ);
1084 -- If we fall through, we have the case where we do the arithmetic
1085 -- in the next higher type and get the check by conversion. In these
1086 -- cases Ctyp is set to the type to be used as the check type.
1088 Opnod := Relocate_Node (N);
1090 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
1093 Set_Etype (Opnd, Ctyp);
1094 Set_Analyzed (Opnd, True);
1095 Set_Left_Opnd (Opnod, Opnd);
1097 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
1100 Set_Etype (Opnd, Ctyp);
1101 Set_Analyzed (Opnd, True);
1102 Set_Right_Opnd (Opnod, Opnd);
1104 -- The type of the operation changes to the base type of the check
1105 -- type, and we reset the overflow check indication, since clearly no
1106 -- overflow is possible now that we are using a double length type.
1107 -- We also set the Analyzed flag to avoid a recursive attempt to
1110 Set_Etype (Opnod, Base_Type (Ctyp));
1111 Set_Do_Overflow_Check (Opnod, False);
1112 Set_Analyzed (Opnod, True);
1114 -- Now build the outer conversion
1116 Opnd := OK_Convert_To (Typ, Opnod);
1118 Set_Etype (Opnd, Typ);
1120 -- In the discrete type case, we directly generate the range check
1121 -- for the outer operand. This range check will implement the
1122 -- required overflow check.
1124 if Is_Discrete_Type (Typ) then
1126 Generate_Range_Check
1127 (Expression (N), Typ, CE_Overflow_Check_Failed);
1129 -- For other types, we enable overflow checking on the conversion,
1130 -- after setting the node as analyzed to prevent recursive attempts
1131 -- to expand the conversion node.
1134 Set_Analyzed (Opnd, True);
1135 Enable_Overflow_Check (Opnd);
1140 when RE_Not_Available =>
1143 end Apply_Arithmetic_Overflow_Strict;
1145 ----------------------------------------------------
1146 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1147 ----------------------------------------------------
1149 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
1150 pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
1152 Loc : constant Source_Ptr := Sloc (Op);
1153 P : constant Node_Id := Parent (Op);
1155 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
1156 -- Operands and results are of this type when we convert
1158 Result_Type : constant Entity_Id := Etype (Op);
1159 -- Original result type
1161 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1162 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
1165 -- Ranges of values for result
1168 -- Nothing to do if our parent is one of the following:
1170 -- Another signed integer arithmetic op
1171 -- A membership operation
1172 -- A comparison operation
1174 -- In all these cases, we will process at the higher level (and then
1175 -- this node will be processed during the downwards recursion that
1176 -- is part of the processing in Minimize_Eliminate_Overflows).
1178 if Is_Signed_Integer_Arithmetic_Op (P)
1179 or else Nkind (P) in N_Membership_Test
1180 or else Nkind (P) in N_Op_Compare
1182 -- This is also true for an alternative in a case expression
1184 or else Nkind (P) = N_Case_Expression_Alternative
1186 -- This is also true for a range operand in a membership test
1188 or else (Nkind (P) = N_Range
1189 and then Nkind (Parent (P)) in N_Membership_Test)
1191 -- If_Expressions and Case_Expressions are treated as arithmetic
1192 -- ops, but if they appear in an assignment or similar contexts
1193 -- there is no overflow check that starts from that parent node,
1194 -- so apply check now.
1196 if Nkind_In (P, N_If_Expression, N_Case_Expression)
1197 and then not Is_Signed_Integer_Arithmetic_Op (Parent (P))
1205 -- Otherwise, we have a top level arithmetic operation node, and this
1206 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1207 -- modes. This is the case where we tell the machinery not to move into
1208 -- Bignum mode at this top level (of course the top level operation
1209 -- will still be in Bignum mode if either of its operands are of type
1212 Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
1214 -- That call may but does not necessarily change the result type of Op.
1215 -- It is the job of this routine to undo such changes, so that at the
1216 -- top level, we have the proper type. This "undoing" is a point at
1217 -- which a final overflow check may be applied.
1219 -- If the result type was not fiddled we are all set. We go to base
1220 -- types here because things may have been rewritten to generate the
1221 -- base type of the operand types.
1223 if Base_Type (Etype (Op)) = Base_Type (Result_Type) then
1228 elsif Is_RTE (Etype (Op), RE_Bignum) then
1230 -- We need a sequence that looks like:
1232 -- Rnn : Result_Type;
1235 -- M : Mark_Id := SS_Mark;
1237 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1241 -- This block is inserted (using Insert_Actions), and then the node
1242 -- is replaced with a reference to Rnn.
1244 -- If our parent is a conversion node then there is no point in
1245 -- generating a conversion to Result_Type. Instead, we let the parent
1246 -- handle this. Note that this special case is not just about
1247 -- optimization. Consider
1251 -- X := Long_Long_Integer'Base (A * (B ** C));
1253 -- Now the product may fit in Long_Long_Integer but not in Integer.
1254 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1255 -- overflow exception for this intermediate value.
1258 Blk : constant Node_Id := Make_Bignum_Block (Loc);
1259 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
1265 RHS := Convert_From_Bignum (Op);
1267 if Nkind (P) /= N_Type_Conversion then
1268 Convert_To_And_Rewrite (Result_Type, RHS);
1269 Rtype := Result_Type;
1271 -- Interesting question, do we need a check on that conversion
1272 -- operation. Answer, not if we know the result is in range.
1273 -- At the moment we are not taking advantage of this. To be
1274 -- looked at later ???
1281 (First (Statements (Handled_Statement_Sequence (Blk))),
1282 Make_Assignment_Statement (Loc,
1283 Name => New_Occurrence_Of (Rnn, Loc),
1284 Expression => RHS));
1286 Insert_Actions (Op, New_List (
1287 Make_Object_Declaration (Loc,
1288 Defining_Identifier => Rnn,
1289 Object_Definition => New_Occurrence_Of (Rtype, Loc)),
1292 Rewrite (Op, New_Occurrence_Of (Rnn, Loc));
1293 Analyze_And_Resolve (Op);
1296 -- Here we know the result is Long_Long_Integer'Base, or that it has
1297 -- been rewritten because the parent operation is a conversion. See
1298 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1302 (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion);
1304 -- All we need to do here is to convert the result to the proper
1305 -- result type. As explained above for the Bignum case, we can
1306 -- omit this if our parent is a type conversion.
1308 if Nkind (P) /= N_Type_Conversion then
1309 Convert_To_And_Rewrite (Result_Type, Op);
1312 Analyze_And_Resolve (Op);
1314 end Apply_Arithmetic_Overflow_Minimized_Eliminated;
1316 ----------------------------
1317 -- Apply_Constraint_Check --
1318 ----------------------------
1320 procedure Apply_Constraint_Check
1323 No_Sliding : Boolean := False)
1325 Desig_Typ : Entity_Id;
1328 -- No checks inside a generic (check the instantiations)
1330 if Inside_A_Generic then
1334 -- Apply required constraint checks
1336 if Is_Scalar_Type (Typ) then
1337 Apply_Scalar_Range_Check (N, Typ);
1339 elsif Is_Array_Type (Typ) then
1341 -- A useful optimization: an aggregate with only an others clause
1342 -- always has the right bounds.
1344 if Nkind (N) = N_Aggregate
1345 and then No (Expressions (N))
1347 (First (Choices (First (Component_Associations (N)))))
1353 if Is_Constrained (Typ) then
1354 Apply_Length_Check (N, Typ);
1357 Apply_Range_Check (N, Typ);
1360 Apply_Range_Check (N, Typ);
1363 elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
1364 and then Has_Discriminants (Base_Type (Typ))
1365 and then Is_Constrained (Typ)
1367 Apply_Discriminant_Check (N, Typ);
1369 elsif Is_Access_Type (Typ) then
1371 Desig_Typ := Designated_Type (Typ);
1373 -- No checks necessary if expression statically null
1375 if Known_Null (N) then
1376 if Can_Never_Be_Null (Typ) then
1377 Install_Null_Excluding_Check (N);
1380 -- No sliding possible on access to arrays
1382 elsif Is_Array_Type (Desig_Typ) then
1383 if Is_Constrained (Desig_Typ) then
1384 Apply_Length_Check (N, Typ);
1387 Apply_Range_Check (N, Typ);
1389 -- Do not install a discriminant check for a constrained subtype
1390 -- created for an unconstrained nominal type because the subtype
1391 -- has the correct constraints by construction.
1393 elsif Has_Discriminants (Base_Type (Desig_Typ))
1394 and then Is_Constrained (Desig_Typ)
1395 and then not Is_Constr_Subt_For_U_Nominal (Desig_Typ)
1397 Apply_Discriminant_Check (N, Typ);
1400 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1401 -- this check if the constraint node is illegal, as shown by having
1402 -- an error posted. This additional guard prevents cascaded errors
1403 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1405 if Can_Never_Be_Null (Typ)
1406 and then not Can_Never_Be_Null (Etype (N))
1407 and then not Error_Posted (N)
1409 Install_Null_Excluding_Check (N);
1412 end Apply_Constraint_Check;
1414 ------------------------------
1415 -- Apply_Discriminant_Check --
1416 ------------------------------
1418 procedure Apply_Discriminant_Check
1421 Lhs : Node_Id := Empty)
1423 Loc : constant Source_Ptr := Sloc (N);
1424 Do_Access : constant Boolean := Is_Access_Type (Typ);
1425 S_Typ : Entity_Id := Etype (N);
1429 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
1430 -- A heap object with an indefinite subtype is constrained by its
1431 -- initial value, and assigning to it requires a constraint_check.
1432 -- The target may be an explicit dereference, or a renaming of one.
1434 function Is_Aliased_Unconstrained_Component return Boolean;
1435 -- It is possible for an aliased component to have a nominal
1436 -- unconstrained subtype (through instantiation). If this is a
1437 -- discriminated component assigned in the expansion of an aggregate
1438 -- in an initialization, the check must be suppressed. This unusual
1439 -- situation requires a predicate of its own.
1441 ----------------------------------
1442 -- Denotes_Explicit_Dereference --
1443 ----------------------------------
1445 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
1448 Nkind (Obj) = N_Explicit_Dereference
1450 (Is_Entity_Name (Obj)
1451 and then Present (Renamed_Object (Entity (Obj)))
1452 and then Nkind (Renamed_Object (Entity (Obj))) =
1453 N_Explicit_Dereference);
1454 end Denotes_Explicit_Dereference;
1456 ----------------------------------------
1457 -- Is_Aliased_Unconstrained_Component --
1458 ----------------------------------------
1460 function Is_Aliased_Unconstrained_Component return Boolean is
1465 if Nkind (Lhs) /= N_Selected_Component then
1468 Comp := Entity (Selector_Name (Lhs));
1469 Pref := Prefix (Lhs);
1472 if Ekind (Comp) /= E_Component
1473 or else not Is_Aliased (Comp)
1478 return not Comes_From_Source (Pref)
1479 and then In_Instance
1480 and then not Is_Constrained (Etype (Comp));
1481 end Is_Aliased_Unconstrained_Component;
1483 -- Start of processing for Apply_Discriminant_Check
1487 T_Typ := Designated_Type (Typ);
1492 -- If the expression is a function call that returns a limited object
1493 -- it cannot be copied. It is not clear how to perform the proper
1494 -- discriminant check in this case because the discriminant value must
1495 -- be retrieved from the constructed object itself.
1497 if Nkind (N) = N_Function_Call
1498 and then Is_Limited_Type (Typ)
1499 and then Is_Entity_Name (Name (N))
1500 and then Returns_By_Ref (Entity (Name (N)))
1505 -- Only apply checks when generating code and discriminant checks are
1506 -- not suppressed. In GNATprove mode, we do not apply the checks, but we
1507 -- still analyze the expression to possibly issue errors on SPARK code
1508 -- when a run-time error can be detected at compile time.
1510 if not GNATprove_Mode then
1511 if not Expander_Active
1512 or else Discriminant_Checks_Suppressed (T_Typ)
1518 -- No discriminant checks necessary for an access when expression is
1519 -- statically Null. This is not only an optimization, it is fundamental
1520 -- because otherwise discriminant checks may be generated in init procs
1521 -- for types containing an access to a not-yet-frozen record, causing a
1522 -- deadly forward reference.
1524 -- Also, if the expression is of an access type whose designated type is
1525 -- incomplete, then the access value must be null and we suppress the
1528 if Known_Null (N) then
1531 elsif Is_Access_Type (S_Typ) then
1532 S_Typ := Designated_Type (S_Typ);
1534 if Ekind (S_Typ) = E_Incomplete_Type then
1539 -- If an assignment target is present, then we need to generate the
1540 -- actual subtype if the target is a parameter or aliased object with
1541 -- an unconstrained nominal subtype.
1543 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1544 -- subtype to the parameter and dereference cases, since other aliased
1545 -- objects are unconstrained (unless the nominal subtype is explicitly
1549 and then (Present (Param_Entity (Lhs))
1550 or else (Ada_Version < Ada_2005
1551 and then not Is_Constrained (T_Typ)
1552 and then Is_Aliased_View (Lhs)
1553 and then not Is_Aliased_Unconstrained_Component)
1554 or else (Ada_Version >= Ada_2005
1555 and then not Is_Constrained (T_Typ)
1556 and then Denotes_Explicit_Dereference (Lhs)
1557 and then Nkind (Original_Node (Lhs)) /=
1560 T_Typ := Get_Actual_Subtype (Lhs);
1563 -- Nothing to do if the type is unconstrained (this is the case where
1564 -- the actual subtype in the RM sense of N is unconstrained and no check
1567 if not Is_Constrained (T_Typ) then
1570 -- Ada 2005: nothing to do if the type is one for which there is a
1571 -- partial view that is constrained.
1573 elsif Ada_Version >= Ada_2005
1574 and then Object_Type_Has_Constrained_Partial_View
1575 (Typ => Base_Type (T_Typ),
1576 Scop => Current_Scope)
1581 -- Nothing to do if the type is an Unchecked_Union
1583 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1587 -- Suppress checks if the subtypes are the same. The check must be
1588 -- preserved in an assignment to a formal, because the constraint is
1589 -- given by the actual.
1591 if Nkind (Original_Node (N)) /= N_Allocator
1593 or else not Is_Entity_Name (Lhs)
1594 or else No (Param_Entity (Lhs)))
1597 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1598 and then not Is_Aliased_View (Lhs)
1603 -- We can also eliminate checks on allocators with a subtype mark that
1604 -- coincides with the context type. The context type may be a subtype
1605 -- without a constraint (common case, a generic actual).
1607 elsif Nkind (Original_Node (N)) = N_Allocator
1608 and then Is_Entity_Name (Expression (Original_Node (N)))
1611 Alloc_Typ : constant Entity_Id :=
1612 Entity (Expression (Original_Node (N)));
1615 if Alloc_Typ = T_Typ
1616 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1617 and then Is_Entity_Name (
1618 Subtype_Indication (Parent (T_Typ)))
1619 and then Alloc_Typ = Base_Type (T_Typ))
1627 -- See if we have a case where the types are both constrained, and all
1628 -- the constraints are constants. In this case, we can do the check
1629 -- successfully at compile time.
1631 -- We skip this check for the case where the node is rewritten as
1632 -- an allocator, because it already carries the context subtype,
1633 -- and extracting the discriminants from the aggregate is messy.
1635 if Is_Constrained (S_Typ)
1636 and then Nkind (Original_Node (N)) /= N_Allocator
1646 -- S_Typ may not have discriminants in the case where it is a
1647 -- private type completed by a default discriminated type. In that
1648 -- case, we need to get the constraints from the underlying type.
1649 -- If the underlying type is unconstrained (i.e. has no default
1650 -- discriminants) no check is needed.
1652 if Has_Discriminants (S_Typ) then
1653 Discr := First_Discriminant (S_Typ);
1654 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1657 Discr := First_Discriminant (Underlying_Type (S_Typ));
1660 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1666 -- A further optimization: if T_Typ is derived from S_Typ
1667 -- without imposing a constraint, no check is needed.
1669 if Nkind (Original_Node (Parent (T_Typ))) =
1670 N_Full_Type_Declaration
1673 Type_Def : constant Node_Id :=
1674 Type_Definition (Original_Node (Parent (T_Typ)));
1676 if Nkind (Type_Def) = N_Derived_Type_Definition
1677 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1678 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1686 -- Constraint may appear in full view of type
1688 if Ekind (T_Typ) = E_Private_Subtype
1689 and then Present (Full_View (T_Typ))
1692 First_Elmt (Discriminant_Constraint (Full_View (T_Typ)));
1695 First_Elmt (Discriminant_Constraint (T_Typ));
1698 while Present (Discr) loop
1699 ItemS := Node (DconS);
1700 ItemT := Node (DconT);
1702 -- For a discriminated component type constrained by the
1703 -- current instance of an enclosing type, there is no
1704 -- applicable discriminant check.
1706 if Nkind (ItemT) = N_Attribute_Reference
1707 and then Is_Access_Type (Etype (ItemT))
1708 and then Is_Entity_Name (Prefix (ItemT))
1709 and then Is_Type (Entity (Prefix (ItemT)))
1714 -- If the expressions for the discriminants are identical
1715 -- and it is side-effect free (for now just an entity),
1716 -- this may be a shared constraint, e.g. from a subtype
1717 -- without a constraint introduced as a generic actual.
1718 -- Examine other discriminants if any.
1721 and then Is_Entity_Name (ItemS)
1725 elsif not Is_OK_Static_Expression (ItemS)
1726 or else not Is_OK_Static_Expression (ItemT)
1730 elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
1731 if Do_Access then -- needs run-time check.
1734 Apply_Compile_Time_Constraint_Error
1735 (N, "incorrect value for discriminant&??",
1736 CE_Discriminant_Check_Failed, Ent => Discr);
1743 Next_Discriminant (Discr);
1752 -- In GNATprove mode, we do not apply the checks
1754 if GNATprove_Mode then
1758 -- Here we need a discriminant check. First build the expression
1759 -- for the comparisons of the discriminants:
1761 -- (n.disc1 /= typ.disc1) or else
1762 -- (n.disc2 /= typ.disc2) or else
1764 -- (n.discn /= typ.discn)
1766 Cond := Build_Discriminant_Checks (N, T_Typ);
1768 -- If Lhs is set and is a parameter, then the condition is guarded by:
1769 -- lhs'constrained and then (condition built above)
1771 if Present (Param_Entity (Lhs)) then
1775 Make_Attribute_Reference (Loc,
1776 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1777 Attribute_Name => Name_Constrained),
1778 Right_Opnd => Cond);
1782 Cond := Guard_Access (Cond, Loc, N);
1786 Make_Raise_Constraint_Error (Loc,
1788 Reason => CE_Discriminant_Check_Failed));
1789 end Apply_Discriminant_Check;
1791 -------------------------
1792 -- Apply_Divide_Checks --
1793 -------------------------
1795 procedure Apply_Divide_Checks (N : Node_Id) is
1796 Loc : constant Source_Ptr := Sloc (N);
1797 Typ : constant Entity_Id := Etype (N);
1798 Left : constant Node_Id := Left_Opnd (N);
1799 Right : constant Node_Id := Right_Opnd (N);
1801 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1802 -- Current overflow checking mode
1812 pragma Warnings (Off, Lhi);
1813 -- Don't actually use this value
1816 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1817 -- operating on signed integer types, then the only thing this routine
1818 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1819 -- procedure will (possibly later on during recursive downward calls),
1820 -- ensure that any needed overflow/division checks are properly applied.
1822 if Mode in Minimized_Or_Eliminated
1823 and then Is_Signed_Integer_Type (Typ)
1825 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
1829 -- Proceed here in SUPPRESSED or CHECKED modes
1832 and then not Backend_Divide_Checks_On_Target
1833 and then Check_Needed (Right, Division_Check)
1835 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
1837 -- Deal with division check
1839 if Do_Division_Check (N)
1840 and then not Division_Checks_Suppressed (Typ)
1842 Apply_Division_Check (N, Rlo, Rhi, ROK);
1845 -- Deal with overflow check
1847 if Do_Overflow_Check (N)
1848 and then not Overflow_Checks_Suppressed (Etype (N))
1850 Set_Do_Overflow_Check (N, False);
1852 -- Test for extremely annoying case of xxx'First divided by -1
1853 -- for division of signed integer types (only overflow case).
1855 if Nkind (N) = N_Op_Divide
1856 and then Is_Signed_Integer_Type (Typ)
1858 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
1859 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1861 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1863 ((not LOK) or else (Llo = LLB))
1865 -- Ensure that expressions are not evaluated twice (once
1866 -- for their runtime checks and once for their regular
1869 Force_Evaluation (Left, Mode => Strict);
1870 Force_Evaluation (Right, Mode => Strict);
1873 Make_Raise_Constraint_Error (Loc,
1879 Duplicate_Subexpr_Move_Checks (Left),
1880 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1884 Left_Opnd => Duplicate_Subexpr (Right),
1885 Right_Opnd => Make_Integer_Literal (Loc, -1))),
1887 Reason => CE_Overflow_Check_Failed));
1892 end Apply_Divide_Checks;
1894 --------------------------
1895 -- Apply_Division_Check --
1896 --------------------------
1898 procedure Apply_Division_Check
1904 pragma Assert (Do_Division_Check (N));
1906 Loc : constant Source_Ptr := Sloc (N);
1907 Right : constant Node_Id := Right_Opnd (N);
1912 and then not Backend_Divide_Checks_On_Target
1913 and then Check_Needed (Right, Division_Check)
1915 -- See if division by zero possible, and if so generate test. This
1916 -- part of the test is not controlled by the -gnato switch, since it
1917 -- is a Division_Check and not an Overflow_Check.
1919 and then Do_Division_Check (N)
1921 Set_Do_Division_Check (N, False);
1923 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1924 if Is_Floating_Point_Type (Etype (N)) then
1925 Opnd := Make_Real_Literal (Loc, Ureal_0);
1927 Opnd := Make_Integer_Literal (Loc, 0);
1931 Make_Raise_Constraint_Error (Loc,
1934 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1935 Right_Opnd => Opnd),
1936 Reason => CE_Divide_By_Zero));
1939 end Apply_Division_Check;
1941 ----------------------------------
1942 -- Apply_Float_Conversion_Check --
1943 ----------------------------------
1945 -- Let F and I be the source and target types of the conversion. The RM
1946 -- specifies that a floating-point value X is rounded to the nearest
1947 -- integer, with halfway cases being rounded away from zero. The rounded
1948 -- value of X is checked against I'Range.
1950 -- The catch in the above paragraph is that there is no good way to know
1951 -- whether the round-to-integer operation resulted in overflow. A remedy is
1952 -- to perform a range check in the floating-point domain instead, however:
1954 -- (1) The bounds may not be known at compile time
1955 -- (2) The check must take into account rounding or truncation.
1956 -- (3) The range of type I may not be exactly representable in F.
1957 -- (4) For the rounding case, The end-points I'First - 0.5 and
1958 -- I'Last + 0.5 may or may not be in range, depending on the
1959 -- sign of I'First and I'Last.
1960 -- (5) X may be a NaN, which will fail any comparison
1962 -- The following steps correctly convert X with rounding:
1964 -- (1) If either I'First or I'Last is not known at compile time, use
1965 -- I'Base instead of I in the next three steps and perform a
1966 -- regular range check against I'Range after conversion.
1967 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1968 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1969 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1970 -- In other words, take one of the closest floating-point numbers
1971 -- (which is an integer value) to I'First, and see if it is in
1973 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1974 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1975 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1976 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1977 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1979 -- For the truncating case, replace steps (2) and (3) as follows:
1980 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1981 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1983 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1984 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1987 procedure Apply_Float_Conversion_Check
1989 Target_Typ : Entity_Id)
1991 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1992 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1993 Loc : constant Source_Ptr := Sloc (Ck_Node);
1994 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1995 Target_Base : constant Entity_Id :=
1996 Implementation_Base_Type (Target_Typ);
1998 Par : constant Node_Id := Parent (Ck_Node);
1999 pragma Assert (Nkind (Par) = N_Type_Conversion);
2000 -- Parent of check node, must be a type conversion
2002 Truncate : constant Boolean := Float_Truncate (Par);
2003 Max_Bound : constant Uint :=
2005 (Machine_Radix_Value (Expr_Type),
2006 Machine_Mantissa_Value (Expr_Type) - 1) - 1;
2008 -- Largest bound, so bound plus or minus half is a machine number of F
2010 Ifirst, Ilast : Uint;
2011 -- Bounds of integer type
2014 -- Bounds to check in floating-point domain
2016 Lo_OK, Hi_OK : Boolean;
2017 -- True iff Lo resp. Hi belongs to I'Range
2019 Lo_Chk, Hi_Chk : Node_Id;
2020 -- Expressions that are False iff check fails
2022 Reason : RT_Exception_Code;
2025 -- We do not need checks if we are not generating code (i.e. the full
2026 -- expander is not active). In SPARK mode, we specifically don't want
2027 -- the frontend to expand these checks, which are dealt with directly
2028 -- in the formal verification backend.
2030 if not Expander_Active then
2034 -- Here we will generate an explicit range check, so we don't want to
2035 -- set the Do_Range check flag, since the range check is taken care of
2036 -- by the code we will generate.
2038 Set_Do_Range_Check (Ck_Node, False);
2040 if not Compile_Time_Known_Value (LB)
2041 or not Compile_Time_Known_Value (HB)
2044 -- First check that the value falls in the range of the base type,
2045 -- to prevent overflow during conversion and then perform a
2046 -- regular range check against the (dynamic) bounds.
2048 pragma Assert (Target_Base /= Target_Typ);
2050 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
2053 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
2054 Set_Etype (Temp, Target_Base);
2056 Insert_Action (Parent (Par),
2057 Make_Object_Declaration (Loc,
2058 Defining_Identifier => Temp,
2059 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
2060 Expression => New_Copy_Tree (Par)),
2061 Suppress => All_Checks);
2064 Make_Raise_Constraint_Error (Loc,
2067 Left_Opnd => New_Occurrence_Of (Temp, Loc),
2068 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
2069 Reason => CE_Range_Check_Failed));
2070 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
2076 -- Get the (static) bounds of the target type
2078 Ifirst := Expr_Value (LB);
2079 Ilast := Expr_Value (HB);
2081 -- A simple optimization: if the expression is a universal literal,
2082 -- we can do the comparison with the bounds and the conversion to
2083 -- an integer type statically. The range checks are unchanged.
2085 if Nkind (Ck_Node) = N_Real_Literal
2086 and then Etype (Ck_Node) = Universal_Real
2087 and then Is_Integer_Type (Target_Typ)
2090 Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
2093 if Int_Val <= Ilast and then Int_Val >= Ifirst then
2095 -- Conversion is safe
2097 Rewrite (Parent (Ck_Node),
2098 Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
2099 Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
2105 -- Check against lower bound
2107 if Truncate and then Ifirst > 0 then
2108 Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
2112 Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
2115 elsif abs (Ifirst) < Max_Bound then
2116 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
2117 Lo_OK := (Ifirst > 0);
2120 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
2121 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
2126 -- Lo_Chk := (X >= Lo)
2128 Lo_Chk := Make_Op_Ge (Loc,
2129 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2130 Right_Opnd => Make_Real_Literal (Loc, Lo));
2133 -- Lo_Chk := (X > Lo)
2135 Lo_Chk := Make_Op_Gt (Loc,
2136 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2137 Right_Opnd => Make_Real_Literal (Loc, Lo));
2140 -- Check against higher bound
2142 if Truncate and then Ilast < 0 then
2143 Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
2147 Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
2150 elsif abs (Ilast) < Max_Bound then
2151 Hi := UR_From_Uint (Ilast) + Ureal_Half;
2152 Hi_OK := (Ilast < 0);
2154 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
2155 Hi_OK := (Hi <= UR_From_Uint (Ilast));
2160 -- Hi_Chk := (X <= Hi)
2162 Hi_Chk := Make_Op_Le (Loc,
2163 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2164 Right_Opnd => Make_Real_Literal (Loc, Hi));
2167 -- Hi_Chk := (X < Hi)
2169 Hi_Chk := Make_Op_Lt (Loc,
2170 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2171 Right_Opnd => Make_Real_Literal (Loc, Hi));
2174 -- If the bounds of the target type are the same as those of the base
2175 -- type, the check is an overflow check as a range check is not
2176 -- performed in these cases.
2178 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
2179 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
2181 Reason := CE_Overflow_Check_Failed;
2183 Reason := CE_Range_Check_Failed;
2186 -- Raise CE if either conditions does not hold
2188 Insert_Action (Ck_Node,
2189 Make_Raise_Constraint_Error (Loc,
2190 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
2192 end Apply_Float_Conversion_Check;
2194 ------------------------
2195 -- Apply_Length_Check --
2196 ------------------------
2198 procedure Apply_Length_Check
2200 Target_Typ : Entity_Id;
2201 Source_Typ : Entity_Id := Empty)
2204 Apply_Selected_Length_Checks
2205 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2206 end Apply_Length_Check;
2208 -------------------------------------
2209 -- Apply_Parameter_Aliasing_Checks --
2210 -------------------------------------
2212 procedure Apply_Parameter_Aliasing_Checks
2216 Loc : constant Source_Ptr := Sloc (Call);
2218 function May_Cause_Aliasing
2219 (Formal_1 : Entity_Id;
2220 Formal_2 : Entity_Id) return Boolean;
2221 -- Determine whether two formal parameters can alias each other
2222 -- depending on their modes.
2224 function Original_Actual (N : Node_Id) return Node_Id;
2225 -- The expander may replace an actual with a temporary for the sake of
2226 -- side effect removal. The temporary may hide a potential aliasing as
2227 -- it does not share the address of the actual. This routine attempts
2228 -- to retrieve the original actual.
2230 procedure Overlap_Check
2231 (Actual_1 : Node_Id;
2233 Formal_1 : Entity_Id;
2234 Formal_2 : Entity_Id;
2235 Check : in out Node_Id);
2236 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2237 -- If detailed exception messages are enabled, the check is augmented to
2238 -- provide information about the names of the corresponding formals. See
2239 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2240 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2241 -- Check contains all and-ed simple tests generated so far or remains
2242 -- unchanged in the case of detailed exception messaged.
2244 ------------------------
2245 -- May_Cause_Aliasing --
2246 ------------------------
2248 function May_Cause_Aliasing
2249 (Formal_1 : Entity_Id;
2250 Formal_2 : Entity_Id) return Boolean
2253 -- The following combination cannot lead to aliasing
2255 -- Formal 1 Formal 2
2258 if Ekind (Formal_1) = E_In_Parameter
2260 Ekind (Formal_2) = E_In_Parameter
2264 -- The following combinations may lead to aliasing
2266 -- Formal 1 Formal 2
2276 end May_Cause_Aliasing;
2278 ---------------------
2279 -- Original_Actual --
2280 ---------------------
2282 function Original_Actual (N : Node_Id) return Node_Id is
2284 if Nkind (N) = N_Type_Conversion then
2285 return Expression (N);
2287 -- The expander created a temporary to capture the result of a type
2288 -- conversion where the expression is the real actual.
2290 elsif Nkind (N) = N_Identifier
2291 and then Present (Original_Node (N))
2292 and then Nkind (Original_Node (N)) = N_Type_Conversion
2294 return Expression (Original_Node (N));
2298 end Original_Actual;
2304 procedure Overlap_Check
2305 (Actual_1 : Node_Id;
2307 Formal_1 : Entity_Id;
2308 Formal_2 : Entity_Id;
2309 Check : in out Node_Id)
2312 ID_Casing : constant Casing_Type :=
2313 Identifier_Casing (Source_Index (Current_Sem_Unit));
2317 -- Actual_1'Overlaps_Storage (Actual_2)
2320 Make_Attribute_Reference (Loc,
2321 Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
2322 Attribute_Name => Name_Overlaps_Storage,
2324 New_List (New_Copy_Tree (Original_Actual (Actual_2))));
2326 -- Generate the following check when detailed exception messages are
2329 -- if Actual_1'Overlaps_Storage (Actual_2) then
2330 -- raise Program_Error with <detailed message>;
2333 if Exception_Extra_Info then
2336 -- Do not generate location information for internal calls
2338 if Comes_From_Source (Call) then
2339 Store_String_Chars (Build_Location_String (Loc));
2340 Store_String_Char (' ');
2343 Store_String_Chars ("aliased parameters, actuals for """);
2345 Get_Name_String (Chars (Formal_1));
2346 Set_Casing (ID_Casing);
2347 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2349 Store_String_Chars (""" and """);
2351 Get_Name_String (Chars (Formal_2));
2352 Set_Casing (ID_Casing);
2353 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2355 Store_String_Chars (""" overlap");
2357 Insert_Action (Call,
2358 Make_If_Statement (Loc,
2360 Then_Statements => New_List (
2361 Make_Raise_Statement (Loc,
2363 New_Occurrence_Of (Standard_Program_Error, Loc),
2364 Expression => Make_String_Literal (Loc, End_String)))));
2366 -- Create a sequence of overlapping checks by and-ing them all
2376 Right_Opnd => Cond);
2386 Formal_1 : Entity_Id;
2387 Formal_2 : Entity_Id;
2388 Orig_Act_1 : Node_Id;
2389 Orig_Act_2 : Node_Id;
2391 -- Start of processing for Apply_Parameter_Aliasing_Checks
2396 Actual_1 := First_Actual (Call);
2397 Formal_1 := First_Formal (Subp);
2398 while Present (Actual_1) and then Present (Formal_1) loop
2399 Orig_Act_1 := Original_Actual (Actual_1);
2401 -- Ensure that the actual is an object that is not passed by value.
2402 -- Elementary types are always passed by value, therefore actuals of
2403 -- such types cannot lead to aliasing. An aggregate is an object in
2404 -- Ada 2012, but an actual that is an aggregate cannot overlap with
2405 -- another actual. A type that is By_Reference (such as an array of
2406 -- controlled types) is not subject to the check because any update
2407 -- will be done in place and a subsequent read will always see the
2408 -- correct value, see RM 6.2 (12/3).
2410 if Nkind (Orig_Act_1) = N_Aggregate
2411 or else (Nkind (Orig_Act_1) = N_Qualified_Expression
2412 and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
2416 elsif Is_Object_Reference (Orig_Act_1)
2417 and then not Is_Elementary_Type (Etype (Orig_Act_1))
2418 and then not Is_By_Reference_Type (Etype (Orig_Act_1))
2420 Actual_2 := Next_Actual (Actual_1);
2421 Formal_2 := Next_Formal (Formal_1);
2422 while Present (Actual_2) and then Present (Formal_2) loop
2423 Orig_Act_2 := Original_Actual (Actual_2);
2425 -- The other actual we are testing against must also denote
2426 -- a non pass-by-value object. Generate the check only when
2427 -- the mode of the two formals may lead to aliasing.
2429 if Is_Object_Reference (Orig_Act_2)
2430 and then not Is_Elementary_Type (Etype (Orig_Act_2))
2431 and then May_Cause_Aliasing (Formal_1, Formal_2)
2433 Remove_Side_Effects (Actual_1);
2434 Remove_Side_Effects (Actual_2);
2437 (Actual_1 => Actual_1,
2438 Actual_2 => Actual_2,
2439 Formal_1 => Formal_1,
2440 Formal_2 => Formal_2,
2444 Next_Actual (Actual_2);
2445 Next_Formal (Formal_2);
2449 Next_Actual (Actual_1);
2450 Next_Formal (Formal_1);
2453 -- Place a simple check right before the call
2455 if Present (Check) and then not Exception_Extra_Info then
2456 Insert_Action (Call,
2457 Make_Raise_Program_Error (Loc,
2459 Reason => PE_Aliased_Parameters));
2461 end Apply_Parameter_Aliasing_Checks;
2463 -------------------------------------
2464 -- Apply_Parameter_Validity_Checks --
2465 -------------------------------------
2467 procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
2468 Subp_Decl : Node_Id;
2470 procedure Add_Validity_Check
2471 (Formal : Entity_Id;
2473 For_Result : Boolean := False);
2474 -- Add a single 'Valid[_Scalars] check which verifies the initialization
2475 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2476 -- Set flag For_Result when to verify the result of a function.
2478 ------------------------
2479 -- Add_Validity_Check --
2480 ------------------------
2482 procedure Add_Validity_Check
2483 (Formal : Entity_Id;
2485 For_Result : Boolean := False)
2487 procedure Build_Pre_Post_Condition (Expr : Node_Id);
2488 -- Create a pre/postcondition pragma that tests expression Expr
2490 ------------------------------
2491 -- Build_Pre_Post_Condition --
2492 ------------------------------
2494 procedure Build_Pre_Post_Condition (Expr : Node_Id) is
2495 Loc : constant Source_Ptr := Sloc (Subp);
2503 Pragma_Argument_Associations => New_List (
2504 Make_Pragma_Argument_Association (Loc,
2505 Chars => Name_Check,
2506 Expression => Expr)));
2508 -- Add a message unless exception messages are suppressed
2510 if not Exception_Locations_Suppressed then
2511 Append_To (Pragma_Argument_Associations (Prag),
2512 Make_Pragma_Argument_Association (Loc,
2513 Chars => Name_Message,
2515 Make_String_Literal (Loc,
2517 & Get_Name_String (Prag_Nam)
2519 & Build_Location_String (Loc))));
2522 -- Insert the pragma in the tree
2524 if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then
2525 Add_Global_Declaration (Prag);
2528 -- PPC pragmas associated with subprogram bodies must be inserted
2529 -- in the declarative part of the body.
2531 elsif Nkind (Subp_Decl) = N_Subprogram_Body then
2532 Decls := Declarations (Subp_Decl);
2536 Set_Declarations (Subp_Decl, Decls);
2539 Prepend_To (Decls, Prag);
2542 -- For subprogram declarations insert the PPC pragma right after
2543 -- the declarative node.
2546 Insert_After_And_Analyze (Subp_Decl, Prag);
2548 end Build_Pre_Post_Condition;
2552 Loc : constant Source_Ptr := Sloc (Subp);
2553 Typ : constant Entity_Id := Etype (Formal);
2557 -- Start of processing for Add_Validity_Check
2560 -- For scalars, generate 'Valid test
2562 if Is_Scalar_Type (Typ) then
2565 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2567 elsif Scalar_Part_Present (Typ) then
2568 Nam := Name_Valid_Scalars;
2570 -- No test needed for other cases (no scalars to test)
2576 -- Step 1: Create the expression to verify the validity of the
2579 Check := New_Occurrence_Of (Formal, Loc);
2581 -- When processing a function result, use 'Result. Generate
2586 Make_Attribute_Reference (Loc,
2588 Attribute_Name => Name_Result);
2592 -- Context['Result]'Valid[_Scalars]
2595 Make_Attribute_Reference (Loc,
2597 Attribute_Name => Nam);
2599 -- Step 2: Create a pre or post condition pragma
2601 Build_Pre_Post_Condition (Check);
2602 end Add_Validity_Check;
2607 Subp_Spec : Node_Id;
2609 -- Start of processing for Apply_Parameter_Validity_Checks
2612 -- Extract the subprogram specification and declaration nodes
2614 Subp_Spec := Parent (Subp);
2616 if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
2617 Subp_Spec := Parent (Subp_Spec);
2620 Subp_Decl := Parent (Subp_Spec);
2622 if not Comes_From_Source (Subp)
2624 -- Do not process formal subprograms because the corresponding actual
2625 -- will receive the proper checks when the instance is analyzed.
2627 or else Is_Formal_Subprogram (Subp)
2629 -- Do not process imported subprograms since pre and postconditions
2630 -- are never verified on routines coming from a different language.
2632 or else Is_Imported (Subp)
2633 or else Is_Intrinsic_Subprogram (Subp)
2635 -- The PPC pragmas generated by this routine do not correspond to
2636 -- source aspects, therefore they cannot be applied to abstract
2639 or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
2641 -- Do not consider subprogram renaminds because the renamed entity
2642 -- already has the proper PPC pragmas.
2644 or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
2646 -- Do not process null procedures because there is no benefit of
2647 -- adding the checks to a no action routine.
2649 or else (Nkind (Subp_Spec) = N_Procedure_Specification
2650 and then Null_Present (Subp_Spec))
2655 -- Inspect all the formals applying aliasing and scalar initialization
2656 -- checks where applicable.
2658 Formal := First_Formal (Subp);
2659 while Present (Formal) loop
2661 -- Generate the following scalar initialization checks for each
2662 -- formal parameter:
2664 -- mode IN - Pre => Formal'Valid[_Scalars]
2665 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2666 -- mode OUT - Post => Formal'Valid[_Scalars]
2668 if Check_Validity_Of_Parameters then
2669 if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
2670 Add_Validity_Check (Formal, Name_Precondition, False);
2673 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
2674 Add_Validity_Check (Formal, Name_Postcondition, False);
2678 Next_Formal (Formal);
2681 -- Generate following scalar initialization check for function result:
2683 -- Post => Subp'Result'Valid[_Scalars]
2685 if Check_Validity_Of_Parameters and then Ekind (Subp) = E_Function then
2686 Add_Validity_Check (Subp, Name_Postcondition, True);
2688 end Apply_Parameter_Validity_Checks;
2690 ---------------------------
2691 -- Apply_Predicate_Check --
2692 ---------------------------
2694 procedure Apply_Predicate_Check
2697 Fun : Entity_Id := Empty)
2702 if Predicate_Checks_Suppressed (Empty) then
2705 elsif Predicates_Ignored (Typ) then
2708 elsif Present (Predicate_Function (Typ)) then
2710 while Present (S) and then not Is_Subprogram (S) loop
2714 -- A predicate check does not apply within internally generated
2715 -- subprograms, such as TSS functions.
2717 if Within_Internal_Subprogram then
2720 -- If the check appears within the predicate function itself, it
2721 -- means that the user specified a check whose formal is the
2722 -- predicated subtype itself, rather than some covering type. This
2723 -- is likely to be a common error, and thus deserves a warning.
2725 elsif Present (S) and then S = Predicate_Function (Typ) then
2727 ("predicate check includes a call to& that requires a "
2728 & "predicate check??", Parent (N), Fun);
2730 ("\this will result in infinite recursion??", Parent (N));
2732 if Is_First_Subtype (Typ) then
2734 ("\use an explicit subtype of& to carry the predicate",
2739 Make_Raise_Storage_Error (Sloc (N),
2740 Reason => SE_Infinite_Recursion));
2742 -- Here for normal case of predicate active
2745 -- If the expression is an IN parameter, the predicate will have
2746 -- been applied at the point of call. An additional check would
2747 -- be redundant, or will lead to out-of-scope references if the
2748 -- call appears within an aspect specification for a precondition.
2750 -- However, if the reference is within the body of the subprogram
2751 -- that declares the formal, the predicate can safely be applied,
2752 -- which may be necessary for a nested call whose formal has a
2753 -- different predicate.
2755 if Is_Entity_Name (N)
2756 and then Ekind (Entity (N)) = E_In_Parameter
2759 In_Body : Boolean := False;
2760 P : Node_Id := Parent (N);
2763 while Present (P) loop
2764 if Nkind (P) = N_Subprogram_Body
2765 and then Corresponding_Spec (P) = Scope (Entity (N))
2780 -- If the type has a static predicate and the expression is known
2781 -- at compile time, see if the expression satisfies the predicate.
2783 Check_Expression_Against_Static_Predicate (N, Typ);
2785 if not Expander_Active then
2789 -- For an entity of the type, generate a call to the predicate
2790 -- function, unless its type is an actual subtype, which is not
2791 -- visible outside of the enclosing subprogram.
2793 if Is_Entity_Name (N)
2794 and then not Is_Actual_Subtype (Typ)
2797 Make_Predicate_Check
2798 (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
2800 -- If the expression is not an entity it may have side effects,
2801 -- and the following call will create an object declaration for
2802 -- it. We disable checks during its analysis, to prevent an
2803 -- infinite recursion.
2805 -- If the prefix is an aggregate in an assignment, apply the
2806 -- check to the LHS after assignment, rather than create a
2807 -- redundant temporary. This is only necessary in rare cases
2808 -- of array types (including strings) initialized with an
2809 -- aggregate with an "others" clause, either coming from source
2810 -- or generated by an Initialize_Scalars pragma.
2812 elsif Nkind (N) = N_Aggregate
2813 and then Nkind (Parent (N)) = N_Assignment_Statement
2815 Insert_Action_After (Parent (N),
2816 Make_Predicate_Check
2817 (Typ, Duplicate_Subexpr (Name (Parent (N)))));
2821 Make_Predicate_Check
2822 (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
2826 end Apply_Predicate_Check;
2828 -----------------------
2829 -- Apply_Range_Check --
2830 -----------------------
2832 procedure Apply_Range_Check
2834 Target_Typ : Entity_Id;
2835 Source_Typ : Entity_Id := Empty)
2838 Apply_Selected_Range_Checks
2839 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2840 end Apply_Range_Check;
2842 ------------------------------
2843 -- Apply_Scalar_Range_Check --
2844 ------------------------------
2846 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2847 -- off if it is already set on.
2849 procedure Apply_Scalar_Range_Check
2851 Target_Typ : Entity_Id;
2852 Source_Typ : Entity_Id := Empty;
2853 Fixed_Int : Boolean := False)
2855 Parnt : constant Node_Id := Parent (Expr);
2857 Arr : Node_Id := Empty; -- initialize to prevent warning
2858 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
2860 Is_Subscr_Ref : Boolean;
2861 -- Set true if Expr is a subscript
2863 Is_Unconstrained_Subscr_Ref : Boolean;
2864 -- Set true if Expr is a subscript of an unconstrained array. In this
2865 -- case we do not attempt to do an analysis of the value against the
2866 -- range of the subscript, since we don't know the actual subtype.
2869 -- Set to True if Expr should be regarded as a real value even though
2870 -- the type of Expr might be discrete.
2872 procedure Bad_Value (Warn : Boolean := False);
2873 -- Procedure called if value is determined to be out of range. Warn is
2874 -- True to force a warning instead of an error, even when SPARK_Mode is
2881 procedure Bad_Value (Warn : Boolean := False) is
2883 Apply_Compile_Time_Constraint_Error
2884 (Expr, "value not in range of}??", CE_Range_Check_Failed,
2890 -- Start of processing for Apply_Scalar_Range_Check
2893 -- Return if check obviously not needed
2896 -- Not needed inside generic
2900 -- Not needed if previous error
2902 or else Target_Typ = Any_Type
2903 or else Nkind (Expr) = N_Error
2905 -- Not needed for non-scalar type
2907 or else not Is_Scalar_Type (Target_Typ)
2909 -- Not needed if we know node raises CE already
2911 or else Raises_Constraint_Error (Expr)
2916 -- Now, see if checks are suppressed
2919 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
2921 if Is_Subscr_Ref then
2922 Arr := Prefix (Parnt);
2923 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
2925 if Is_Access_Type (Arr_Typ) then
2926 Arr_Typ := Designated_Type (Arr_Typ);
2930 if not Do_Range_Check (Expr) then
2932 -- Subscript reference. Check for Index_Checks suppressed
2934 if Is_Subscr_Ref then
2936 -- Check array type and its base type
2938 if Index_Checks_Suppressed (Arr_Typ)
2939 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
2943 -- Check array itself if it is an entity name
2945 elsif Is_Entity_Name (Arr)
2946 and then Index_Checks_Suppressed (Entity (Arr))
2950 -- Check expression itself if it is an entity name
2952 elsif Is_Entity_Name (Expr)
2953 and then Index_Checks_Suppressed (Entity (Expr))
2958 -- All other cases, check for Range_Checks suppressed
2961 -- Check target type and its base type
2963 if Range_Checks_Suppressed (Target_Typ)
2964 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
2968 -- Check expression itself if it is an entity name
2970 elsif Is_Entity_Name (Expr)
2971 and then Range_Checks_Suppressed (Entity (Expr))
2975 -- If Expr is part of an assignment statement, then check left
2976 -- side of assignment if it is an entity name.
2978 elsif Nkind (Parnt) = N_Assignment_Statement
2979 and then Is_Entity_Name (Name (Parnt))
2980 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
2987 -- Do not set range checks if they are killed
2989 if Nkind (Expr) = N_Unchecked_Type_Conversion
2990 and then Kill_Range_Check (Expr)
2995 -- Do not set range checks for any values from System.Scalar_Values
2996 -- since the whole idea of such values is to avoid checking them.
2998 if Is_Entity_Name (Expr)
2999 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
3004 -- Now see if we need a check
3006 if No (Source_Typ) then
3007 S_Typ := Etype (Expr);
3009 S_Typ := Source_Typ;
3012 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
3016 Is_Unconstrained_Subscr_Ref :=
3017 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
3019 -- Special checks for floating-point type
3021 if Is_Floating_Point_Type (S_Typ) then
3023 -- Always do a range check if the source type includes infinities and
3024 -- the target type does not include infinities. We do not do this if
3025 -- range checks are killed.
3026 -- If the expression is a literal and the bounds of the type are
3027 -- static constants it may be possible to optimize the check.
3029 if Has_Infinities (S_Typ)
3030 and then not Has_Infinities (Target_Typ)
3032 -- If the expression is a literal and the bounds of the type are
3033 -- static constants it may be possible to optimize the check.
3035 if Nkind (Expr) = N_Real_Literal then
3037 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
3038 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
3041 if Compile_Time_Known_Value (Tlo)
3042 and then Compile_Time_Known_Value (Thi)
3043 and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo)
3044 and then Expr_Value_R (Expr) <= Expr_Value_R (Thi)
3048 Enable_Range_Check (Expr);
3053 Enable_Range_Check (Expr);
3058 -- Return if we know expression is definitely in the range of the target
3059 -- type as determined by Determine_Range. Right now we only do this for
3060 -- discrete types, and not fixed-point or floating-point types.
3062 -- The additional less-precise tests below catch these cases
3064 -- In GNATprove_Mode, also deal with the case of a conversion from
3065 -- floating-point to integer. It is only possible because analysis
3066 -- in GNATprove rules out the possibility of a NaN or infinite value.
3068 -- Note: skip this if we are given a source_typ, since the point of
3069 -- supplying a Source_Typ is to stop us looking at the expression.
3070 -- We could sharpen this test to be out parameters only ???
3072 if Is_Discrete_Type (Target_Typ)
3073 and then (Is_Discrete_Type (Etype (Expr))
3074 or else (GNATprove_Mode
3075 and then Is_Floating_Point_Type (Etype (Expr))))
3076 and then not Is_Unconstrained_Subscr_Ref
3077 and then No (Source_Typ)
3080 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
3081 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
3084 if Compile_Time_Known_Value (Tlo)
3085 and then Compile_Time_Known_Value (Thi)
3088 OK : Boolean := False; -- initialize to prevent warning
3089 Hiv : constant Uint := Expr_Value (Thi);
3090 Lov : constant Uint := Expr_Value (Tlo);
3091 Hi : Uint := No_Uint;
3092 Lo : Uint := No_Uint;
3095 -- If range is null, we for sure have a constraint error (we
3096 -- don't even need to look at the value involved, since all
3097 -- possible values will raise CE).
3101 -- When SPARK_Mode is On, force a warning instead of
3102 -- an error in that case, as this likely corresponds
3103 -- to deactivated code.
3105 Bad_Value (Warn => SPARK_Mode = On);
3107 -- In GNATprove mode, we enable the range check so that
3108 -- GNATprove will issue a message if it cannot be proved.
3110 if GNATprove_Mode then
3111 Enable_Range_Check (Expr);
3117 -- Otherwise determine range of value
3119 if Is_Discrete_Type (Etype (Expr)) then
3121 (Expr, OK, Lo, Hi, Assume_Valid => True);
3123 -- When converting a float to an integer type, determine the
3124 -- range in real first, and then convert the bounds using
3125 -- UR_To_Uint which correctly rounds away from zero when
3126 -- half way between two integers, as required by normal
3127 -- Ada 95 rounding semantics. It is only possible because
3128 -- analysis in GNATprove rules out the possibility of a NaN
3129 -- or infinite value.
3131 elsif GNATprove_Mode
3132 and then Is_Floating_Point_Type (Etype (Expr))
3140 (Expr, OK, Lor, Hir, Assume_Valid => True);
3143 Lo := UR_To_Uint (Lor);
3144 Hi := UR_To_Uint (Hir);
3151 -- If definitely in range, all OK
3153 if Lo >= Lov and then Hi <= Hiv then
3156 -- If definitely not in range, warn
3158 elsif Lov > Hi or else Hiv < Lo then
3160 -- Ignore out of range values for System.Priority in
3161 -- CodePeer mode since the actual target compiler may
3162 -- provide a wider range.
3164 if not CodePeer_Mode
3165 or else Target_Typ /= RTE (RE_Priority)
3172 -- Otherwise we don't know
3184 Is_Floating_Point_Type (S_Typ)
3185 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
3187 -- Check if we can determine at compile time whether Expr is in the
3188 -- range of the target type. Note that if S_Typ is within the bounds
3189 -- of Target_Typ then this must be the case. This check is meaningful
3190 -- only if this is not a conversion between integer and real types.
3192 if not Is_Unconstrained_Subscr_Ref
3193 and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
3195 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
3197 -- Also check if the expression itself is in the range of the
3198 -- target type if it is a known at compile time value. We skip
3199 -- this test if S_Typ is set since for OUT and IN OUT parameters
3200 -- the Expr itself is not relevant to the checking.
3204 and then Is_In_Range (Expr, Target_Typ,
3205 Assume_Valid => True,
3206 Fixed_Int => Fixed_Int,
3207 Int_Real => Int_Real)))
3211 elsif Is_Out_Of_Range (Expr, Target_Typ,
3212 Assume_Valid => True,
3213 Fixed_Int => Fixed_Int,
3214 Int_Real => Int_Real)
3219 -- Floating-point case
3220 -- In the floating-point case, we only do range checks if the type is
3221 -- constrained. We definitely do NOT want range checks for unconstrained
3222 -- types, since we want to have infinities, except when
3223 -- Check_Float_Overflow is set.
3225 elsif Is_Floating_Point_Type (S_Typ) then
3226 if Is_Constrained (S_Typ) or else Check_Float_Overflow then
3227 Enable_Range_Check (Expr);
3230 -- For all other cases we enable a range check unconditionally
3233 Enable_Range_Check (Expr);
3236 end Apply_Scalar_Range_Check;
3238 ----------------------------------
3239 -- Apply_Selected_Length_Checks --
3240 ----------------------------------
3242 procedure Apply_Selected_Length_Checks
3244 Target_Typ : Entity_Id;
3245 Source_Typ : Entity_Id;
3246 Do_Static : Boolean)
3248 Checks_On : constant Boolean :=
3249 not Index_Checks_Suppressed (Target_Typ)
3251 not Length_Checks_Suppressed (Target_Typ);
3253 Loc : constant Source_Ptr := Sloc (Ck_Node);
3257 R_Result : Check_Result;
3260 -- Only apply checks when generating code
3262 -- Note: this means that we lose some useful warnings if the expander
3265 if not Expander_Active then
3270 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3272 for J in 1 .. 2 loop
3273 R_Cno := R_Result (J);
3274 exit when No (R_Cno);
3276 -- A length check may mention an Itype which is attached to a
3277 -- subsequent node. At the top level in a package this can cause
3278 -- an order-of-elaboration problem, so we make sure that the itype
3279 -- is referenced now.
3281 if Ekind (Current_Scope) = E_Package
3282 and then Is_Compilation_Unit (Current_Scope)
3284 Ensure_Defined (Target_Typ, Ck_Node);
3286 if Present (Source_Typ) then
3287 Ensure_Defined (Source_Typ, Ck_Node);
3289 elsif Is_Itype (Etype (Ck_Node)) then
3290 Ensure_Defined (Etype (Ck_Node), Ck_Node);
3294 -- If the item is a conditional raise of constraint error, then have
3295 -- a look at what check is being performed and ???
3297 if Nkind (R_Cno) = N_Raise_Constraint_Error
3298 and then Present (Condition (R_Cno))
3300 Cond := Condition (R_Cno);
3302 -- Case where node does not now have a dynamic check
3304 if not Has_Dynamic_Length_Check (Ck_Node) then
3306 -- If checks are on, just insert the check
3309 Insert_Action (Ck_Node, R_Cno);
3311 if not Do_Static then
3312 Set_Has_Dynamic_Length_Check (Ck_Node);
3315 -- If checks are off, then analyze the length check after
3316 -- temporarily attaching it to the tree in case the relevant
3317 -- condition can be evaluated at compile time. We still want a
3318 -- compile time warning in this case.
3321 Set_Parent (R_Cno, Ck_Node);
3326 -- Output a warning if the condition is known to be True
3328 if Is_Entity_Name (Cond)
3329 and then Entity (Cond) = Standard_True
3331 Apply_Compile_Time_Constraint_Error
3332 (Ck_Node, "wrong length for array of}??",
3333 CE_Length_Check_Failed,
3337 -- If we were only doing a static check, or if checks are not
3338 -- on, then we want to delete the check, since it is not needed.
3339 -- We do this by replacing the if statement by a null statement
3341 elsif Do_Static or else not Checks_On then
3342 Remove_Warning_Messages (R_Cno);
3343 Rewrite (R_Cno, Make_Null_Statement (Loc));
3347 Install_Static_Check (R_Cno, Loc);
3350 end Apply_Selected_Length_Checks;
3352 ---------------------------------
3353 -- Apply_Selected_Range_Checks --
3354 ---------------------------------
3356 procedure Apply_Selected_Range_Checks
3358 Target_Typ : Entity_Id;
3359 Source_Typ : Entity_Id;
3360 Do_Static : Boolean)
3362 Checks_On : constant Boolean :=
3363 not Index_Checks_Suppressed (Target_Typ)
3365 not Range_Checks_Suppressed (Target_Typ);
3367 Loc : constant Source_Ptr := Sloc (Ck_Node);
3371 R_Result : Check_Result;
3374 -- Only apply checks when generating code. In GNATprove mode, we do not
3375 -- apply the checks, but we still call Selected_Range_Checks to possibly
3376 -- issue errors on SPARK code when a run-time error can be detected at
3379 if not GNATprove_Mode then
3380 if not Expander_Active or not Checks_On then
3386 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3388 if GNATprove_Mode then
3392 for J in 1 .. 2 loop
3393 R_Cno := R_Result (J);
3394 exit when No (R_Cno);
3396 -- The range check requires runtime evaluation. Depending on what its
3397 -- triggering condition is, the check may be converted into a compile
3398 -- time constraint check.
3400 if Nkind (R_Cno) = N_Raise_Constraint_Error
3401 and then Present (Condition (R_Cno))
3403 Cond := Condition (R_Cno);
3405 -- Insert the range check before the related context. Note that
3406 -- this action analyses the triggering condition.
3408 Insert_Action (Ck_Node, R_Cno);
3410 -- This old code doesn't make sense, why is the context flagged as
3411 -- requiring dynamic range checks now in the middle of generating
3414 if not Do_Static then
3415 Set_Has_Dynamic_Range_Check (Ck_Node);
3418 -- The triggering condition evaluates to True, the range check
3419 -- can be converted into a compile time constraint check.
3421 if Is_Entity_Name (Cond)
3422 and then Entity (Cond) = Standard_True
3424 -- Since an N_Range is technically not an expression, we have
3425 -- to set one of the bounds to C_E and then just flag the
3426 -- N_Range. The warning message will point to the lower bound
3427 -- and complain about a range, which seems OK.
3429 if Nkind (Ck_Node) = N_Range then
3430 Apply_Compile_Time_Constraint_Error
3431 (Low_Bound (Ck_Node),
3432 "static range out of bounds of}??",
3433 CE_Range_Check_Failed,
3437 Set_Raises_Constraint_Error (Ck_Node);
3440 Apply_Compile_Time_Constraint_Error
3442 "static value out of range of}??",
3443 CE_Range_Check_Failed,
3448 -- If we were only doing a static check, or if checks are not
3449 -- on, then we want to delete the check, since it is not needed.
3450 -- We do this by replacing the if statement by a null statement
3452 elsif Do_Static then
3453 Remove_Warning_Messages (R_Cno);
3454 Rewrite (R_Cno, Make_Null_Statement (Loc));
3457 -- The range check raises Constraint_Error explicitly
3460 Install_Static_Check (R_Cno, Loc);
3463 end Apply_Selected_Range_Checks;
3465 -------------------------------
3466 -- Apply_Static_Length_Check --
3467 -------------------------------
3469 procedure Apply_Static_Length_Check
3471 Target_Typ : Entity_Id;
3472 Source_Typ : Entity_Id := Empty)
3475 Apply_Selected_Length_Checks
3476 (Expr, Target_Typ, Source_Typ, Do_Static => True);
3477 end Apply_Static_Length_Check;
3479 -------------------------------------
3480 -- Apply_Subscript_Validity_Checks --
3481 -------------------------------------
3483 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
3487 pragma Assert (Nkind (Expr) = N_Indexed_Component);
3489 -- Loop through subscripts
3491 Sub := First (Expressions (Expr));
3492 while Present (Sub) loop
3494 -- Check one subscript. Note that we do not worry about enumeration
3495 -- type with holes, since we will convert the value to a Pos value
3496 -- for the subscript, and that convert will do the necessary validity
3499 Ensure_Valid (Sub, Holes_OK => True);
3501 -- Move to next subscript
3505 end Apply_Subscript_Validity_Checks;
3507 ----------------------------------
3508 -- Apply_Type_Conversion_Checks --
3509 ----------------------------------
3511 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
3512 Target_Type : constant Entity_Id := Etype (N);
3513 Target_Base : constant Entity_Id := Base_Type (Target_Type);
3514 Expr : constant Node_Id := Expression (N);
3516 Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
3517 -- Note: if Etype (Expr) is a private type without discriminants, its
3518 -- full view might have discriminants with defaults, so we need the
3519 -- full view here to retrieve the constraints.
3522 if Inside_A_Generic then
3525 -- Skip these checks if serious errors detected, there are some nasty
3526 -- situations of incomplete trees that blow things up.
3528 elsif Serious_Errors_Detected > 0 then
3531 -- Never generate discriminant checks for Unchecked_Union types
3533 elsif Present (Expr_Type)
3534 and then Is_Unchecked_Union (Expr_Type)
3538 -- Scalar type conversions of the form Target_Type (Expr) require a
3539 -- range check if we cannot be sure that Expr is in the base type of
3540 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3541 -- are not quite the same condition from an implementation point of
3542 -- view, but clearly the second includes the first.
3544 elsif Is_Scalar_Type (Target_Type) then
3546 Conv_OK : constant Boolean := Conversion_OK (N);
3547 -- If the Conversion_OK flag on the type conversion is set and no
3548 -- floating-point type is involved in the type conversion then
3549 -- fixed-point values must be read as integral values.
3551 Float_To_Int : constant Boolean :=
3552 Is_Floating_Point_Type (Expr_Type)
3553 and then Is_Integer_Type (Target_Type);
3556 if not Overflow_Checks_Suppressed (Target_Base)
3557 and then not Overflow_Checks_Suppressed (Target_Type)
3559 In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
3560 and then not Float_To_Int
3562 -- A small optimization: the attribute 'Pos applied to an
3563 -- enumeration type has a known range, even though its type is
3564 -- Universal_Integer. So in numeric conversions it is usually
3565 -- within range of the target integer type. Use the static
3566 -- bounds of the base types to check. Disable this optimization
3567 -- in case of a generic formal discrete type, because we don't
3568 -- necessarily know the upper bound yet.
3570 if Nkind (Expr) = N_Attribute_Reference
3571 and then Attribute_Name (Expr) = Name_Pos
3572 and then Is_Enumeration_Type (Etype (Prefix (Expr)))
3573 and then not Is_Generic_Type (Etype (Prefix (Expr)))
3574 and then Is_Integer_Type (Target_Type)
3577 Enum_T : constant Entity_Id :=
3578 Root_Type (Etype (Prefix (Expr)));
3579 Int_T : constant Entity_Id := Base_Type (Target_Type);
3580 Last_I : constant Uint :=
3581 Intval (High_Bound (Scalar_Range (Int_T)));
3585 -- Character types have no explicit literals, so we use
3586 -- the known number of characters in the type.
3588 if Root_Type (Enum_T) = Standard_Character then
3589 Last_E := UI_From_Int (255);
3591 elsif Enum_T = Standard_Wide_Character
3592 or else Enum_T = Standard_Wide_Wide_Character
3594 Last_E := UI_From_Int (65535);
3599 (Entity (High_Bound (Scalar_Range (Enum_T))));
3602 if Last_E <= Last_I then
3606 Activate_Overflow_Check (N);
3611 Activate_Overflow_Check (N);
3615 if not Range_Checks_Suppressed (Target_Type)
3616 and then not Range_Checks_Suppressed (Expr_Type)
3619 and then not GNATprove_Mode
3621 Apply_Float_Conversion_Check (Expr, Target_Type);
3624 -- Conversions involving fixed-point types are expanded
3625 -- separately, and do not need a Range_Check flag, except
3626 -- in GNATprove_Mode, where the explicit constraint check
3627 -- will not be generated.
3630 or else (not Is_Fixed_Point_Type (Expr_Type)
3631 and then not Is_Fixed_Point_Type (Target_Type))
3633 Apply_Scalar_Range_Check
3634 (Expr, Target_Type, Fixed_Int => Conv_OK);
3637 Set_Do_Range_Check (Expr, False);
3640 -- If the target type has predicates, we need to indicate
3641 -- the need for a check, even if Determine_Range finds that
3642 -- the value is within bounds. This may be the case e.g for
3643 -- a division with a constant denominator.
3645 if Has_Predicates (Target_Type) then
3646 Enable_Range_Check (Expr);
3652 elsif Comes_From_Source (N)
3653 and then not Discriminant_Checks_Suppressed (Target_Type)
3654 and then Is_Record_Type (Target_Type)
3655 and then Is_Derived_Type (Target_Type)
3656 and then not Is_Tagged_Type (Target_Type)
3657 and then not Is_Constrained (Target_Type)
3658 and then Present (Stored_Constraint (Target_Type))
3660 -- An unconstrained derived type may have inherited discriminant.
3661 -- Build an actual discriminant constraint list using the stored
3662 -- constraint, to verify that the expression of the parent type
3663 -- satisfies the constraints imposed by the (unconstrained) derived
3664 -- type. This applies to value conversions, not to view conversions
3668 Loc : constant Source_Ptr := Sloc (N);
3670 Constraint : Elmt_Id;
3671 Discr_Value : Node_Id;
3674 New_Constraints : constant Elist_Id := New_Elmt_List;
3675 Old_Constraints : constant Elist_Id :=
3676 Discriminant_Constraint (Expr_Type);
3679 Constraint := First_Elmt (Stored_Constraint (Target_Type));
3680 while Present (Constraint) loop
3681 Discr_Value := Node (Constraint);
3683 if Is_Entity_Name (Discr_Value)
3684 and then Ekind (Entity (Discr_Value)) = E_Discriminant
3686 Discr := Corresponding_Discriminant (Entity (Discr_Value));
3689 and then Scope (Discr) = Base_Type (Expr_Type)
3691 -- Parent is constrained by new discriminant. Obtain
3692 -- Value of original discriminant in expression. If the
3693 -- new discriminant has been used to constrain more than
3694 -- one of the stored discriminants, this will provide the
3695 -- required consistency check.
3698 (Make_Selected_Component (Loc,
3700 Duplicate_Subexpr_No_Checks
3701 (Expr, Name_Req => True),
3703 Make_Identifier (Loc, Chars (Discr))),
3707 -- Discriminant of more remote ancestor ???
3712 -- Derived type definition has an explicit value for this
3713 -- stored discriminant.
3717 (Duplicate_Subexpr_No_Checks (Discr_Value),
3721 Next_Elmt (Constraint);
3724 -- Use the unconstrained expression type to retrieve the
3725 -- discriminants of the parent, and apply momentarily the
3726 -- discriminant constraint synthesized above.
3728 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
3729 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
3730 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
3733 Make_Raise_Constraint_Error (Loc,
3735 Reason => CE_Discriminant_Check_Failed));
3738 -- For arrays, checks are set now, but conversions are applied during
3739 -- expansion, to take into accounts changes of representation. The
3740 -- checks become range checks on the base type or length checks on the
3741 -- subtype, depending on whether the target type is unconstrained or
3742 -- constrained. Note that the range check is put on the expression of a
3743 -- type conversion, while the length check is put on the type conversion
3746 elsif Is_Array_Type (Target_Type) then
3747 if Is_Constrained (Target_Type) then
3748 Set_Do_Length_Check (N);
3750 Set_Do_Range_Check (Expr);
3753 end Apply_Type_Conversion_Checks;
3755 ----------------------------------------------
3756 -- Apply_Universal_Integer_Attribute_Checks --
3757 ----------------------------------------------
3759 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
3760 Loc : constant Source_Ptr := Sloc (N);
3761 Typ : constant Entity_Id := Etype (N);
3764 if Inside_A_Generic then
3767 -- Nothing to do if checks are suppressed
3769 elsif Range_Checks_Suppressed (Typ)
3770 and then Overflow_Checks_Suppressed (Typ)
3774 -- Nothing to do if the attribute does not come from source. The
3775 -- internal attributes we generate of this type do not need checks,
3776 -- and furthermore the attempt to check them causes some circular
3777 -- elaboration orders when dealing with packed types.
3779 elsif not Comes_From_Source (N) then
3782 -- If the prefix is a selected component that depends on a discriminant
3783 -- the check may improperly expose a discriminant instead of using
3784 -- the bounds of the object itself. Set the type of the attribute to
3785 -- the base type of the context, so that a check will be imposed when
3786 -- needed (e.g. if the node appears as an index).
3788 elsif Nkind (Prefix (N)) = N_Selected_Component
3789 and then Ekind (Typ) = E_Signed_Integer_Subtype
3790 and then Depends_On_Discriminant (Scalar_Range (Typ))
3792 Set_Etype (N, Base_Type (Typ));
3794 -- Otherwise, replace the attribute node with a type conversion node
3795 -- whose expression is the attribute, retyped to universal integer, and
3796 -- whose subtype mark is the target type. The call to analyze this
3797 -- conversion will set range and overflow checks as required for proper
3798 -- detection of an out of range value.
3801 Set_Etype (N, Universal_Integer);
3802 Set_Analyzed (N, True);
3805 Make_Type_Conversion (Loc,
3806 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
3807 Expression => Relocate_Node (N)));
3809 Analyze_And_Resolve (N, Typ);
3812 end Apply_Universal_Integer_Attribute_Checks;
3814 -------------------------------------
3815 -- Atomic_Synchronization_Disabled --
3816 -------------------------------------
3818 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3819 -- using a bogus check called Atomic_Synchronization. This is to make it
3820 -- more convenient to get exactly the same semantics as [Un]Suppress.
3822 function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
3824 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3825 -- looks enabled, since it is never disabled.
3827 if Debug_Flag_Dot_E then
3830 -- If debug flag d.d is set then always return True, i.e. all atomic
3831 -- sync looks disabled, since it always tests True.
3833 elsif Debug_Flag_Dot_D then
3836 -- If entity present, then check result for that entity
3838 elsif Present (E) and then Checks_May_Be_Suppressed (E) then
3839 return Is_Check_Suppressed (E, Atomic_Synchronization);
3841 -- Otherwise result depends on current scope setting
3844 return Scope_Suppress.Suppress (Atomic_Synchronization);
3846 end Atomic_Synchronization_Disabled;
3848 -------------------------------
3849 -- Build_Discriminant_Checks --
3850 -------------------------------
3852 function Build_Discriminant_Checks
3854 T_Typ : Entity_Id) return Node_Id
3856 Loc : constant Source_Ptr := Sloc (N);
3859 Disc_Ent : Entity_Id;
3863 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
3865 --------------------------------
3866 -- Aggregate_Discriminant_Val --
3867 --------------------------------
3869 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
3873 -- The aggregate has been normalized with named associations. We use
3874 -- the Chars field to locate the discriminant to take into account
3875 -- discriminants in derived types, which carry the same name as those
3878 Assoc := First (Component_Associations (N));
3879 while Present (Assoc) loop
3880 if Chars (First (Choices (Assoc))) = Chars (Disc) then
3881 return Expression (Assoc);
3887 -- Discriminant must have been found in the loop above
3889 raise Program_Error;
3890 end Aggregate_Discriminant_Val;
3892 -- Start of processing for Build_Discriminant_Checks
3895 -- Loop through discriminants evolving the condition
3898 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
3900 -- For a fully private type, use the discriminants of the parent type
3902 if Is_Private_Type (T_Typ)
3903 and then No (Full_View (T_Typ))
3905 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
3907 Disc_Ent := First_Discriminant (T_Typ);
3910 while Present (Disc) loop
3911 Dval := Node (Disc);
3913 if Nkind (Dval) = N_Identifier
3914 and then Ekind (Entity (Dval)) = E_Discriminant
3916 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
3918 Dval := Duplicate_Subexpr_No_Checks (Dval);
3921 -- If we have an Unchecked_Union node, we can infer the discriminants
3924 if Is_Unchecked_Union (Base_Type (T_Typ)) then
3926 Get_Discriminant_Value (
3927 First_Discriminant (T_Typ),
3929 Stored_Constraint (T_Typ)));
3931 elsif Nkind (N) = N_Aggregate then
3933 Duplicate_Subexpr_No_Checks
3934 (Aggregate_Discriminant_Val (Disc_Ent));
3938 Make_Selected_Component (Loc,
3940 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
3941 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
3943 Set_Is_In_Discriminant_Check (Dref);
3946 Evolve_Or_Else (Cond,
3949 Right_Opnd => Dval));
3952 Next_Discriminant (Disc_Ent);
3956 end Build_Discriminant_Checks;
3962 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
3969 function Left_Expression (Op : Node_Id) return Node_Id;
3970 -- Return the relevant expression from the left operand of the given
3971 -- short circuit form: this is LO itself, except if LO is a qualified
3972 -- expression, a type conversion, or an expression with actions, in
3973 -- which case this is Left_Expression (Expression (LO)).
3975 ---------------------
3976 -- Left_Expression --
3977 ---------------------
3979 function Left_Expression (Op : Node_Id) return Node_Id is
3980 LE : Node_Id := Left_Opnd (Op);
3982 while Nkind_In (LE, N_Qualified_Expression,
3984 N_Expression_With_Actions)
3986 LE := Expression (LE);
3990 end Left_Expression;
3992 -- Start of processing for Check_Needed
3995 -- Always check if not simple entity
3997 if Nkind (Nod) not in N_Has_Entity
3998 or else not Comes_From_Source (Nod)
4003 -- Look up tree for short circuit
4010 -- Done if out of subexpression (note that we allow generated stuff
4011 -- such as itype declarations in this context, to keep the loop going
4012 -- since we may well have generated such stuff in complex situations.
4013 -- Also done if no parent (probably an error condition, but no point
4014 -- in behaving nasty if we find it).
4017 or else (K not in N_Subexpr and then Comes_From_Source (P))
4021 -- Or/Or Else case, where test is part of the right operand, or is
4022 -- part of one of the actions associated with the right operand, and
4023 -- the left operand is an equality test.
4025 elsif K = N_Op_Or then
4026 exit when N = Right_Opnd (P)
4027 and then Nkind (Left_Expression (P)) = N_Op_Eq;
4029 elsif K = N_Or_Else then
4030 exit when (N = Right_Opnd (P)
4033 and then List_Containing (N) = Actions (P)))
4034 and then Nkind (Left_Expression (P)) = N_Op_Eq;
4036 -- Similar test for the And/And then case, where the left operand
4037 -- is an inequality test.
4039 elsif K = N_Op_And then
4040 exit when N = Right_Opnd (P)
4041 and then Nkind (Left_Expression (P)) = N_Op_Ne;
4043 elsif K = N_And_Then then
4044 exit when (N = Right_Opnd (P)
4047 and then List_Containing (N) = Actions (P)))
4048 and then Nkind (Left_Expression (P)) = N_Op_Ne;
4054 -- If we fall through the loop, then we have a conditional with an
4055 -- appropriate test as its left operand, so look further.
4057 L := Left_Expression (P);
4059 -- L is an "=" or "/=" operator: extract its operands
4061 R := Right_Opnd (L);
4064 -- Left operand of test must match original variable
4066 if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
4070 -- Right operand of test must be key value (zero or null)
4073 when Access_Check =>
4074 if not Known_Null (R) then
4078 when Division_Check =>
4079 if not Compile_Time_Known_Value (R)
4080 or else Expr_Value (R) /= Uint_0
4086 raise Program_Error;
4089 -- Here we have the optimizable case, warn if not short-circuited
4091 if K = N_Op_And or else K = N_Op_Or then
4092 Error_Msg_Warn := SPARK_Mode /= On;
4095 when Access_Check =>
4096 if GNATprove_Mode then
4098 ("Constraint_Error might have been raised (access check)",
4102 ("Constraint_Error may be raised (access check)??",
4106 when Division_Check =>
4107 if GNATprove_Mode then
4109 ("Constraint_Error might have been raised (zero divide)",
4113 ("Constraint_Error may be raised (zero divide)??",
4118 raise Program_Error;
4121 if K = N_Op_And then
4122 Error_Msg_N -- CODEFIX
4123 ("use `AND THEN` instead of AND??", P);
4125 Error_Msg_N -- CODEFIX
4126 ("use `OR ELSE` instead of OR??", P);
4129 -- If not short-circuited, we need the check
4133 -- If short-circuited, we can omit the check
4140 -----------------------------------
4141 -- Check_Valid_Lvalue_Subscripts --
4142 -----------------------------------
4144 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
4146 -- Skip this if range checks are suppressed
4148 if Range_Checks_Suppressed (Etype (Expr)) then
4151 -- Only do this check for expressions that come from source. We assume
4152 -- that expander generated assignments explicitly include any necessary
4153 -- checks. Note that this is not just an optimization, it avoids
4154 -- infinite recursions.
4156 elsif not Comes_From_Source (Expr) then
4159 -- For a selected component, check the prefix
4161 elsif Nkind (Expr) = N_Selected_Component then
4162 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
4165 -- Case of indexed component
4167 elsif Nkind (Expr) = N_Indexed_Component then
4168 Apply_Subscript_Validity_Checks (Expr);
4170 -- Prefix may itself be or contain an indexed component, and these
4171 -- subscripts need checking as well.
4173 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
4175 end Check_Valid_Lvalue_Subscripts;
4177 ----------------------------------
4178 -- Null_Exclusion_Static_Checks --
4179 ----------------------------------
4181 procedure Null_Exclusion_Static_Checks
4183 Comp : Node_Id := Empty;
4184 Array_Comp : Boolean := False)
4186 Has_Null : constant Boolean := Has_Null_Exclusion (N);
4187 Kind : constant Node_Kind := Nkind (N);
4188 Error_Nod : Node_Id;
4194 (Nkind_In (Kind, N_Component_Declaration,
4195 N_Discriminant_Specification,
4196 N_Function_Specification,
4197 N_Object_Declaration,
4198 N_Parameter_Specification));
4200 if Kind = N_Function_Specification then
4201 Typ := Etype (Defining_Entity (N));
4203 Typ := Etype (Defining_Identifier (N));
4207 when N_Component_Declaration =>
4208 if Present (Access_Definition (Component_Definition (N))) then
4209 Error_Nod := Component_Definition (N);
4211 Error_Nod := Subtype_Indication (Component_Definition (N));
4214 when N_Discriminant_Specification =>
4215 Error_Nod := Discriminant_Type (N);
4217 when N_Function_Specification =>
4218 Error_Nod := Result_Definition (N);
4220 when N_Object_Declaration =>
4221 Error_Nod := Object_Definition (N);
4223 when N_Parameter_Specification =>
4224 Error_Nod := Parameter_Type (N);
4227 raise Program_Error;
4232 -- Enforce legality rule 3.10 (13): A null exclusion can only be
4233 -- applied to an access [sub]type.
4235 if not Is_Access_Type (Typ) then
4237 ("`NOT NULL` allowed only for an access type", Error_Nod);
4239 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4240 -- be applied to a [sub]type that does not exclude null already.
4242 elsif Can_Never_Be_Null (Typ) and then Comes_From_Source (Typ) then
4244 ("`NOT NULL` not allowed (& already excludes null)",
4249 -- Check that null-excluding objects are always initialized, except for
4250 -- deferred constants, for which the expression will appear in the full
4253 if Kind = N_Object_Declaration
4254 and then No (Expression (N))
4255 and then not Constant_Present (N)
4256 and then not No_Initialization (N)
4258 if Present (Comp) then
4260 -- Specialize the warning message to indicate that we are dealing
4261 -- with an uninitialized composite object that has a defaulted
4262 -- null-excluding component.
4264 Error_Msg_Name_1 := Chars (Defining_Identifier (Comp));
4265 Error_Msg_Name_2 := Chars (Defining_Identifier (N));
4268 (Compile_Time_Constraint_Error
4271 "(Ada 2005) null-excluding component % of object % must "
4272 & "be initialized??",
4273 Ent => Defining_Identifier (Comp)));
4275 -- This is a case of an array with null-excluding components, so
4276 -- indicate that in the warning.
4278 elsif Array_Comp then
4280 (Compile_Time_Constraint_Error
4283 "(Ada 2005) null-excluding array components must "
4284 & "be initialized??",
4285 Ent => Defining_Identifier (N)));
4287 -- Normal case of object of a null-excluding access type
4290 -- Add an expression that assigns null. This node is needed by
4291 -- Apply_Compile_Time_Constraint_Error, which will replace this
4292 -- with a Constraint_Error node.
4294 Set_Expression (N, Make_Null (Sloc (N)));
4295 Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
4297 Apply_Compile_Time_Constraint_Error
4298 (N => Expression (N),
4300 "(Ada 2005) null-excluding objects must be initialized??",
4301 Reason => CE_Null_Not_Allowed);
4305 -- Check that a null-excluding component, formal or object is not being
4306 -- assigned a null value. Otherwise generate a warning message and
4307 -- replace Expression (N) by an N_Constraint_Error node.
4309 if Kind /= N_Function_Specification then
4310 Expr := Expression (N);
4312 if Present (Expr) and then Known_Null (Expr) then
4314 when N_Component_Declaration
4315 | N_Discriminant_Specification
4317 Apply_Compile_Time_Constraint_Error
4320 "(Ada 2005) null not allowed in null-excluding "
4322 Reason => CE_Null_Not_Allowed);
4324 when N_Object_Declaration =>
4325 Apply_Compile_Time_Constraint_Error
4328 "(Ada 2005) null not allowed in null-excluding "
4330 Reason => CE_Null_Not_Allowed);
4332 when N_Parameter_Specification =>
4333 Apply_Compile_Time_Constraint_Error
4336 "(Ada 2005) null not allowed in null-excluding "
4338 Reason => CE_Null_Not_Allowed);
4345 end Null_Exclusion_Static_Checks;
4347 ----------------------------------
4348 -- Conditional_Statements_Begin --
4349 ----------------------------------
4351 procedure Conditional_Statements_Begin is
4353 Saved_Checks_TOS := Saved_Checks_TOS + 1;
4355 -- If stack overflows, kill all checks, that way we know to simply reset
4356 -- the number of saved checks to zero on return. This should never occur
4359 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4362 -- In the normal case, we just make a new stack entry saving the current
4363 -- number of saved checks for a later restore.
4366 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
4368 if Debug_Flag_CC then
4369 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
4373 end Conditional_Statements_Begin;
4375 --------------------------------
4376 -- Conditional_Statements_End --
4377 --------------------------------
4379 procedure Conditional_Statements_End is
4381 pragma Assert (Saved_Checks_TOS > 0);
4383 -- If the saved checks stack overflowed, then we killed all checks, so
4384 -- setting the number of saved checks back to zero is correct. This
4385 -- should never occur in practice.
4387 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4388 Num_Saved_Checks := 0;
4390 -- In the normal case, restore the number of saved checks from the top
4394 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
4396 if Debug_Flag_CC then
4397 w ("Conditional_Statements_End: Num_Saved_Checks = ",
4402 Saved_Checks_TOS := Saved_Checks_TOS - 1;
4403 end Conditional_Statements_End;
4405 -------------------------
4406 -- Convert_From_Bignum --
4407 -------------------------
4409 function Convert_From_Bignum (N : Node_Id) return Node_Id is
4410 Loc : constant Source_Ptr := Sloc (N);
4413 pragma Assert (Is_RTE (Etype (N), RE_Bignum));
4415 -- Construct call From Bignum
4418 Make_Function_Call (Loc,
4420 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4421 Parameter_Associations => New_List (Relocate_Node (N)));
4422 end Convert_From_Bignum;
4424 -----------------------
4425 -- Convert_To_Bignum --
4426 -----------------------
4428 function Convert_To_Bignum (N : Node_Id) return Node_Id is
4429 Loc : constant Source_Ptr := Sloc (N);
4432 -- Nothing to do if Bignum already except call Relocate_Node
4434 if Is_RTE (Etype (N), RE_Bignum) then
4435 return Relocate_Node (N);
4437 -- Otherwise construct call to To_Bignum, converting the operand to the
4438 -- required Long_Long_Integer form.
4441 pragma Assert (Is_Signed_Integer_Type (Etype (N)));
4443 Make_Function_Call (Loc,
4445 New_Occurrence_Of (RTE (RE_To_Bignum), Loc),
4446 Parameter_Associations => New_List (
4447 Convert_To (Standard_Long_Long_Integer, Relocate_Node (N))));
4449 end Convert_To_Bignum;
4451 ---------------------
4452 -- Determine_Range --
4453 ---------------------
4455 Cache_Size : constant := 2 ** 10;
4456 type Cache_Index is range 0 .. Cache_Size - 1;
4457 -- Determine size of below cache (power of 2 is more efficient)
4459 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
4460 Determine_Range_Cache_V : array (Cache_Index) of Boolean;
4461 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
4462 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
4463 Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
4464 Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
4465 -- The above arrays are used to implement a small direct cache for
4466 -- Determine_Range and Determine_Range_R calls. Because of the way these
4467 -- subprograms recursively traces subexpressions, and because overflow
4468 -- checking calls the routine on the way up the tree, a quadratic behavior
4469 -- can otherwise be encountered in large expressions. The cache entry for
4470 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4471 -- by checking the actual node value stored there. The Range_Cache_V array
4472 -- records the setting of Assume_Valid for the cache entry.
4474 procedure Determine_Range
4479 Assume_Valid : Boolean := False)
4481 Typ : Entity_Id := Etype (N);
4482 -- Type to use, may get reset to base type for possibly invalid entity
4486 -- Lo and Hi bounds of left operand
4488 Lo_Right : Uint := No_Uint;
4489 Hi_Right : Uint := No_Uint;
4490 -- Lo and Hi bounds of right (or only) operand
4493 -- Temp variable used to hold a bound node
4496 -- High bound of base type of expression
4500 -- Refined values for low and high bounds, after tightening
4503 -- Used in lower level calls to indicate if call succeeded
4505 Cindex : Cache_Index;
4506 -- Used to search cache
4511 function OK_Operands return Boolean;
4512 -- Used for binary operators. Determines the ranges of the left and
4513 -- right operands, and if they are both OK, returns True, and puts
4514 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4520 function OK_Operands return Boolean is
4523 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4530 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4534 -- Start of processing for Determine_Range
4537 -- Prevent junk warnings by initializing range variables
4544 -- For temporary constants internally generated to remove side effects
4545 -- we must use the corresponding expression to determine the range of
4546 -- the expression. But note that the expander can also generate
4547 -- constants in other cases, including deferred constants.
4549 if Is_Entity_Name (N)
4550 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4551 and then Ekind (Entity (N)) = E_Constant
4552 and then Is_Internal_Name (Chars (Entity (N)))
4554 if Present (Expression (Parent (Entity (N)))) then
4556 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4558 elsif Present (Full_View (Entity (N))) then
4560 (Expression (Parent (Full_View (Entity (N)))),
4561 OK, Lo, Hi, Assume_Valid);
4569 -- If type is not defined, we can't determine its range
4573 -- We don't deal with anything except discrete types
4575 or else not Is_Discrete_Type (Typ)
4577 -- Don't deal with enumerated types with non-standard representation
4579 or else (Is_Enumeration_Type (Typ)
4580 and then Present (Enum_Pos_To_Rep (Base_Type (Typ))))
4582 -- Ignore type for which an error has been posted, since range in
4583 -- this case may well be a bogosity deriving from the error. Also
4584 -- ignore if error posted on the reference node.
4586 or else Error_Posted (N) or else Error_Posted (Typ)
4592 -- For all other cases, we can determine the range
4596 -- If value is compile time known, then the possible range is the one
4597 -- value that we know this expression definitely has.
4599 if Compile_Time_Known_Value (N) then
4600 Lo := Expr_Value (N);
4605 -- Return if already in the cache
4607 Cindex := Cache_Index (N mod Cache_Size);
4609 if Determine_Range_Cache_N (Cindex) = N
4611 Determine_Range_Cache_V (Cindex) = Assume_Valid
4613 Lo := Determine_Range_Cache_Lo (Cindex);
4614 Hi := Determine_Range_Cache_Hi (Cindex);
4618 -- Otherwise, start by finding the bounds of the type of the expression,
4619 -- the value cannot be outside this range (if it is, then we have an
4620 -- overflow situation, which is a separate check, we are talking here
4621 -- only about the expression value).
4623 -- First a check, never try to find the bounds of a generic type, since
4624 -- these bounds are always junk values, and it is only valid to look at
4625 -- the bounds in an instance.
4627 if Is_Generic_Type (Typ) then
4632 -- First step, change to use base type unless we know the value is valid
4634 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4635 or else Assume_No_Invalid_Values
4636 or else Assume_Valid
4638 -- If this is a known valid constant with a nonstatic value, it may
4639 -- have inherited a narrower subtype from its initial value; use this
4640 -- saved subtype (see sem_ch3.adb).
4642 if Is_Entity_Name (N)
4643 and then Ekind (Entity (N)) = E_Constant
4644 and then Present (Actual_Subtype (Entity (N)))
4646 Typ := Actual_Subtype (Entity (N));
4650 Typ := Underlying_Type (Base_Type (Typ));
4653 -- Retrieve the base type. Handle the case where the base type is a
4654 -- private enumeration type.
4656 Btyp := Base_Type (Typ);
4658 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4659 Btyp := Full_View (Btyp);
4662 -- We use the actual bound unless it is dynamic, in which case use the
4663 -- corresponding base type bound if possible. If we can't get a bound
4664 -- then we figure we can't determine the range (a peculiar case, that
4665 -- perhaps cannot happen, but there is no point in bombing in this
4666 -- optimization circuit.
4668 -- First the low bound
4670 Bound := Type_Low_Bound (Typ);
4672 if Compile_Time_Known_Value (Bound) then
4673 Lo := Expr_Value (Bound);
4675 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4676 Lo := Expr_Value (Type_Low_Bound (Btyp));
4683 -- Now the high bound
4685 Bound := Type_High_Bound (Typ);
4687 -- We need the high bound of the base type later on, and this should
4688 -- always be compile time known. Again, it is not clear that this
4689 -- can ever be false, but no point in bombing.
4691 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4692 Hbound := Expr_Value (Type_High_Bound (Btyp));
4700 -- If we have a static subtype, then that may have a tighter bound so
4701 -- use the upper bound of the subtype instead in this case.
4703 if Compile_Time_Known_Value (Bound) then
4704 Hi := Expr_Value (Bound);
4707 -- We may be able to refine this value in certain situations. If any
4708 -- refinement is possible, then Lor and Hir are set to possibly tighter
4709 -- bounds, and OK1 is set to True.
4713 -- For unary plus, result is limited by range of operand
4717 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4719 -- For unary minus, determine range of operand, and negate it
4723 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4730 -- For binary addition, get range of each operand and do the
4731 -- addition to get the result range.
4735 Lor := Lo_Left + Lo_Right;
4736 Hir := Hi_Left + Hi_Right;
4739 -- Division is tricky. The only case we consider is where the right
4740 -- operand is a positive constant, and in this case we simply divide
4741 -- the bounds of the left operand
4745 if Lo_Right = Hi_Right
4746 and then Lo_Right > 0
4748 Lor := Lo_Left / Lo_Right;
4749 Hir := Hi_Left / Lo_Right;
4755 -- For binary subtraction, get range of each operand and do the worst
4756 -- case subtraction to get the result range.
4758 when N_Op_Subtract =>
4760 Lor := Lo_Left - Hi_Right;
4761 Hir := Hi_Left - Lo_Right;
4764 -- For MOD, if right operand is a positive constant, then result must
4765 -- be in the allowable range of mod results.
4769 if Lo_Right = Hi_Right
4770 and then Lo_Right /= 0
4772 if Lo_Right > 0 then
4774 Hir := Lo_Right - 1;
4776 else -- Lo_Right < 0
4777 Lor := Lo_Right + 1;
4786 -- For REM, if right operand is a positive constant, then result must
4787 -- be in the allowable range of mod results.
4791 if Lo_Right = Hi_Right and then Lo_Right /= 0 then
4793 Dval : constant Uint := (abs Lo_Right) - 1;
4796 -- The sign of the result depends on the sign of the
4797 -- dividend (but not on the sign of the divisor, hence
4798 -- the abs operation above).
4818 -- Attribute reference cases
4820 when N_Attribute_Reference =>
4821 case Attribute_Name (N) is
4823 -- For Pos/Val attributes, we can refine the range using the
4824 -- possible range of values of the attribute expression.
4830 (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
4832 -- For Length attribute, use the bounds of the corresponding
4833 -- index type to refine the range.
4837 Atyp : Entity_Id := Etype (Prefix (N));
4845 if Is_Access_Type (Atyp) then
4846 Atyp := Designated_Type (Atyp);
4849 -- For string literal, we know exact value
4851 if Ekind (Atyp) = E_String_Literal_Subtype then
4853 Lo := String_Literal_Length (Atyp);
4854 Hi := String_Literal_Length (Atyp);
4858 -- Otherwise check for expression given
4860 if No (Expressions (N)) then
4864 UI_To_Int (Expr_Value (First (Expressions (N))));
4867 Indx := First_Index (Atyp);
4868 for J in 2 .. Inum loop
4869 Indx := Next_Index (Indx);
4872 -- If the index type is a formal type or derived from
4873 -- one, the bounds are not static.
4875 if Is_Generic_Type (Root_Type (Etype (Indx))) then
4881 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
4886 (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
4891 -- The maximum value for Length is the biggest
4892 -- possible gap between the values of the bounds.
4893 -- But of course, this value cannot be negative.
4895 Hir := UI_Max (Uint_0, UU - LL + 1);
4897 -- For constrained arrays, the minimum value for
4898 -- Length is taken from the actual value of the
4899 -- bounds, since the index will be exactly of this
4902 if Is_Constrained (Atyp) then
4903 Lor := UI_Max (Uint_0, UL - LU + 1);
4905 -- For an unconstrained array, the minimum value
4906 -- for length is always zero.
4915 -- No special handling for other attributes
4916 -- Probably more opportunities exist here???
4923 when N_Type_Conversion =>
4925 -- For type conversion from one discrete type to another, we can
4926 -- refine the range using the converted value.
4928 if Is_Discrete_Type (Etype (Expression (N))) then
4929 Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
4931 -- When converting a float to an integer type, determine the range
4932 -- in real first, and then convert the bounds using UR_To_Uint
4933 -- which correctly rounds away from zero when half way between two
4934 -- integers, as required by normal Ada 95 rounding semantics. It
4935 -- is only possible because analysis in GNATprove rules out the
4936 -- possibility of a NaN or infinite value.
4938 elsif GNATprove_Mode
4939 and then Is_Floating_Point_Type (Etype (Expression (N)))
4942 Lor_Real, Hir_Real : Ureal;
4944 Determine_Range_R (Expression (N), OK1, Lor_Real, Hir_Real,
4948 Lor := UR_To_Uint (Lor_Real);
4949 Hir := UR_To_Uint (Hir_Real);
4957 -- Nothing special to do for all other expression kinds
4965 -- At this stage, if OK1 is true, then we know that the actual result of
4966 -- the computed expression is in the range Lor .. Hir. We can use this
4967 -- to restrict the possible range of results.
4971 -- If the refined value of the low bound is greater than the type
4972 -- low bound, then reset it to the more restrictive value. However,
4973 -- we do NOT do this for the case of a modular type where the
4974 -- possible upper bound on the value is above the base type high
4975 -- bound, because that means the result could wrap.
4978 and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound)
4983 -- Similarly, if the refined value of the high bound is less than the
4984 -- value so far, then reset it to the more restrictive value. Again,
4985 -- we do not do this if the refined low bound is negative for a
4986 -- modular type, since this would wrap.
4989 and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0)
4995 -- Set cache entry for future call and we are all done
4997 Determine_Range_Cache_N (Cindex) := N;
4998 Determine_Range_Cache_V (Cindex) := Assume_Valid;
4999 Determine_Range_Cache_Lo (Cindex) := Lo;
5000 Determine_Range_Cache_Hi (Cindex) := Hi;
5003 -- If any exception occurs, it means that we have some bug in the compiler,
5004 -- possibly triggered by a previous error, or by some unforeseen peculiar
5005 -- occurrence. However, this is only an optimization attempt, so there is
5006 -- really no point in crashing the compiler. Instead we just decide, too
5007 -- bad, we can't figure out a range in this case after all.
5012 -- Debug flag K disables this behavior (useful for debugging)
5014 if Debug_Flag_K then
5022 end Determine_Range;
5024 -----------------------
5025 -- Determine_Range_R --
5026 -----------------------
5028 procedure Determine_Range_R
5033 Assume_Valid : Boolean := False)
5035 Typ : Entity_Id := Etype (N);
5036 -- Type to use, may get reset to base type for possibly invalid entity
5040 -- Lo and Hi bounds of left operand
5042 Lo_Right : Ureal := No_Ureal;
5043 Hi_Right : Ureal := No_Ureal;
5044 -- Lo and Hi bounds of right (or only) operand
5047 -- Temp variable used to hold a bound node
5050 -- High bound of base type of expression
5054 -- Refined values for low and high bounds, after tightening
5057 -- Used in lower level calls to indicate if call succeeded
5059 Cindex : Cache_Index;
5060 -- Used to search cache
5065 function OK_Operands return Boolean;
5066 -- Used for binary operators. Determines the ranges of the left and
5067 -- right operands, and if they are both OK, returns True, and puts
5068 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
5070 function Round_Machine (B : Ureal) return Ureal;
5071 -- B is a real bound. Round it using mode Round_Even.
5077 function OK_Operands return Boolean is
5080 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
5087 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
5095 function Round_Machine (B : Ureal) return Ureal is
5097 return Machine (Typ, B, Round_Even, N);
5100 -- Start of processing for Determine_Range_R
5103 -- Prevent junk warnings by initializing range variables
5110 -- For temporary constants internally generated to remove side effects
5111 -- we must use the corresponding expression to determine the range of
5112 -- the expression. But note that the expander can also generate
5113 -- constants in other cases, including deferred constants.
5115 if Is_Entity_Name (N)
5116 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
5117 and then Ekind (Entity (N)) = E_Constant
5118 and then Is_Internal_Name (Chars (Entity (N)))
5120 if Present (Expression (Parent (Entity (N)))) then
5122 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
5124 elsif Present (Full_View (Entity (N))) then
5126 (Expression (Parent (Full_View (Entity (N)))),
5127 OK, Lo, Hi, Assume_Valid);
5136 -- If type is not defined, we can't determine its range
5140 -- We don't deal with anything except IEEE floating-point types
5142 or else not Is_Floating_Point_Type (Typ)
5143 or else Float_Rep (Typ) /= IEEE_Binary
5145 -- Ignore type for which an error has been posted, since range in
5146 -- this case may well be a bogosity deriving from the error. Also
5147 -- ignore if error posted on the reference node.
5149 or else Error_Posted (N) or else Error_Posted (Typ)
5155 -- For all other cases, we can determine the range
5159 -- If value is compile time known, then the possible range is the one
5160 -- value that we know this expression definitely has.
5162 if Compile_Time_Known_Value (N) then
5163 Lo := Expr_Value_R (N);
5168 -- Return if already in the cache
5170 Cindex := Cache_Index (N mod Cache_Size);
5172 if Determine_Range_Cache_N (Cindex) = N
5174 Determine_Range_Cache_V (Cindex) = Assume_Valid
5176 Lo := Determine_Range_Cache_Lo_R (Cindex);
5177 Hi := Determine_Range_Cache_Hi_R (Cindex);
5181 -- Otherwise, start by finding the bounds of the type of the expression,
5182 -- the value cannot be outside this range (if it is, then we have an
5183 -- overflow situation, which is a separate check, we are talking here
5184 -- only about the expression value).
5186 -- First a check, never try to find the bounds of a generic type, since
5187 -- these bounds are always junk values, and it is only valid to look at
5188 -- the bounds in an instance.
5190 if Is_Generic_Type (Typ) then
5195 -- First step, change to use base type unless we know the value is valid
5197 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
5198 or else Assume_No_Invalid_Values
5199 or else Assume_Valid
5203 Typ := Underlying_Type (Base_Type (Typ));
5206 -- Retrieve the base type. Handle the case where the base type is a
5209 Btyp := Base_Type (Typ);
5211 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
5212 Btyp := Full_View (Btyp);
5215 -- We use the actual bound unless it is dynamic, in which case use the
5216 -- corresponding base type bound if possible. If we can't get a bound
5217 -- then we figure we can't determine the range (a peculiar case, that
5218 -- perhaps cannot happen, but there is no point in bombing in this
5219 -- optimization circuit).
5221 -- First the low bound
5223 Bound := Type_Low_Bound (Typ);
5225 if Compile_Time_Known_Value (Bound) then
5226 Lo := Expr_Value_R (Bound);
5228 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
5229 Lo := Expr_Value_R (Type_Low_Bound (Btyp));
5236 -- Now the high bound
5238 Bound := Type_High_Bound (Typ);
5240 -- We need the high bound of the base type later on, and this should
5241 -- always be compile time known. Again, it is not clear that this
5242 -- can ever be false, but no point in bombing.
5244 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
5245 Hbound := Expr_Value_R (Type_High_Bound (Btyp));
5253 -- If we have a static subtype, then that may have a tighter bound so
5254 -- use the upper bound of the subtype instead in this case.
5256 if Compile_Time_Known_Value (Bound) then
5257 Hi := Expr_Value_R (Bound);
5260 -- We may be able to refine this value in certain situations. If any
5261 -- refinement is possible, then Lor and Hir are set to possibly tighter
5262 -- bounds, and OK1 is set to True.
5266 -- For unary plus, result is limited by range of operand
5270 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
5272 -- For unary minus, determine range of operand, and negate it
5276 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
5283 -- For binary addition, get range of each operand and do the
5284 -- addition to get the result range.
5288 Lor := Round_Machine (Lo_Left + Lo_Right);
5289 Hir := Round_Machine (Hi_Left + Hi_Right);
5292 -- For binary subtraction, get range of each operand and do the worst
5293 -- case subtraction to get the result range.
5295 when N_Op_Subtract =>
5297 Lor := Round_Machine (Lo_Left - Hi_Right);
5298 Hir := Round_Machine (Hi_Left - Lo_Right);
5301 -- For multiplication, get range of each operand and do the
5302 -- four multiplications to get the result range.
5304 when N_Op_Multiply =>
5307 M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
5308 M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
5309 M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
5310 M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
5313 Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
5314 Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
5318 -- For division, consider separately the cases where the right
5319 -- operand is positive or negative. Otherwise, the right operand
5320 -- can be arbitrarily close to zero, so the result is likely to
5321 -- be unbounded in one direction, do not attempt to compute it.
5326 -- Right operand is positive
5328 if Lo_Right > Ureal_0 then
5330 -- If the low bound of the left operand is negative, obtain
5331 -- the overall low bound by dividing it by the smallest
5332 -- value of the right operand, and otherwise by the largest
5333 -- value of the right operand.
5335 if Lo_Left < Ureal_0 then
5336 Lor := Round_Machine (Lo_Left / Lo_Right);
5338 Lor := Round_Machine (Lo_Left / Hi_Right);
5341 -- If the high bound of the left operand is negative, obtain
5342 -- the overall high bound by dividing it by the largest
5343 -- value of the right operand, and otherwise by the
5344 -- smallest value of the right operand.
5346 if Hi_Left < Ureal_0 then
5347 Hir := Round_Machine (Hi_Left / Hi_Right);
5349 Hir := Round_Machine (Hi_Left / Lo_Right);
5352 -- Right operand is negative
5354 elsif Hi_Right < Ureal_0 then
5356 -- If the low bound of the left operand is negative, obtain
5357 -- the overall low bound by dividing it by the largest
5358 -- value of the right operand, and otherwise by the smallest
5359 -- value of the right operand.
5361 if Lo_Left < Ureal_0 then
5362 Lor := Round_Machine (Lo_Left / Hi_Right);
5364 Lor := Round_Machine (Lo_Left / Lo_Right);
5367 -- If the high bound of the left operand is negative, obtain
5368 -- the overall high bound by dividing it by the smallest
5369 -- value of the right operand, and otherwise by the
5370 -- largest value of the right operand.
5372 if Hi_Left < Ureal_0 then
5373 Hir := Round_Machine (Hi_Left / Lo_Right);
5375 Hir := Round_Machine (Hi_Left / Hi_Right);
5383 when N_Type_Conversion =>
5385 -- For type conversion from one floating-point type to another, we
5386 -- can refine the range using the converted value.
5388 if Is_Floating_Point_Type (Etype (Expression (N))) then
5389 Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
5391 -- When converting an integer to a floating-point type, determine
5392 -- the range in integer first, and then convert the bounds.
5394 elsif Is_Discrete_Type (Etype (Expression (N))) then
5401 (Expression (N), OK1, Lor_Int, Hir_Int, Assume_Valid);
5404 Lor := Round_Machine (UR_From_Uint (Lor_Int));
5405 Hir := Round_Machine (UR_From_Uint (Hir_Int));
5413 -- Nothing special to do for all other expression kinds
5421 -- At this stage, if OK1 is true, then we know that the actual result of
5422 -- the computed expression is in the range Lor .. Hir. We can use this
5423 -- to restrict the possible range of results.
5427 -- If the refined value of the low bound is greater than the type
5428 -- low bound, then reset it to the more restrictive value.
5434 -- Similarly, if the refined value of the high bound is less than the
5435 -- value so far, then reset it to the more restrictive value.
5442 -- Set cache entry for future call and we are all done
5444 Determine_Range_Cache_N (Cindex) := N;
5445 Determine_Range_Cache_V (Cindex) := Assume_Valid;
5446 Determine_Range_Cache_Lo_R (Cindex) := Lo;
5447 Determine_Range_Cache_Hi_R (Cindex) := Hi;
5450 -- If any exception occurs, it means that we have some bug in the compiler,
5451 -- possibly triggered by a previous error, or by some unforeseen peculiar
5452 -- occurrence. However, this is only an optimization attempt, so there is
5453 -- really no point in crashing the compiler. Instead we just decide, too
5454 -- bad, we can't figure out a range in this case after all.
5459 -- Debug flag K disables this behavior (useful for debugging)
5461 if Debug_Flag_K then
5469 end Determine_Range_R;
5471 ------------------------------------
5472 -- Discriminant_Checks_Suppressed --
5473 ------------------------------------
5475 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
5478 if Is_Unchecked_Union (E) then
5480 elsif Checks_May_Be_Suppressed (E) then
5481 return Is_Check_Suppressed (E, Discriminant_Check);
5485 return Scope_Suppress.Suppress (Discriminant_Check);
5486 end Discriminant_Checks_Suppressed;
5488 --------------------------------
5489 -- Division_Checks_Suppressed --
5490 --------------------------------
5492 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
5494 if Present (E) and then Checks_May_Be_Suppressed (E) then
5495 return Is_Check_Suppressed (E, Division_Check);
5497 return Scope_Suppress.Suppress (Division_Check);
5499 end Division_Checks_Suppressed;
5501 --------------------------------------
5502 -- Duplicated_Tag_Checks_Suppressed --
5503 --------------------------------------
5505 function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
5507 if Present (E) and then Checks_May_Be_Suppressed (E) then
5508 return Is_Check_Suppressed (E, Duplicated_Tag_Check);
5510 return Scope_Suppress.Suppress (Duplicated_Tag_Check);
5512 end Duplicated_Tag_Checks_Suppressed;
5514 -----------------------------------
5515 -- Elaboration_Checks_Suppressed --
5516 -----------------------------------
5518 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
5520 -- The complication in this routine is that if we are in the dynamic
5521 -- model of elaboration, we also check All_Checks, since All_Checks
5522 -- does not set Elaboration_Check explicitly.
5525 if Kill_Elaboration_Checks (E) then
5528 elsif Checks_May_Be_Suppressed (E) then
5529 if Is_Check_Suppressed (E, Elaboration_Check) then
5532 elsif Dynamic_Elaboration_Checks then
5533 return Is_Check_Suppressed (E, All_Checks);
5541 if Scope_Suppress.Suppress (Elaboration_Check) then
5544 elsif Dynamic_Elaboration_Checks then
5545 return Scope_Suppress.Suppress (All_Checks);
5550 end Elaboration_Checks_Suppressed;
5552 ---------------------------
5553 -- Enable_Overflow_Check --
5554 ---------------------------
5556 procedure Enable_Overflow_Check (N : Node_Id) is
5557 Typ : constant Entity_Id := Base_Type (Etype (N));
5558 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
5566 Do_Ovflow_Check : Boolean;
5569 if Debug_Flag_CC then
5570 w ("Enable_Overflow_Check for node ", Int (N));
5571 Write_Str (" Source location = ");
5576 -- No check if overflow checks suppressed for type of node
5578 if Overflow_Checks_Suppressed (Etype (N)) then
5581 -- Nothing to do for unsigned integer types, which do not overflow
5583 elsif Is_Modular_Integer_Type (Typ) then
5587 -- This is the point at which processing for STRICT mode diverges
5588 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5589 -- probably more extreme that it needs to be, but what is going on here
5590 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5591 -- to leave the processing for STRICT mode untouched. There were
5592 -- two reasons for this. First it avoided any incompatible change of
5593 -- behavior. Second, it guaranteed that STRICT mode continued to be
5596 -- The big difference is that in STRICT mode there is a fair amount of
5597 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5598 -- know that no check is needed. We skip all that in the two new modes,
5599 -- since really overflow checking happens over a whole subtree, and we
5600 -- do the corresponding optimizations later on when applying the checks.
5602 if Mode in Minimized_Or_Eliminated then
5603 if not (Overflow_Checks_Suppressed (Etype (N)))
5604 and then not (Is_Entity_Name (N)
5605 and then Overflow_Checks_Suppressed (Entity (N)))
5607 Activate_Overflow_Check (N);
5610 if Debug_Flag_CC then
5611 w ("Minimized/Eliminated mode");
5617 -- Remainder of processing is for STRICT case, and is unchanged from
5618 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5620 -- Nothing to do if the range of the result is known OK. We skip this
5621 -- for conversions, since the caller already did the check, and in any
5622 -- case the condition for deleting the check for a type conversion is
5625 if Nkind (N) /= N_Type_Conversion then
5626 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
5628 -- Note in the test below that we assume that the range is not OK
5629 -- if a bound of the range is equal to that of the type. That's not
5630 -- quite accurate but we do this for the following reasons:
5632 -- a) The way that Determine_Range works, it will typically report
5633 -- the bounds of the value as being equal to the bounds of the
5634 -- type, because it either can't tell anything more precise, or
5635 -- does not think it is worth the effort to be more precise.
5637 -- b) It is very unusual to have a situation in which this would
5638 -- generate an unnecessary overflow check (an example would be
5639 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5640 -- literal value one is added).
5642 -- c) The alternative is a lot of special casing in this routine
5643 -- which would partially duplicate Determine_Range processing.
5646 Do_Ovflow_Check := True;
5648 -- Note that the following checks are quite deliberately > and <
5649 -- rather than >= and <= as explained above.
5651 if Lo > Expr_Value (Type_Low_Bound (Typ))
5653 Hi < Expr_Value (Type_High_Bound (Typ))
5655 Do_Ovflow_Check := False;
5657 -- Despite the comments above, it is worth dealing specially with
5658 -- division specially. The only case where integer division can
5659 -- overflow is (largest negative number) / (-1). So we will do
5660 -- an extra range analysis to see if this is possible.
5662 elsif Nkind (N) = N_Op_Divide then
5664 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5666 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then
5667 Do_Ovflow_Check := False;
5671 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5673 if OK and then (Lo > Uint_Minus_1
5677 Do_Ovflow_Check := False;
5682 -- If no overflow check required, we are done
5684 if not Do_Ovflow_Check then
5685 if Debug_Flag_CC then
5686 w ("No overflow check required");
5694 -- If not in optimizing mode, set flag and we are done. We are also done
5695 -- (and just set the flag) if the type is not a discrete type, since it
5696 -- is not worth the effort to eliminate checks for other than discrete
5697 -- types. In addition, we take this same path if we have stored the
5698 -- maximum number of checks possible already (a very unlikely situation,
5699 -- but we do not want to blow up).
5701 if Optimization_Level = 0
5702 or else not Is_Discrete_Type (Etype (N))
5703 or else Num_Saved_Checks = Saved_Checks'Last
5705 Activate_Overflow_Check (N);
5707 if Debug_Flag_CC then
5708 w ("Optimization off");
5714 -- Otherwise evaluate and check the expression
5719 Target_Type => Empty,
5725 if Debug_Flag_CC then
5726 w ("Called Find_Check");
5730 w (" Check_Num = ", Chk);
5731 w (" Ent = ", Int (Ent));
5732 Write_Str (" Ofs = ");
5737 -- If check is not of form to optimize, then set flag and we are done
5740 Activate_Overflow_Check (N);
5744 -- If check is already performed, then return without setting flag
5747 if Debug_Flag_CC then
5748 w ("Check suppressed!");
5754 -- Here we will make a new entry for the new check
5756 Activate_Overflow_Check (N);
5757 Num_Saved_Checks := Num_Saved_Checks + 1;
5758 Saved_Checks (Num_Saved_Checks) :=
5763 Target_Type => Empty);
5765 if Debug_Flag_CC then
5766 w ("Make new entry, check number = ", Num_Saved_Checks);
5767 w (" Entity = ", Int (Ent));
5768 Write_Str (" Offset = ");
5770 w (" Check_Type = O");
5771 w (" Target_Type = Empty");
5774 -- If we get an exception, then something went wrong, probably because of
5775 -- an error in the structure of the tree due to an incorrect program. Or
5776 -- it may be a bug in the optimization circuit. In either case the safest
5777 -- thing is simply to set the check flag unconditionally.
5781 Activate_Overflow_Check (N);
5783 if Debug_Flag_CC then
5784 w (" exception occurred, overflow flag set");
5788 end Enable_Overflow_Check;
5790 ------------------------
5791 -- Enable_Range_Check --
5792 ------------------------
5794 procedure Enable_Range_Check (N : Node_Id) is
5803 -- Return if unchecked type conversion with range check killed. In this
5804 -- case we never set the flag (that's what Kill_Range_Check is about).
5806 if Nkind (N) = N_Unchecked_Type_Conversion
5807 and then Kill_Range_Check (N)
5812 -- Do not set range check flag if parent is assignment statement or
5813 -- object declaration with Suppress_Assignment_Checks flag set
5815 if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
5816 and then Suppress_Assignment_Checks (Parent (N))
5821 -- Check for various cases where we should suppress the range check
5823 -- No check if range checks suppressed for type of node
5825 if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then
5828 -- No check if node is an entity name, and range checks are suppressed
5829 -- for this entity, or for the type of this entity.
5831 elsif Is_Entity_Name (N)
5832 and then (Range_Checks_Suppressed (Entity (N))
5833 or else Range_Checks_Suppressed (Etype (Entity (N))))
5837 -- No checks if index of array, and index checks are suppressed for
5838 -- the array object or the type of the array.
5840 elsif Nkind (Parent (N)) = N_Indexed_Component then
5842 Pref : constant Node_Id := Prefix (Parent (N));
5844 if Is_Entity_Name (Pref)
5845 and then Index_Checks_Suppressed (Entity (Pref))
5848 elsif Index_Checks_Suppressed (Etype (Pref)) then
5854 -- Debug trace output
5856 if Debug_Flag_CC then
5857 w ("Enable_Range_Check for node ", Int (N));
5858 Write_Str (" Source location = ");
5863 -- If not in optimizing mode, set flag and we are done. We are also done
5864 -- (and just set the flag) if the type is not a discrete type, since it
5865 -- is not worth the effort to eliminate checks for other than discrete
5866 -- types. In addition, we take this same path if we have stored the
5867 -- maximum number of checks possible already (a very unlikely situation,
5868 -- but we do not want to blow up).
5870 if Optimization_Level = 0
5871 or else No (Etype (N))
5872 or else not Is_Discrete_Type (Etype (N))
5873 or else Num_Saved_Checks = Saved_Checks'Last
5875 Activate_Range_Check (N);
5877 if Debug_Flag_CC then
5878 w ("Optimization off");
5884 -- Otherwise find out the target type
5888 -- For assignment, use left side subtype
5890 if Nkind (P) = N_Assignment_Statement
5891 and then Expression (P) = N
5893 Ttyp := Etype (Name (P));
5895 -- For indexed component, use subscript subtype
5897 elsif Nkind (P) = N_Indexed_Component then
5904 Atyp := Etype (Prefix (P));
5906 if Is_Access_Type (Atyp) then
5907 Atyp := Designated_Type (Atyp);
5909 -- If the prefix is an access to an unconstrained array,
5910 -- perform check unconditionally: it depends on the bounds of
5911 -- an object and we cannot currently recognize whether the test
5912 -- may be redundant.
5914 if not Is_Constrained (Atyp) then
5915 Activate_Range_Check (N);
5919 -- Ditto if prefix is simply an unconstrained array. We used
5920 -- to think this case was OK, if the prefix was not an explicit
5921 -- dereference, but we have now seen a case where this is not
5922 -- true, so it is safer to just suppress the optimization in this
5923 -- case. The back end is getting better at eliminating redundant
5924 -- checks in any case, so the loss won't be important.
5926 elsif Is_Array_Type (Atyp)
5927 and then not Is_Constrained (Atyp)
5929 Activate_Range_Check (N);
5933 Indx := First_Index (Atyp);
5934 Subs := First (Expressions (P));
5937 Ttyp := Etype (Indx);
5946 -- For now, ignore all other cases, they are not so interesting
5949 if Debug_Flag_CC then
5950 w (" target type not found, flag set");
5953 Activate_Range_Check (N);
5957 -- Evaluate and check the expression
5962 Target_Type => Ttyp,
5968 if Debug_Flag_CC then
5969 w ("Called Find_Check");
5970 w ("Target_Typ = ", Int (Ttyp));
5974 w (" Check_Num = ", Chk);
5975 w (" Ent = ", Int (Ent));
5976 Write_Str (" Ofs = ");
5981 -- If check is not of form to optimize, then set flag and we are done
5984 if Debug_Flag_CC then
5985 w (" expression not of optimizable type, flag set");
5988 Activate_Range_Check (N);
5992 -- If check is already performed, then return without setting flag
5995 if Debug_Flag_CC then
5996 w ("Check suppressed!");
6002 -- Here we will make a new entry for the new check
6004 Activate_Range_Check (N);
6005 Num_Saved_Checks := Num_Saved_Checks + 1;
6006 Saved_Checks (Num_Saved_Checks) :=
6011 Target_Type => Ttyp);
6013 if Debug_Flag_CC then
6014 w ("Make new entry, check number = ", Num_Saved_Checks);
6015 w (" Entity = ", Int (Ent));
6016 Write_Str (" Offset = ");
6018 w (" Check_Type = R");
6019 w (" Target_Type = ", Int (Ttyp));
6020 pg (Union_Id (Ttyp));
6023 -- If we get an exception, then something went wrong, probably because of
6024 -- an error in the structure of the tree due to an incorrect program. Or
6025 -- it may be a bug in the optimization circuit. In either case the safest
6026 -- thing is simply to set the check flag unconditionally.
6030 Activate_Range_Check (N);
6032 if Debug_Flag_CC then
6033 w (" exception occurred, range flag set");
6037 end Enable_Range_Check;
6043 procedure Ensure_Valid
6045 Holes_OK : Boolean := False;
6046 Related_Id : Entity_Id := Empty;
6047 Is_Low_Bound : Boolean := False;
6048 Is_High_Bound : Boolean := False)
6050 Typ : constant Entity_Id := Etype (Expr);
6053 -- Ignore call if we are not doing any validity checking
6055 if not Validity_Checks_On then
6058 -- Ignore call if range or validity checks suppressed on entity or type
6060 elsif Range_Or_Validity_Checks_Suppressed (Expr) then
6063 -- No check required if expression is from the expander, we assume the
6064 -- expander will generate whatever checks are needed. Note that this is
6065 -- not just an optimization, it avoids infinite recursions.
6067 -- Unchecked conversions must be checked, unless they are initialized
6068 -- scalar values, as in a component assignment in an init proc.
6070 -- In addition, we force a check if Force_Validity_Checks is set
6072 elsif not Comes_From_Source (Expr)
6074 (Nkind (Expr) = N_Identifier
6075 and then Present (Renamed_Object (Entity (Expr)))
6076 and then Comes_From_Source (Renamed_Object (Entity (Expr))))
6077 and then not Force_Validity_Checks
6078 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
6079 or else Kill_Range_Check (Expr))
6083 -- No check required if expression is known to have valid value
6085 elsif Expr_Known_Valid (Expr) then
6088 -- No check needed within a generated predicate function. Validity
6089 -- of input value will have been checked earlier.
6091 elsif Ekind (Current_Scope) = E_Function
6092 and then Is_Predicate_Function (Current_Scope)
6096 -- Ignore case of enumeration with holes where the flag is set not to
6097 -- worry about holes, since no special validity check is needed
6099 elsif Is_Enumeration_Type (Typ)
6100 and then Has_Non_Standard_Rep (Typ)
6105 -- No check required on the left-hand side of an assignment
6107 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
6108 and then Expr = Name (Parent (Expr))
6112 -- No check on a universal real constant. The context will eventually
6113 -- convert it to a machine number for some target type, or report an
6116 elsif Nkind (Expr) = N_Real_Literal
6117 and then Etype (Expr) = Universal_Real
6121 -- If the expression denotes a component of a packed boolean array,
6122 -- no possible check applies. We ignore the old ACATS chestnuts that
6123 -- involve Boolean range True..True.
6125 -- Note: validity checks are generated for expressions that yield a
6126 -- scalar type, when it is possible to create a value that is outside of
6127 -- the type. If this is a one-bit boolean no such value exists. This is
6128 -- an optimization, and it also prevents compiler blowing up during the
6129 -- elaboration of improperly expanded packed array references.
6131 elsif Nkind (Expr) = N_Indexed_Component
6132 and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
6133 and then Root_Type (Etype (Expr)) = Standard_Boolean
6137 -- For an expression with actions, we want to insert the validity check
6138 -- on the final Expression.
6140 elsif Nkind (Expr) = N_Expression_With_Actions then
6141 Ensure_Valid (Expression (Expr));
6144 -- An annoying special case. If this is an out parameter of a scalar
6145 -- type, then the value is not going to be accessed, therefore it is
6146 -- inappropriate to do any validity check at the call site. Likewise
6147 -- if the parameter is passed by reference.
6150 -- Only need to worry about scalar types
6152 if Is_Scalar_Type (Typ) then
6162 -- Find actual argument (which may be a parameter association)
6163 -- and the parent of the actual argument (the call statement)
6168 if Nkind (P) = N_Parameter_Association then
6173 -- If this is an indirect or dispatching call, get signature
6174 -- from the subprogram type.
6176 if Nkind_In (P, N_Entry_Call_Statement,
6178 N_Procedure_Call_Statement)
6180 E := Get_Called_Entity (P);
6181 L := Parameter_Associations (P);
6183 -- Only need to worry if there are indeed actuals, and if
6184 -- this could be a subprogram call, otherwise we cannot get
6185 -- a match (either we are not an argument, or the mode of
6186 -- the formal is not OUT). This test also filters out the
6189 if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
6191 -- This is the loop through parameters, looking for an
6192 -- OUT parameter for which we are the argument.
6194 F := First_Formal (E);
6196 while Present (F) loop
6198 and then (Ekind (F) = E_Out_Parameter
6199 or else Mechanism (F) = By_Reference)
6213 -- If this is a boolean expression, only its elementary operands need
6214 -- checking: if they are valid, a boolean or short-circuit operation
6215 -- with them will be valid as well.
6217 if Base_Type (Typ) = Standard_Boolean
6219 (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit)
6224 -- If we fall through, a validity check is required
6226 Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound);
6228 if Is_Entity_Name (Expr)
6229 and then Safe_To_Capture_Value (Expr, Entity (Expr))
6231 Set_Is_Known_Valid (Entity (Expr));
6235 ----------------------
6236 -- Expr_Known_Valid --
6237 ----------------------
6239 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
6240 Typ : constant Entity_Id := Etype (Expr);
6243 -- Non-scalar types are always considered valid, since they never give
6244 -- rise to the issues of erroneous or bounded error behavior that are
6245 -- the concern. In formal reference manual terms the notion of validity
6246 -- only applies to scalar types. Note that even when packed arrays are
6247 -- represented using modular types, they are still arrays semantically,
6248 -- so they are also always valid (in particular, the unused bits can be
6249 -- random rubbish without affecting the validity of the array value).
6251 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then
6254 -- If no validity checking, then everything is considered valid
6256 elsif not Validity_Checks_On then
6259 -- Floating-point types are considered valid unless floating-point
6260 -- validity checks have been specifically turned on.
6262 elsif Is_Floating_Point_Type (Typ)
6263 and then not Validity_Check_Floating_Point
6267 -- If the expression is the value of an object that is known to be
6268 -- valid, then clearly the expression value itself is valid.
6270 elsif Is_Entity_Name (Expr)
6271 and then Is_Known_Valid (Entity (Expr))
6273 -- Exclude volatile variables
6275 and then not Treat_As_Volatile (Entity (Expr))
6279 -- References to discriminants are always considered valid. The value
6280 -- of a discriminant gets checked when the object is built. Within the
6281 -- record, we consider it valid, and it is important to do so, since
6282 -- otherwise we can try to generate bogus validity checks which
6283 -- reference discriminants out of scope. Discriminants of concurrent
6284 -- types are excluded for the same reason.
6286 elsif Is_Entity_Name (Expr)
6287 and then Denotes_Discriminant (Expr, Check_Concurrent => True)
6291 -- If the type is one for which all values are known valid, then we are
6292 -- sure that the value is valid except in the slightly odd case where
6293 -- the expression is a reference to a variable whose size has been
6294 -- explicitly set to a value greater than the object size.
6296 elsif Is_Known_Valid (Typ) then
6297 if Is_Entity_Name (Expr)
6298 and then Ekind (Entity (Expr)) = E_Variable
6299 and then Esize (Entity (Expr)) > Esize (Typ)
6306 -- Integer and character literals always have valid values, where
6307 -- appropriate these will be range checked in any case.
6309 elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
6312 -- If we have a type conversion or a qualification of a known valid
6313 -- value, then the result will always be valid.
6315 elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
6316 return Expr_Known_Valid (Expression (Expr));
6318 -- Case of expression is a non-floating-point operator. In this case we
6319 -- can assume the result is valid the generated code for the operator
6320 -- will include whatever checks are needed (e.g. range checks) to ensure
6321 -- validity. This assumption does not hold for the floating-point case,
6322 -- since floating-point operators can generate Infinite or NaN results
6323 -- which are considered invalid.
6325 -- Historical note: in older versions, the exemption of floating-point
6326 -- types from this assumption was done only in cases where the parent
6327 -- was an assignment, function call or parameter association. Presumably
6328 -- the idea was that in other contexts, the result would be checked
6329 -- elsewhere, but this list of cases was missing tests (at least the
6330 -- N_Object_Declaration case, as shown by a reported missing validity
6331 -- check), and it is not clear why function calls but not procedure
6332 -- calls were tested for. It really seems more accurate and much
6333 -- safer to recognize that expressions which are the result of a
6334 -- floating-point operator can never be assumed to be valid.
6336 elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then
6339 -- The result of a membership test is always valid, since it is true or
6340 -- false, there are no other possibilities.
6342 elsif Nkind (Expr) in N_Membership_Test then
6345 -- For all other cases, we do not know the expression is valid
6350 end Expr_Known_Valid;
6356 procedure Find_Check
6358 Check_Type : Character;
6359 Target_Type : Entity_Id;
6360 Entry_OK : out Boolean;
6361 Check_Num : out Nat;
6362 Ent : out Entity_Id;
6365 function Within_Range_Of
6366 (Target_Type : Entity_Id;
6367 Check_Type : Entity_Id) return Boolean;
6368 -- Given a requirement for checking a range against Target_Type, and
6369 -- and a range Check_Type against which a check has already been made,
6370 -- determines if the check against check type is sufficient to ensure
6371 -- that no check against Target_Type is required.
6373 ---------------------
6374 -- Within_Range_Of --
6375 ---------------------
6377 function Within_Range_Of
6378 (Target_Type : Entity_Id;
6379 Check_Type : Entity_Id) return Boolean
6382 if Target_Type = Check_Type then
6387 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
6388 Thi : constant Node_Id := Type_High_Bound (Target_Type);
6389 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
6390 Chi : constant Node_Id := Type_High_Bound (Check_Type);
6394 or else (Compile_Time_Known_Value (Tlo)
6396 Compile_Time_Known_Value (Clo)
6398 Expr_Value (Clo) >= Expr_Value (Tlo)))
6401 or else (Compile_Time_Known_Value (Thi)
6403 Compile_Time_Known_Value (Chi)
6405 Expr_Value (Chi) <= Expr_Value (Clo)))
6413 end Within_Range_Of;
6415 -- Start of processing for Find_Check
6418 -- Establish default, in case no entry is found
6422 -- Case of expression is simple entity reference
6424 if Is_Entity_Name (Expr) then
6425 Ent := Entity (Expr);
6428 -- Case of expression is entity + known constant
6430 elsif Nkind (Expr) = N_Op_Add
6431 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6432 and then Is_Entity_Name (Left_Opnd (Expr))
6434 Ent := Entity (Left_Opnd (Expr));
6435 Ofs := Expr_Value (Right_Opnd (Expr));
6437 -- Case of expression is entity - known constant
6439 elsif Nkind (Expr) = N_Op_Subtract
6440 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6441 and then Is_Entity_Name (Left_Opnd (Expr))
6443 Ent := Entity (Left_Opnd (Expr));
6444 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
6446 -- Any other expression is not of the right form
6455 -- Come here with expression of appropriate form, check if entity is an
6456 -- appropriate one for our purposes.
6458 if (Ekind (Ent) = E_Variable
6459 or else Is_Constant_Object (Ent))
6460 and then not Is_Library_Level_Entity (Ent)
6468 -- See if there is matching check already
6470 for J in reverse 1 .. Num_Saved_Checks loop
6472 SC : Saved_Check renames Saved_Checks (J);
6474 if SC.Killed = False
6475 and then SC.Entity = Ent
6476 and then SC.Offset = Ofs
6477 and then SC.Check_Type = Check_Type
6478 and then Within_Range_Of (Target_Type, SC.Target_Type)
6486 -- If we fall through entry was not found
6491 ---------------------------------
6492 -- Generate_Discriminant_Check --
6493 ---------------------------------
6495 -- Note: the code for this procedure is derived from the
6496 -- Emit_Discriminant_Check Routine in trans.c.
6498 procedure Generate_Discriminant_Check (N : Node_Id) is
6499 Loc : constant Source_Ptr := Sloc (N);
6500 Pref : constant Node_Id := Prefix (N);
6501 Sel : constant Node_Id := Selector_Name (N);
6503 Orig_Comp : constant Entity_Id :=
6504 Original_Record_Component (Entity (Sel));
6505 -- The original component to be checked
6507 Discr_Fct : constant Entity_Id :=
6508 Discriminant_Checking_Func (Orig_Comp);
6509 -- The discriminant checking function
6512 -- One discriminant to be checked in the type
6514 Real_Discr : Entity_Id;
6515 -- Actual discriminant in the call
6517 Pref_Type : Entity_Id;
6518 -- Type of relevant prefix (ignoring private/access stuff)
6521 -- List of arguments for function call
6524 -- Keep track of the formal corresponding to the actual we build for
6525 -- each discriminant, in order to be able to perform the necessary type
6529 -- Selected component reference for checking function argument
6532 Pref_Type := Etype (Pref);
6534 -- Force evaluation of the prefix, so that it does not get evaluated
6535 -- twice (once for the check, once for the actual reference). Such a
6536 -- double evaluation is always a potential source of inefficiency, and
6537 -- is functionally incorrect in the volatile case, or when the prefix
6538 -- may have side effects. A nonvolatile entity or a component of a
6539 -- nonvolatile entity requires no evaluation.
6541 if Is_Entity_Name (Pref) then
6542 if Treat_As_Volatile (Entity (Pref)) then
6543 Force_Evaluation (Pref, Name_Req => True);
6546 elsif Treat_As_Volatile (Etype (Pref)) then
6547 Force_Evaluation (Pref, Name_Req => True);
6549 elsif Nkind (Pref) = N_Selected_Component
6550 and then Is_Entity_Name (Prefix (Pref))
6555 Force_Evaluation (Pref, Name_Req => True);
6558 -- For a tagged type, use the scope of the original component to
6559 -- obtain the type, because ???
6561 if Is_Tagged_Type (Scope (Orig_Comp)) then
6562 Pref_Type := Scope (Orig_Comp);
6564 -- For an untagged derived type, use the discriminants of the parent
6565 -- which have been renamed in the derivation, possibly by a one-to-many
6566 -- discriminant constraint. For untagged type, initially get the Etype
6570 if Is_Derived_Type (Pref_Type)
6571 and then Number_Discriminants (Pref_Type) /=
6572 Number_Discriminants (Etype (Base_Type (Pref_Type)))
6574 Pref_Type := Etype (Base_Type (Pref_Type));
6578 -- We definitely should have a checking function, This routine should
6579 -- not be called if no discriminant checking function is present.
6581 pragma Assert (Present (Discr_Fct));
6583 -- Create the list of the actual parameters for the call. This list
6584 -- is the list of the discriminant fields of the record expression to
6585 -- be discriminant checked.
6588 Formal := First_Formal (Discr_Fct);
6589 Discr := First_Discriminant (Pref_Type);
6590 while Present (Discr) loop
6592 -- If we have a corresponding discriminant field, and a parent
6593 -- subtype is present, then we want to use the corresponding
6594 -- discriminant since this is the one with the useful value.
6596 if Present (Corresponding_Discriminant (Discr))
6597 and then Ekind (Pref_Type) = E_Record_Type
6598 and then Present (Parent_Subtype (Pref_Type))
6600 Real_Discr := Corresponding_Discriminant (Discr);
6602 Real_Discr := Discr;
6605 -- Construct the reference to the discriminant
6608 Make_Selected_Component (Loc,
6610 Unchecked_Convert_To (Pref_Type,
6611 Duplicate_Subexpr (Pref)),
6612 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
6614 -- Manually analyze and resolve this selected component. We really
6615 -- want it just as it appears above, and do not want the expander
6616 -- playing discriminal games etc with this reference. Then we append
6617 -- the argument to the list we are gathering.
6619 Set_Etype (Scomp, Etype (Real_Discr));
6620 Set_Analyzed (Scomp, True);
6621 Append_To (Args, Convert_To (Etype (Formal), Scomp));
6623 Next_Formal_With_Extras (Formal);
6624 Next_Discriminant (Discr);
6627 -- Now build and insert the call
6630 Make_Raise_Constraint_Error (Loc,
6632 Make_Function_Call (Loc,
6633 Name => New_Occurrence_Of (Discr_Fct, Loc),
6634 Parameter_Associations => Args),
6635 Reason => CE_Discriminant_Check_Failed));
6636 end Generate_Discriminant_Check;
6638 ---------------------------
6639 -- Generate_Index_Checks --
6640 ---------------------------
6642 procedure Generate_Index_Checks (N : Node_Id) is
6644 function Entity_Of_Prefix return Entity_Id;
6645 -- Returns the entity of the prefix of N (or Empty if not found)
6647 ----------------------
6648 -- Entity_Of_Prefix --
6649 ----------------------
6651 function Entity_Of_Prefix return Entity_Id is
6656 while not Is_Entity_Name (P) loop
6657 if not Nkind_In (P, N_Selected_Component,
6658 N_Indexed_Component)
6667 end Entity_Of_Prefix;
6671 Loc : constant Source_Ptr := Sloc (N);
6672 A : constant Node_Id := Prefix (N);
6673 A_Ent : constant Entity_Id := Entity_Of_Prefix;
6676 -- Start of processing for Generate_Index_Checks
6679 -- Ignore call if the prefix is not an array since we have a serious
6680 -- error in the sources. Ignore it also if index checks are suppressed
6681 -- for array object or type.
6683 if not Is_Array_Type (Etype (A))
6684 or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent))
6685 or else Index_Checks_Suppressed (Etype (A))
6689 -- The indexed component we are dealing with contains 'Loop_Entry in its
6690 -- prefix. This case arises when analysis has determined that constructs
6693 -- Prefix'Loop_Entry (Expr)
6694 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6696 -- require rewriting for error detection purposes. A side effect of this
6697 -- action is the generation of index checks that mention 'Loop_Entry.
6698 -- Delay the generation of the check until 'Loop_Entry has been properly
6699 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6701 elsif Nkind (Prefix (N)) = N_Attribute_Reference
6702 and then Attribute_Name (Prefix (N)) = Name_Loop_Entry
6707 -- Generate a raise of constraint error with the appropriate reason and
6708 -- a condition of the form:
6710 -- Base_Type (Sub) not in Array'Range (Subscript)
6712 -- Note that the reason we generate the conversion to the base type here
6713 -- is that we definitely want the range check to take place, even if it
6714 -- looks like the subtype is OK. Optimization considerations that allow
6715 -- us to omit the check have already been taken into account in the
6716 -- setting of the Do_Range_Check flag earlier on.
6718 Sub := First (Expressions (N));
6720 -- Handle string literals
6722 if Ekind (Etype (A)) = E_String_Literal_Subtype then
6723 if Do_Range_Check (Sub) then
6724 Set_Do_Range_Check (Sub, False);
6726 -- For string literals we obtain the bounds of the string from the
6727 -- associated subtype.
6730 Make_Raise_Constraint_Error (Loc,
6734 Convert_To (Base_Type (Etype (Sub)),
6735 Duplicate_Subexpr_Move_Checks (Sub)),
6737 Make_Attribute_Reference (Loc,
6738 Prefix => New_Occurrence_Of (Etype (A), Loc),
6739 Attribute_Name => Name_Range)),
6740 Reason => CE_Index_Check_Failed));
6747 A_Idx : Node_Id := Empty;
6754 A_Idx := First_Index (Etype (A));
6756 while Present (Sub) loop
6757 if Do_Range_Check (Sub) then
6758 Set_Do_Range_Check (Sub, False);
6760 -- Force evaluation except for the case of a simple name of
6761 -- a nonvolatile entity.
6763 if not Is_Entity_Name (Sub)
6764 or else Treat_As_Volatile (Entity (Sub))
6766 Force_Evaluation (Sub);
6769 if Nkind (A_Idx) = N_Range then
6772 elsif Nkind (A_Idx) = N_Identifier
6773 or else Nkind (A_Idx) = N_Expanded_Name
6775 A_Range := Scalar_Range (Entity (A_Idx));
6777 else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication);
6778 A_Range := Range_Expression (Constraint (A_Idx));
6781 -- For array objects with constant bounds we can generate
6782 -- the index check using the bounds of the type of the index
6785 and then Ekind (A_Ent) = E_Variable
6786 and then Is_Constant_Bound (Low_Bound (A_Range))
6787 and then Is_Constant_Bound (High_Bound (A_Range))
6790 Make_Attribute_Reference (Loc,
6792 New_Occurrence_Of (Etype (A_Idx), Loc),
6793 Attribute_Name => Name_Range);
6795 -- For arrays with non-constant bounds we cannot generate
6796 -- the index check using the bounds of the type of the index
6797 -- since it may reference discriminants of some enclosing
6798 -- type. We obtain the bounds directly from the prefix
6805 Num := New_List (Make_Integer_Literal (Loc, Ind));
6809 Make_Attribute_Reference (Loc,
6811 Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
6812 Attribute_Name => Name_Range,
6813 Expressions => Num);
6817 Make_Raise_Constraint_Error (Loc,
6821 Convert_To (Base_Type (Etype (Sub)),
6822 Duplicate_Subexpr_Move_Checks (Sub)),
6823 Right_Opnd => Range_N),
6824 Reason => CE_Index_Check_Failed));
6827 A_Idx := Next_Index (A_Idx);
6833 end Generate_Index_Checks;
6835 --------------------------
6836 -- Generate_Range_Check --
6837 --------------------------
6839 procedure Generate_Range_Check
6841 Target_Type : Entity_Id;
6842 Reason : RT_Exception_Code)
6844 Loc : constant Source_Ptr := Sloc (N);
6845 Source_Type : constant Entity_Id := Etype (N);
6846 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
6847 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
6849 procedure Convert_And_Check_Range (Suppress : Check_Id);
6850 -- Convert N to the target base type and save the result in a temporary.
6851 -- The action is analyzed using the default checks as modified by the
6852 -- given Suppress argument. Then check the converted value against the
6853 -- range of the target subtype.
6855 -----------------------------
6856 -- Convert_And_Check_Range --
6857 -----------------------------
6859 procedure Convert_And_Check_Range (Suppress : Check_Id) is
6860 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6864 -- For enumeration types with non-standard representation this is a
6865 -- direct conversion from the enumeration type to the target integer
6866 -- type, which is treated by the back end as a normal integer type
6867 -- conversion, treating the enumeration type as an integer, which is
6868 -- exactly what we want. We set Conversion_OK to make sure that the
6869 -- analyzer does not complain about what otherwise might be an
6870 -- illegal conversion.
6872 if Is_Enumeration_Type (Source_Base_Type)
6873 and then Present (Enum_Pos_To_Rep (Source_Base_Type))
6874 and then Is_Integer_Type (Target_Base_Type)
6876 Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N));
6878 Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N));
6881 -- We make a temporary to hold the value of the conversion to the
6882 -- target base type, and then do the test against this temporary.
6883 -- N itself is replaced by an occurrence of Tnn and followed by
6884 -- the explicit range check.
6886 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6887 -- [constraint_error when Tnn not in Target_Type]
6890 Insert_Actions (N, New_List (
6891 Make_Object_Declaration (Loc,
6892 Defining_Identifier => Tnn,
6893 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
6894 Constant_Present => True,
6895 Expression => Conv_N),
6897 Make_Raise_Constraint_Error (Loc,
6900 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6901 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6903 Suppress => Suppress);
6905 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6907 -- Set the type of N, because the declaration for Tnn might not
6908 -- be analyzed yet, as is the case if N appears within a record
6909 -- declaration, as a discriminant constraint or expression.
6911 Set_Etype (N, Target_Base_Type);
6912 end Convert_And_Check_Range;
6914 -- Start of processing for Generate_Range_Check
6917 -- First special case, if the source type is already within the range
6918 -- of the target type, then no check is needed (probably we should have
6919 -- stopped Do_Range_Check from being set in the first place, but better
6920 -- late than never in preventing junk code and junk flag settings).
6922 if In_Subrange_Of (Source_Type, Target_Type)
6924 -- We do NOT apply this if the source node is a literal, since in this
6925 -- case the literal has already been labeled as having the subtype of
6929 (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal)
6932 and then Ekind (Entity (N)) = E_Enumeration_Literal))
6934 Set_Do_Range_Check (N, False);
6938 -- Here a check is needed. If the expander is not active, or if we are
6939 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6940 -- are done. In both these cases, we just want to see the range check
6941 -- flag set, we do not want to generate the explicit range check code.
6943 if GNATprove_Mode or else not Expander_Active then
6944 Set_Do_Range_Check (N);
6948 -- Here we will generate an explicit range check, so we don't want to
6949 -- set the Do_Range check flag, since the range check is taken care of
6950 -- by the code we will generate.
6952 Set_Do_Range_Check (N, False);
6954 -- Force evaluation of the node, so that it does not get evaluated twice
6955 -- (once for the check, once for the actual reference). Such a double
6956 -- evaluation is always a potential source of inefficiency, and is
6957 -- functionally incorrect in the volatile case.
6959 -- We skip the evaluation of attribute references because, after these
6960 -- runtime checks are generated, the expander may need to rewrite this
6961 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in
6962 -- Expand_N_Attribute_Reference).
6964 if Nkind (N) /= N_Attribute_Reference
6965 and then (not Is_Entity_Name (N)
6966 or else Treat_As_Volatile (Entity (N)))
6968 Force_Evaluation (N, Mode => Strict);
6971 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6972 -- the same since in this case we can simply do a direct check of the
6973 -- value of N against the bounds of Target_Type.
6975 -- [constraint_error when N not in Target_Type]
6977 -- Note: this is by far the most common case, for example all cases of
6978 -- checks on the RHS of assignments are in this category, but not all
6979 -- cases are like this. Notably conversions can involve two types.
6981 if Source_Base_Type = Target_Base_Type then
6983 -- Insert the explicit range check. Note that we suppress checks for
6984 -- this code, since we don't want a recursive range check popping up.
6987 Make_Raise_Constraint_Error (Loc,
6990 Left_Opnd => Duplicate_Subexpr (N),
6991 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6993 Suppress => All_Checks);
6995 -- Next test for the case where the target type is within the bounds
6996 -- of the base type of the source type, since in this case we can
6997 -- simply convert the bounds of the target type to this base bype
7000 -- [constraint_error when N not in
7001 -- Source_Base_Type (Target_Type'First)
7003 -- Source_Base_Type(Target_Type'Last))]
7005 -- The conversions will always work and need no check
7007 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
7008 -- of converting from an enumeration value to an integer type, such as
7009 -- occurs for the case of generating a range check on Enum'Val(Exp)
7010 -- (which used to be handled by gigi). This is OK, since the conversion
7011 -- itself does not require a check.
7013 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
7015 -- Insert the explicit range check. Note that we suppress checks for
7016 -- this code, since we don't want a recursive range check popping up.
7018 if Is_Discrete_Type (Source_Base_Type)
7020 Is_Discrete_Type (Target_Base_Type)
7023 Make_Raise_Constraint_Error (Loc,
7026 Left_Opnd => Duplicate_Subexpr (N),
7031 Unchecked_Convert_To (Source_Base_Type,
7032 Make_Attribute_Reference (Loc,
7034 New_Occurrence_Of (Target_Type, Loc),
7035 Attribute_Name => Name_First)),
7038 Unchecked_Convert_To (Source_Base_Type,
7039 Make_Attribute_Reference (Loc,
7041 New_Occurrence_Of (Target_Type, Loc),
7042 Attribute_Name => Name_Last)))),
7044 Suppress => All_Checks);
7046 -- For conversions involving at least one type that is not discrete,
7047 -- first convert to the target base type and then generate the range
7048 -- check. This avoids problems with values that are close to a bound
7049 -- of the target type that would fail a range check when done in a
7050 -- larger source type before converting but pass if converted with
7051 -- rounding and then checked (such as in float-to-float conversions).
7053 -- Note that overflow checks are not suppressed for this code because
7054 -- we do not know whether the source type is in range of the target
7055 -- base type (unlike in the next case below).
7058 Convert_And_Check_Range (Suppress => Range_Check);
7061 -- Note that at this stage we know that the Target_Base_Type is not in
7062 -- the range of the Source_Base_Type (since even the Target_Type itself
7063 -- is not in this range). It could still be the case that Source_Type is
7064 -- in range of the target base type since we have not checked that case.
7066 -- If that is the case, we can freely convert the source to the target,
7067 -- and then test the target result against the bounds. Note that checks
7068 -- are suppressed for this code, since we don't want a recursive range
7069 -- check popping up.
7071 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
7072 Convert_And_Check_Range (Suppress => All_Checks);
7074 -- At this stage, we know that we have two scalar types, which are
7075 -- directly convertible, and where neither scalar type has a base
7076 -- range that is in the range of the other scalar type.
7078 -- The only way this can happen is with a signed and unsigned type.
7079 -- So test for these two cases:
7082 -- Case of the source is unsigned and the target is signed
7084 if Is_Unsigned_Type (Source_Base_Type)
7085 and then not Is_Unsigned_Type (Target_Base_Type)
7087 -- If the source is unsigned and the target is signed, then we
7088 -- know that the source is not shorter than the target (otherwise
7089 -- the source base type would be in the target base type range).
7091 -- In other words, the unsigned type is either the same size as
7092 -- the target, or it is larger. It cannot be smaller.
7095 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
7097 -- We only need to check the low bound if the low bound of the
7098 -- target type is non-negative. If the low bound of the target
7099 -- type is negative, then we know that we will fit fine.
7101 -- If the high bound of the target type is negative, then we
7102 -- know we have a constraint error, since we can't possibly
7103 -- have a negative source.
7105 -- With these two checks out of the way, we can do the check
7106 -- using the source type safely
7108 -- This is definitely the most annoying case.
7110 -- [constraint_error
7111 -- when (Target_Type'First >= 0
7113 -- N < Source_Base_Type (Target_Type'First))
7114 -- or else Target_Type'Last < 0
7115 -- or else N > Source_Base_Type (Target_Type'Last)];
7117 -- We turn off all checks since we know that the conversions
7118 -- will work fine, given the guards for negative values.
7121 Make_Raise_Constraint_Error (Loc,
7127 Left_Opnd => Make_Op_Ge (Loc,
7129 Make_Attribute_Reference (Loc,
7131 New_Occurrence_Of (Target_Type, Loc),
7132 Attribute_Name => Name_First),
7133 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
7137 Left_Opnd => Duplicate_Subexpr (N),
7139 Convert_To (Source_Base_Type,
7140 Make_Attribute_Reference (Loc,
7142 New_Occurrence_Of (Target_Type, Loc),
7143 Attribute_Name => Name_First)))),
7148 Make_Attribute_Reference (Loc,
7149 Prefix => New_Occurrence_Of (Target_Type, Loc),
7150 Attribute_Name => Name_Last),
7151 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
7155 Left_Opnd => Duplicate_Subexpr (N),
7157 Convert_To (Source_Base_Type,
7158 Make_Attribute_Reference (Loc,
7159 Prefix => New_Occurrence_Of (Target_Type, Loc),
7160 Attribute_Name => Name_Last)))),
7163 Suppress => All_Checks);
7165 -- Only remaining possibility is that the source is signed and
7166 -- the target is unsigned.
7169 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
7170 and then Is_Unsigned_Type (Target_Base_Type));
7172 -- If the source is signed and the target is unsigned, then we
7173 -- know that the target is not shorter than the source (otherwise
7174 -- the target base type would be in the source base type range).
7176 -- In other words, the unsigned type is either the same size as
7177 -- the target, or it is larger. It cannot be smaller.
7179 -- Clearly we have an error if the source value is negative since
7180 -- no unsigned type can have negative values. If the source type
7181 -- is non-negative, then the check can be done using the target
7184 -- Tnn : constant Target_Base_Type (N) := Target_Type;
7186 -- [constraint_error
7187 -- when N < 0 or else Tnn not in Target_Type];
7189 -- We turn off all checks for the conversion of N to the target
7190 -- base type, since we generate the explicit check to ensure that
7191 -- the value is non-negative
7194 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
7197 Insert_Actions (N, New_List (
7198 Make_Object_Declaration (Loc,
7199 Defining_Identifier => Tnn,
7200 Object_Definition =>
7201 New_Occurrence_Of (Target_Base_Type, Loc),
7202 Constant_Present => True,
7204 Make_Unchecked_Type_Conversion (Loc,
7206 New_Occurrence_Of (Target_Base_Type, Loc),
7207 Expression => Duplicate_Subexpr (N))),
7209 Make_Raise_Constraint_Error (Loc,
7214 Left_Opnd => Duplicate_Subexpr (N),
7215 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
7219 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
7221 New_Occurrence_Of (Target_Type, Loc))),
7224 Suppress => All_Checks);
7226 -- Set the Etype explicitly, because Insert_Actions may have
7227 -- placed the declaration in the freeze list for an enclosing
7228 -- construct, and thus it is not analyzed yet.
7230 Set_Etype (Tnn, Target_Base_Type);
7231 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
7235 end Generate_Range_Check;
7241 function Get_Check_Id (N : Name_Id) return Check_Id is
7243 -- For standard check name, we can do a direct computation
7245 if N in First_Check_Name .. Last_Check_Name then
7246 return Check_Id (N - (First_Check_Name - 1));
7248 -- For non-standard names added by pragma Check_Name, search table
7251 for J in All_Checks + 1 .. Check_Names.Last loop
7252 if Check_Names.Table (J) = N then
7258 -- No matching name found
7263 ---------------------
7264 -- Get_Discriminal --
7265 ---------------------
7267 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
7268 Loc : constant Source_Ptr := Sloc (E);
7273 -- The bound can be a bona fide parameter of a protected operation,
7274 -- rather than a prival encoded as an in-parameter.
7276 if No (Discriminal_Link (Entity (Bound))) then
7280 -- Climb the scope stack looking for an enclosing protected type. If
7281 -- we run out of scopes, return the bound itself.
7284 while Present (Sc) loop
7285 if Sc = Standard_Standard then
7287 elsif Ekind (Sc) = E_Protected_Type then
7294 D := First_Discriminant (Sc);
7295 while Present (D) loop
7296 if Chars (D) = Chars (Bound) then
7297 return New_Occurrence_Of (Discriminal (D), Loc);
7300 Next_Discriminant (D);
7304 end Get_Discriminal;
7306 ----------------------
7307 -- Get_Range_Checks --
7308 ----------------------
7310 function Get_Range_Checks
7312 Target_Typ : Entity_Id;
7313 Source_Typ : Entity_Id := Empty;
7314 Warn_Node : Node_Id := Empty) return Check_Result
7318 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
7319 end Get_Range_Checks;
7325 function Guard_Access
7328 Ck_Node : Node_Id) return Node_Id
7331 if Nkind (Cond) = N_Or_Else then
7332 Set_Paren_Count (Cond, 1);
7335 if Nkind (Ck_Node) = N_Allocator then
7343 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
7344 Right_Opnd => Make_Null (Loc)),
7345 Right_Opnd => Cond);
7349 -----------------------------
7350 -- Index_Checks_Suppressed --
7351 -----------------------------
7353 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
7355 if Present (E) and then Checks_May_Be_Suppressed (E) then
7356 return Is_Check_Suppressed (E, Index_Check);
7358 return Scope_Suppress.Suppress (Index_Check);
7360 end Index_Checks_Suppressed;
7366 procedure Initialize is
7368 for J in Determine_Range_Cache_N'Range loop
7369 Determine_Range_Cache_N (J) := Empty;
7374 for J in Int range 1 .. All_Checks loop
7375 Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
7379 -------------------------
7380 -- Insert_Range_Checks --
7381 -------------------------
7383 procedure Insert_Range_Checks
7384 (Checks : Check_Result;
7386 Suppress_Typ : Entity_Id;
7387 Static_Sloc : Source_Ptr := No_Location;
7388 Flag_Node : Node_Id := Empty;
7389 Do_Before : Boolean := False)
7391 Checks_On : constant Boolean :=
7392 not Index_Checks_Suppressed (Suppress_Typ)
7394 not Range_Checks_Suppressed (Suppress_Typ);
7396 Check_Node : Node_Id;
7397 Internal_Flag_Node : Node_Id := Flag_Node;
7398 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
7401 -- For now we just return if Checks_On is false, however this should be
7402 -- enhanced to check for an always True value in the condition and to
7403 -- generate a compilation warning???
7405 if not Expander_Active or not Checks_On then
7409 if Static_Sloc = No_Location then
7410 Internal_Static_Sloc := Sloc (Node);
7413 if No (Flag_Node) then
7414 Internal_Flag_Node := Node;
7417 for J in 1 .. 2 loop
7418 exit when No (Checks (J));
7420 if Nkind (Checks (J)) = N_Raise_Constraint_Error
7421 and then Present (Condition (Checks (J)))
7423 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
7424 Check_Node := Checks (J);
7425 Mark_Rewrite_Insertion (Check_Node);
7428 Insert_Before_And_Analyze (Node, Check_Node);
7430 Insert_After_And_Analyze (Node, Check_Node);
7433 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
7438 Make_Raise_Constraint_Error (Internal_Static_Sloc,
7439 Reason => CE_Range_Check_Failed);
7440 Mark_Rewrite_Insertion (Check_Node);
7443 Insert_Before_And_Analyze (Node, Check_Node);
7445 Insert_After_And_Analyze (Node, Check_Node);
7449 end Insert_Range_Checks;
7451 ------------------------
7452 -- Insert_Valid_Check --
7453 ------------------------
7455 procedure Insert_Valid_Check
7457 Related_Id : Entity_Id := Empty;
7458 Is_Low_Bound : Boolean := False;
7459 Is_High_Bound : Boolean := False)
7461 Loc : constant Source_Ptr := Sloc (Expr);
7462 Typ : constant Entity_Id := Etype (Expr);
7466 -- Do not insert if checks off, or if not checking validity or if
7467 -- expression is known to be valid.
7469 if not Validity_Checks_On
7470 or else Range_Or_Validity_Checks_Suppressed (Expr)
7471 or else Expr_Known_Valid (Expr)
7475 -- Do not insert checks within a predicate function. This will arise
7476 -- if the current unit and the predicate function are being compiled
7477 -- with validity checks enabled.
7479 elsif Present (Predicate_Function (Typ))
7480 and then Current_Scope = Predicate_Function (Typ)
7484 -- If the expression is a packed component of a modular type of the
7485 -- right size, the data is always valid.
7487 elsif Nkind (Expr) = N_Selected_Component
7488 and then Present (Component_Clause (Entity (Selector_Name (Expr))))
7489 and then Is_Modular_Integer_Type (Typ)
7490 and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr)))
7494 -- Do not generate a validity check when inside a generic unit as this
7495 -- is an expansion activity.
7497 elsif Inside_A_Generic then
7501 -- Entities declared in Lock_free protected types must be treated as
7502 -- volatile, and we must inhibit validity checks to prevent improper
7503 -- constant folding.
7505 if Is_Entity_Name (Expr)
7506 and then Is_Subprogram (Scope (Entity (Expr)))
7507 and then Present (Protected_Subprogram (Scope (Entity (Expr))))
7508 and then Uses_Lock_Free
7509 (Scope (Protected_Subprogram (Scope (Entity (Expr)))))
7514 -- If we have a checked conversion, then validity check applies to
7515 -- the expression inside the conversion, not the result, since if
7516 -- the expression inside is valid, then so is the conversion result.
7519 while Nkind (Exp) = N_Type_Conversion loop
7520 Exp := Expression (Exp);
7523 -- Do not generate a check for a variable which already validates the
7524 -- value of an assignable object.
7526 if Is_Validation_Variable_Reference (Exp) then
7536 -- If the expression denotes an assignable object, capture its value
7537 -- in a variable and replace the original expression by the variable.
7538 -- This approach has several effects:
7540 -- 1) The evaluation of the object results in only one read in the
7541 -- case where the object is atomic or volatile.
7543 -- Var ... := Object; -- read
7545 -- 2) The captured value is the one verified by attribute 'Valid.
7546 -- As a result the object is not evaluated again, which would
7547 -- result in an unwanted read in the case where the object is
7548 -- atomic or volatile.
7550 -- if not Var'Valid then -- OK, no read of Object
7552 -- if not Object'Valid then -- Wrong, extra read of Object
7554 -- 3) The captured value replaces the original object reference.
7555 -- As a result the object is not evaluated again, in the same
7558 -- ... Var ... -- OK, no read of Object
7560 -- ... Object ... -- Wrong, extra read of Object
7562 -- 4) The use of a variable to capture the value of the object
7563 -- allows the propagation of any changes back to the original
7566 -- procedure Call (Val : in out ...);
7568 -- Var : ... := Object; -- read Object
7569 -- if not Var'Valid then -- validity check
7570 -- Call (Var); -- modify Var
7571 -- Object := Var; -- update Object
7573 if Is_Variable (Exp) then
7574 Var_Id := Make_Temporary (Loc, 'T', Exp);
7576 -- Because we could be dealing with a transient scope which would
7577 -- cause our object declaration to remain unanalyzed we must do
7578 -- some manual decoration.
7580 Set_Ekind (Var_Id, E_Variable);
7581 Set_Etype (Var_Id, Typ);
7584 Make_Object_Declaration (Loc,
7585 Defining_Identifier => Var_Id,
7586 Object_Definition => New_Occurrence_Of (Typ, Loc),
7587 Expression => New_Copy_Tree (Exp)),
7588 Suppress => Validity_Check);
7590 Set_Validated_Object (Var_Id, New_Copy_Tree (Exp));
7592 Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc));
7594 -- Move the Do_Range_Check flag over to the new Exp so it doesn't
7595 -- get lost and doesn't leak elsewhere.
7597 if Do_Range_Check (Validated_Object (Var_Id)) then
7598 Set_Do_Range_Check (Exp);
7599 Set_Do_Range_Check (Validated_Object (Var_Id), False);
7602 PV := New_Occurrence_Of (Var_Id, Loc);
7604 -- Otherwise the expression does not denote a variable. Force its
7605 -- evaluation by capturing its value in a constant. Generate:
7607 -- Temp : constant ... := Exp;
7612 Related_Id => Related_Id,
7613 Is_Low_Bound => Is_Low_Bound,
7614 Is_High_Bound => Is_High_Bound);
7616 PV := New_Copy_Tree (Exp);
7619 -- A rather specialized test. If PV is an analyzed expression which
7620 -- is an indexed component of a packed array that has not been
7621 -- properly expanded, turn off its Analyzed flag to make sure it
7622 -- gets properly reexpanded. If the prefix is an access value,
7623 -- the dereference will be added later.
7625 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7626 -- an analyze with the old parent pointer. This may point e.g. to
7627 -- a subprogram call, which deactivates this expansion.
7630 and then Nkind (PV) = N_Indexed_Component
7631 and then Is_Array_Type (Etype (Prefix (PV)))
7632 and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV))))
7634 Set_Analyzed (PV, False);
7637 -- Build the raise CE node to check for validity. We build a type
7638 -- qualification for the prefix, since it may not be of the form of
7639 -- a name, and we don't care in this context!
7642 Make_Raise_Constraint_Error (Loc,
7646 Make_Attribute_Reference (Loc,
7648 Attribute_Name => Name_Valid)),
7649 Reason => CE_Invalid_Data);
7651 -- Insert the validity check. Note that we do this with validity
7652 -- checks turned off, to avoid recursion, we do not want validity
7653 -- checks on the validity checking code itself.
7655 Insert_Action (Expr, CE, Suppress => Validity_Check);
7657 -- If the expression is a reference to an element of a bit-packed
7658 -- array, then it is rewritten as a renaming declaration. If the
7659 -- expression is an actual in a call, it has not been expanded,
7660 -- waiting for the proper point at which to do it. The same happens
7661 -- with renamings, so that we have to force the expansion now. This
7662 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7665 if Is_Entity_Name (Exp)
7666 and then Nkind (Parent (Entity (Exp))) =
7667 N_Object_Renaming_Declaration
7670 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
7672 if Nkind (Old_Exp) = N_Indexed_Component
7673 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
7675 Expand_Packed_Element_Reference (Old_Exp);
7680 end Insert_Valid_Check;
7682 -------------------------------------
7683 -- Is_Signed_Integer_Arithmetic_Op --
7684 -------------------------------------
7686 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
7700 return Is_Signed_Integer_Type (Etype (N));
7702 when N_Case_Expression
7705 return Is_Signed_Integer_Type (Etype (N));
7710 end Is_Signed_Integer_Arithmetic_Op;
7712 ----------------------------------
7713 -- Install_Null_Excluding_Check --
7714 ----------------------------------
7716 procedure Install_Null_Excluding_Check (N : Node_Id) is
7717 Loc : constant Source_Ptr := Sloc (Parent (N));
7718 Typ : constant Entity_Id := Etype (N);
7720 function Safe_To_Capture_In_Parameter_Value return Boolean;
7721 -- Determines if it is safe to capture Known_Non_Null status for an
7722 -- the entity referenced by node N. The caller ensures that N is indeed
7723 -- an entity name. It is safe to capture the non-null status for an IN
7724 -- parameter when the reference occurs within a declaration that is sure
7725 -- to be executed as part of the declarative region.
7727 procedure Mark_Non_Null;
7728 -- After installation of check, if the node in question is an entity
7729 -- name, then mark this entity as non-null if possible.
7731 function Safe_To_Capture_In_Parameter_Value return Boolean is
7732 E : constant Entity_Id := Entity (N);
7733 S : constant Entity_Id := Current_Scope;
7737 if Ekind (E) /= E_In_Parameter then
7741 -- Two initial context checks. We must be inside a subprogram body
7742 -- with declarations and reference must not appear in nested scopes.
7744 if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure)
7745 or else Scope (E) /= S
7750 S_Par := Parent (Parent (S));
7752 if Nkind (S_Par) /= N_Subprogram_Body
7753 or else No (Declarations (S_Par))
7763 -- Retrieve the declaration node of N (if any). Note that N
7764 -- may be a part of a complex initialization expression.
7768 while Present (P) loop
7770 -- If we have a short circuit form, and we are within the right
7771 -- hand expression, we return false, since the right hand side
7772 -- is not guaranteed to be elaborated.
7774 if Nkind (P) in N_Short_Circuit
7775 and then N = Right_Opnd (P)
7780 -- Similarly, if we are in an if expression and not part of the
7781 -- condition, then we return False, since neither the THEN or
7782 -- ELSE dependent expressions will always be elaborated.
7784 if Nkind (P) = N_If_Expression
7785 and then N /= First (Expressions (P))
7790 -- If within a case expression, and not part of the expression,
7791 -- then return False, since a particular dependent expression
7792 -- may not always be elaborated
7794 if Nkind (P) = N_Case_Expression
7795 and then N /= Expression (P)
7800 -- While traversing the parent chain, if node N belongs to a
7801 -- statement, then it may never appear in a declarative region.
7803 if Nkind (P) in N_Statement_Other_Than_Procedure_Call
7804 or else Nkind (P) = N_Procedure_Call_Statement
7809 -- If we are at a declaration, record it and exit
7811 if Nkind (P) in N_Declaration
7812 and then Nkind (P) not in N_Subprogram_Specification
7825 return List_Containing (N_Decl) = Declarations (S_Par);
7827 end Safe_To_Capture_In_Parameter_Value;
7833 procedure Mark_Non_Null is
7835 -- Only case of interest is if node N is an entity name
7837 if Is_Entity_Name (N) then
7839 -- For sure, we want to clear an indication that this is known to
7840 -- be null, since if we get past this check, it definitely is not.
7842 Set_Is_Known_Null (Entity (N), False);
7844 -- We can mark the entity as known to be non-null if either it is
7845 -- safe to capture the value, or in the case of an IN parameter,
7846 -- which is a constant, if the check we just installed is in the
7847 -- declarative region of the subprogram body. In this latter case,
7848 -- a check is decisive for the rest of the body if the expression
7849 -- is sure to be elaborated, since we know we have to elaborate
7850 -- all declarations before executing the body.
7852 -- Couldn't this always be part of Safe_To_Capture_Value ???
7854 if Safe_To_Capture_Value (N, Entity (N))
7855 or else Safe_To_Capture_In_Parameter_Value
7857 Set_Is_Known_Non_Null (Entity (N));
7862 -- Start of processing for Install_Null_Excluding_Check
7865 -- No need to add null-excluding checks when the tree may not be fully
7868 if Serious_Errors_Detected > 0 then
7872 pragma Assert (Is_Access_Type (Typ));
7874 -- No check inside a generic, check will be emitted in instance
7876 if Inside_A_Generic then
7880 -- No check needed if known to be non-null
7882 if Known_Non_Null (N) then
7886 -- If known to be null, here is where we generate a compile time check
7888 if Known_Null (N) then
7890 -- Avoid generating warning message inside init procs. In SPARK mode
7891 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7892 -- since it will be turned into an error in any case.
7894 if (not Inside_Init_Proc or else SPARK_Mode = On)
7896 -- Do not emit the warning within a conditional expression,
7897 -- where the expression might not be evaluated, and the warning
7898 -- appear as extraneous noise.
7900 and then not Within_Case_Or_If_Expression (N)
7902 Apply_Compile_Time_Constraint_Error
7903 (N, "null value not allowed here??", CE_Access_Check_Failed);
7905 -- Remaining cases, where we silently insert the raise
7909 Make_Raise_Constraint_Error (Loc,
7910 Reason => CE_Access_Check_Failed));
7917 -- If entity is never assigned, for sure a warning is appropriate
7919 if Is_Entity_Name (N) then
7920 Check_Unset_Reference (N);
7923 -- No check needed if checks are suppressed on the range. Note that we
7924 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7925 -- so, since the program is erroneous, but we don't like to casually
7926 -- propagate such conclusions from erroneosity).
7928 if Access_Checks_Suppressed (Typ) then
7932 -- No check needed for access to concurrent record types generated by
7933 -- the expander. This is not just an optimization (though it does indeed
7934 -- remove junk checks). It also avoids generation of junk warnings.
7936 if Nkind (N) in N_Has_Chars
7937 and then Chars (N) = Name_uObject
7938 and then Is_Concurrent_Record_Type
7939 (Directly_Designated_Type (Etype (N)))
7944 -- No check needed in interface thunks since the runtime check is
7945 -- already performed at the caller side.
7947 if Is_Thunk (Current_Scope) then
7951 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7952 -- the expander within exception handlers, since we know that the value
7953 -- can never be null.
7955 -- Is this really the right way to do this? Normally we generate such
7956 -- code in the expander with checks off, and that's how we suppress this
7957 -- kind of junk check ???
7959 if Nkind (N) = N_Function_Call
7960 and then Nkind (Name (N)) = N_Explicit_Dereference
7961 and then Nkind (Prefix (Name (N))) = N_Identifier
7962 and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
7967 -- In GNATprove mode, we do not apply the check
7969 if GNATprove_Mode then
7973 -- Otherwise install access check
7976 Make_Raise_Constraint_Error (Loc,
7979 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
7980 Right_Opnd => Make_Null (Loc)),
7981 Reason => CE_Access_Check_Failed));
7984 end Install_Null_Excluding_Check;
7986 -----------------------------------------
7987 -- Install_Primitive_Elaboration_Check --
7988 -----------------------------------------
7990 procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is
7991 function Within_Compilation_Unit_Instance
7992 (Subp_Id : Entity_Id) return Boolean;
7993 -- Determine whether subprogram Subp_Id appears within an instance which
7994 -- acts as a compilation unit.
7996 --------------------------------------
7997 -- Within_Compilation_Unit_Instance --
7998 --------------------------------------
8000 function Within_Compilation_Unit_Instance
8001 (Subp_Id : Entity_Id) return Boolean
8006 -- Examine the scope chain looking for a compilation-unit-level
8009 Pack := Scope (Subp_Id);
8010 while Present (Pack) and then Pack /= Standard_Standard loop
8011 if Ekind (Pack) = E_Package
8012 and then Is_Generic_Instance (Pack)
8013 and then Nkind (Parent (Unit_Declaration_Node (Pack))) =
8019 Pack := Scope (Pack);
8023 end Within_Compilation_Unit_Instance;
8025 -- Local declarations
8027 Context : constant Node_Id := Parent (Subp_Body);
8028 Loc : constant Source_Ptr := Sloc (Subp_Body);
8029 Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body);
8030 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
8033 Flag_Id : Entity_Id;
8036 Tag_Typ : Entity_Id;
8038 -- Start of processing for Install_Primitive_Elaboration_Check
8041 -- Do not generate an elaboration check in compilation modes where
8042 -- expansion is not desirable.
8044 if ASIS_Mode or GNATprove_Mode then
8047 -- Do not generate an elaboration check if all checks have been
8050 elsif Suppress_Checks then
8053 -- Do not generate an elaboration check if the related subprogram is
8054 -- not subjected to accessibility checks.
8056 elsif Elaboration_Checks_Suppressed (Subp_Id) then
8059 -- Do not generate an elaboration check if such code is not desirable
8061 elsif Restriction_Active (No_Elaboration_Code) then
8064 -- Do not generate an elaboration check if exceptions cannot be used,
8065 -- caught, or propagated.
8067 elsif not Exceptions_OK then
8070 -- Do not consider subprograms which act as compilation units, because
8071 -- they cannot be the target of a dispatching call.
8073 elsif Nkind (Context) = N_Compilation_Unit then
8076 -- Do not consider anything other than nonabstract library-level source
8080 (Comes_From_Source (Subp_Id)
8081 and then Is_Library_Level_Entity (Subp_Id)
8082 and then Is_Primitive (Subp_Id)
8083 and then not Is_Abstract_Subprogram (Subp_Id))
8087 -- Do not consider inlined primitives, because once the body is inlined
8088 -- the reference to the elaboration flag will be out of place and will
8089 -- result in an undefined symbol.
8091 elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then
8094 -- Do not generate a duplicate elaboration check. This happens only in
8095 -- the case of primitives completed by an expression function, as the
8096 -- corresponding body is apparently analyzed and expanded twice.
8098 elsif Analyzed (Subp_Body) then
8101 -- Do not consider primitives which occur within an instance that acts
8102 -- as a compilation unit. Such an instance defines its spec and body out
8103 -- of order (body is first) within the tree, which causes the reference
8104 -- to the elaboration flag to appear as an undefined symbol.
8106 elsif Within_Compilation_Unit_Instance (Subp_Id) then
8110 Tag_Typ := Find_Dispatching_Type (Subp_Id);
8112 -- Only tagged primitives may be the target of a dispatching call
8114 if No (Tag_Typ) then
8117 -- Do not consider finalization-related primitives, because they may
8118 -- need to be called while elaboration is taking place.
8120 elsif Is_Controlled (Tag_Typ)
8121 and then Nam_In (Chars (Subp_Id), Name_Adjust,
8128 -- Create the declaration of the elaboration flag. The name carries a
8129 -- unique counter in case of name overloading.
8132 Make_Defining_Identifier (Loc,
8133 Chars => New_External_Name (Chars (Subp_Id), 'E', -1));
8134 Set_Is_Frozen (Flag_Id);
8136 -- Insert the declaration of the elaboration flag in front of the
8137 -- primitive spec and analyze it in the proper context.
8139 Push_Scope (Scope (Subp_Id));
8142 -- E : Boolean := False;
8144 Insert_Action (Subp_Decl,
8145 Make_Object_Declaration (Loc,
8146 Defining_Identifier => Flag_Id,
8147 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
8148 Expression => New_Occurrence_Of (Standard_False, Loc)));
8151 -- Prevent the compiler from optimizing the elaboration check by killing
8152 -- the current value of the flag and the associated assignment.
8154 Set_Current_Value (Flag_Id, Empty);
8155 Set_Last_Assignment (Flag_Id, Empty);
8157 -- Add a check at the top of the body declarations to ensure that the
8158 -- elaboration flag has been set.
8160 Decls := Declarations (Subp_Body);
8164 Set_Declarations (Subp_Body, Decls);
8169 -- raise Program_Error with "access before elaboration";
8173 Make_Raise_Program_Error (Loc,
8176 Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)),
8177 Reason => PE_Access_Before_Elaboration));
8179 Analyze (First (Decls));
8181 -- Set the elaboration flag once the body has been elaborated. Insert
8182 -- the statement after the subprogram stub when the primitive body is
8185 if Nkind (Context) = N_Subunit then
8186 Set_Ins := Corresponding_Stub (Context);
8188 Set_Ins := Subp_Body;
8195 Make_Assignment_Statement (Loc,
8196 Name => New_Occurrence_Of (Flag_Id, Loc),
8197 Expression => New_Occurrence_Of (Standard_True, Loc));
8199 -- Mark the assignment statement as elaboration code. This allows the
8200 -- early call region mechanism (see Sem_Elab) to properly ignore such
8201 -- assignments even though they are non-preelaborable code.
8203 Set_Is_Elaboration_Code (Set_Stmt);
8205 Insert_After_And_Analyze (Set_Ins, Set_Stmt);
8206 end Install_Primitive_Elaboration_Check;
8208 --------------------------
8209 -- Install_Static_Check --
8210 --------------------------
8212 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
8213 Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
8214 Typ : constant Entity_Id := Etype (R_Cno);
8218 Make_Raise_Constraint_Error (Loc,
8219 Reason => CE_Range_Check_Failed));
8220 Set_Analyzed (R_Cno);
8221 Set_Etype (R_Cno, Typ);
8222 Set_Raises_Constraint_Error (R_Cno);
8223 Set_Is_Static_Expression (R_Cno, Stat);
8225 -- Now deal with possible local raise handling
8227 Possible_Local_Raise (R_Cno, Standard_Constraint_Error);
8228 end Install_Static_Check;
8230 -------------------------
8231 -- Is_Check_Suppressed --
8232 -------------------------
8234 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
8235 Ptr : Suppress_Stack_Entry_Ptr;
8238 -- First search the local entity suppress stack. We search this from the
8239 -- top of the stack down so that we get the innermost entry that applies
8240 -- to this case if there are nested entries.
8242 Ptr := Local_Suppress_Stack_Top;
8243 while Ptr /= null loop
8244 if (Ptr.Entity = Empty or else Ptr.Entity = E)
8245 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
8247 return Ptr.Suppress;
8253 -- Now search the global entity suppress table for a matching entry.
8254 -- We also search this from the top down so that if there are multiple
8255 -- pragmas for the same entity, the last one applies (not clear what
8256 -- or whether the RM specifies this handling, but it seems reasonable).
8258 Ptr := Global_Suppress_Stack_Top;
8259 while Ptr /= null loop
8260 if (Ptr.Entity = Empty or else Ptr.Entity = E)
8261 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
8263 return Ptr.Suppress;
8269 -- If we did not find a matching entry, then use the normal scope
8270 -- suppress value after all (actually this will be the global setting
8271 -- since it clearly was not overridden at any point). For a predefined
8272 -- check, we test the specific flag. For a user defined check, we check
8273 -- the All_Checks flag. The Overflow flag requires special handling to
8274 -- deal with the General vs Assertion case.
8276 if C = Overflow_Check then
8277 return Overflow_Checks_Suppressed (Empty);
8279 elsif C in Predefined_Check_Id then
8280 return Scope_Suppress.Suppress (C);
8283 return Scope_Suppress.Suppress (All_Checks);
8285 end Is_Check_Suppressed;
8287 ---------------------
8288 -- Kill_All_Checks --
8289 ---------------------
8291 procedure Kill_All_Checks is
8293 if Debug_Flag_CC then
8294 w ("Kill_All_Checks");
8297 -- We reset the number of saved checks to zero, and also modify all
8298 -- stack entries for statement ranges to indicate that the number of
8299 -- checks at each level is now zero.
8301 Num_Saved_Checks := 0;
8303 -- Note: the Int'Min here avoids any possibility of J being out of
8304 -- range when called from e.g. Conditional_Statements_Begin.
8306 for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
8307 Saved_Checks_Stack (J) := 0;
8309 end Kill_All_Checks;
8315 procedure Kill_Checks (V : Entity_Id) is
8317 if Debug_Flag_CC then
8318 w ("Kill_Checks for entity", Int (V));
8321 for J in 1 .. Num_Saved_Checks loop
8322 if Saved_Checks (J).Entity = V then
8323 if Debug_Flag_CC then
8324 w (" Checks killed for saved check ", J);
8327 Saved_Checks (J).Killed := True;
8332 ------------------------------
8333 -- Length_Checks_Suppressed --
8334 ------------------------------
8336 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
8338 if Present (E) and then Checks_May_Be_Suppressed (E) then
8339 return Is_Check_Suppressed (E, Length_Check);
8341 return Scope_Suppress.Suppress (Length_Check);
8343 end Length_Checks_Suppressed;
8345 -----------------------
8346 -- Make_Bignum_Block --
8347 -----------------------
8349 function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is
8350 M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM);
8353 Make_Block_Statement (Loc,
8355 New_List (Build_SS_Mark_Call (Loc, M)),
8356 Handled_Statement_Sequence =>
8357 Make_Handled_Sequence_Of_Statements (Loc,
8358 Statements => New_List (Build_SS_Release_Call (Loc, M))));
8359 end Make_Bignum_Block;
8361 ----------------------------------
8362 -- Minimize_Eliminate_Overflows --
8363 ----------------------------------
8365 -- This is a recursive routine that is called at the top of an expression
8366 -- tree to properly process overflow checking for a whole subtree by making
8367 -- recursive calls to process operands. This processing may involve the use
8368 -- of bignum or long long integer arithmetic, which will change the types
8369 -- of operands and results. That's why we can't do this bottom up (since
8370 -- it would interfere with semantic analysis).
8372 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
8373 -- the operator expansion routines, as well as the expansion routines for
8374 -- if/case expression, do nothing (for the moment) except call the routine
8375 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
8376 -- routine does nothing for non top-level nodes, so at the point where the
8377 -- call is made for the top level node, the entire expression subtree has
8378 -- not been expanded, or processed for overflow. All that has to happen as
8379 -- a result of the top level call to this routine.
8381 -- As noted above, the overflow processing works by making recursive calls
8382 -- for the operands, and figuring out what to do, based on the processing
8383 -- of these operands (e.g. if a bignum operand appears, the parent op has
8384 -- to be done in bignum mode), and the determined ranges of the operands.
8386 -- After possible rewriting of a constituent subexpression node, a call is
8387 -- made to either reexpand the node (if nothing has changed) or reanalyze
8388 -- the node (if it has been modified by the overflow check processing). The
8389 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
8390 -- a recursive call into the whole overflow apparatus, an important rule
8391 -- for this call is that the overflow handling mode must be temporarily set
8394 procedure Minimize_Eliminate_Overflows
8398 Top_Level : Boolean)
8400 Rtyp : constant Entity_Id := Etype (N);
8401 pragma Assert (Is_Signed_Integer_Type (Rtyp));
8402 -- Result type, must be a signed integer type
8404 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
8405 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
8407 Loc : constant Source_Ptr := Sloc (N);
8410 -- Ranges of values for right operand (operator case)
8412 Llo : Uint := No_Uint; -- initialize to prevent warning
8413 Lhi : Uint := No_Uint; -- initialize to prevent warning
8414 -- Ranges of values for left operand (operator case)
8416 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
8417 -- Operands and results are of this type when we convert
8419 LLLo : constant Uint := Intval (Type_Low_Bound (LLIB));
8420 LLHi : constant Uint := Intval (Type_High_Bound (LLIB));
8421 -- Bounds of Long_Long_Integer
8423 Binary : constant Boolean := Nkind (N) in N_Binary_Op;
8424 -- Indicates binary operator case
8427 -- Used in call to Determine_Range
8429 Bignum_Operands : Boolean;
8430 -- Set True if one or more operands is already of type Bignum, meaning
8431 -- that for sure (regardless of Top_Level setting) we are committed to
8432 -- doing the operation in Bignum mode (or in the case of a case or if
8433 -- expression, converting all the dependent expressions to Bignum).
8435 Long_Long_Integer_Operands : Boolean;
8436 -- Set True if one or more operands is already of type Long_Long_Integer
8437 -- which means that if the result is known to be in the result type
8438 -- range, then we must convert such operands back to the result type.
8440 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False);
8441 -- This is called when we have modified the node and we therefore need
8442 -- to reanalyze it. It is important that we reset the mode to STRICT for
8443 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
8444 -- we would reenter this routine recursively which would not be good.
8445 -- The argument Suppress is set True if we also want to suppress
8446 -- overflow checking for the reexpansion (this is set when we know
8447 -- overflow is not possible). Typ is the type for the reanalysis.
8449 procedure Reexpand (Suppress : Boolean := False);
8450 -- This is like Reanalyze, but does not do the Analyze step, it only
8451 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
8452 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
8453 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
8454 -- Note that skipping reanalysis is not just an optimization, testing
8455 -- has showed up several complex cases in which reanalyzing an already
8456 -- analyzed node causes incorrect behavior.
8458 function In_Result_Range return Boolean;
8459 -- Returns True iff Lo .. Hi are within range of the result type
8461 procedure Max (A : in out Uint; B : Uint);
8462 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
8464 procedure Min (A : in out Uint; B : Uint);
8465 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
8467 ---------------------
8468 -- In_Result_Range --
8469 ---------------------
8471 function In_Result_Range return Boolean is
8473 if Lo = No_Uint or else Hi = No_Uint then
8476 elsif Is_OK_Static_Subtype (Etype (N)) then
8477 return Lo >= Expr_Value (Type_Low_Bound (Rtyp))
8479 Hi <= Expr_Value (Type_High_Bound (Rtyp));
8482 return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp)))
8484 Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp)));
8486 end In_Result_Range;
8492 procedure Max (A : in out Uint; B : Uint) is
8494 if A = No_Uint or else B > A then
8503 procedure Min (A : in out Uint; B : Uint) is
8505 if A = No_Uint or else B < A then
8514 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is
8515 Svg : constant Overflow_Mode_Type :=
8516 Scope_Suppress.Overflow_Mode_General;
8517 Sva : constant Overflow_Mode_Type :=
8518 Scope_Suppress.Overflow_Mode_Assertions;
8519 Svo : constant Boolean :=
8520 Scope_Suppress.Suppress (Overflow_Check);
8523 Scope_Suppress.Overflow_Mode_General := Strict;
8524 Scope_Suppress.Overflow_Mode_Assertions := Strict;
8527 Scope_Suppress.Suppress (Overflow_Check) := True;
8530 Analyze_And_Resolve (N, Typ);
8532 Scope_Suppress.Suppress (Overflow_Check) := Svo;
8533 Scope_Suppress.Overflow_Mode_General := Svg;
8534 Scope_Suppress.Overflow_Mode_Assertions := Sva;
8541 procedure Reexpand (Suppress : Boolean := False) is
8542 Svg : constant Overflow_Mode_Type :=
8543 Scope_Suppress.Overflow_Mode_General;
8544 Sva : constant Overflow_Mode_Type :=
8545 Scope_Suppress.Overflow_Mode_Assertions;
8546 Svo : constant Boolean :=
8547 Scope_Suppress.Suppress (Overflow_Check);
8550 Scope_Suppress.Overflow_Mode_General := Strict;
8551 Scope_Suppress.Overflow_Mode_Assertions := Strict;
8552 Set_Analyzed (N, False);
8555 Scope_Suppress.Suppress (Overflow_Check) := True;
8560 Scope_Suppress.Suppress (Overflow_Check) := Svo;
8561 Scope_Suppress.Overflow_Mode_General := Svg;
8562 Scope_Suppress.Overflow_Mode_Assertions := Sva;
8565 -- Start of processing for Minimize_Eliminate_Overflows
8568 -- Default initialize Lo and Hi since these are not guaranteed to be
8574 -- Case where we do not have a signed integer arithmetic operation
8576 if not Is_Signed_Integer_Arithmetic_Op (N) then
8578 -- Use the normal Determine_Range routine to get the range. We
8579 -- don't require operands to be valid, invalid values may result in
8580 -- rubbish results where the result has not been properly checked for
8581 -- overflow, that's fine.
8583 Determine_Range (N, OK, Lo, Hi, Assume_Valid => False);
8585 -- If Determine_Range did not work (can this in fact happen? Not
8586 -- clear but might as well protect), use type bounds.
8589 Lo := Intval (Type_Low_Bound (Base_Type (Etype (N))));
8590 Hi := Intval (Type_High_Bound (Base_Type (Etype (N))));
8593 -- If we don't have a binary operator, all we have to do is to set
8594 -- the Hi/Lo range, so we are done.
8598 -- Processing for if expression
8600 elsif Nkind (N) = N_If_Expression then
8602 Then_DE : constant Node_Id := Next (First (Expressions (N)));
8603 Else_DE : constant Node_Id := Next (Then_DE);
8606 Bignum_Operands := False;
8608 Minimize_Eliminate_Overflows
8609 (Then_DE, Lo, Hi, Top_Level => False);
8611 if Lo = No_Uint then
8612 Bignum_Operands := True;
8615 Minimize_Eliminate_Overflows
8616 (Else_DE, Rlo, Rhi, Top_Level => False);
8618 if Rlo = No_Uint then
8619 Bignum_Operands := True;
8621 Long_Long_Integer_Operands :=
8622 Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB;
8628 -- If at least one of our operands is now Bignum, we must rebuild
8629 -- the if expression to use Bignum operands. We will analyze the
8630 -- rebuilt if expression with overflow checks off, since once we
8631 -- are in bignum mode, we are all done with overflow checks.
8633 if Bignum_Operands then
8635 Make_If_Expression (Loc,
8636 Expressions => New_List (
8637 Remove_Head (Expressions (N)),
8638 Convert_To_Bignum (Then_DE),
8639 Convert_To_Bignum (Else_DE)),
8640 Is_Elsif => Is_Elsif (N)));
8642 Reanalyze (RTE (RE_Bignum), Suppress => True);
8644 -- If we have no Long_Long_Integer operands, then we are in result
8645 -- range, since it means that none of our operands felt the need
8646 -- to worry about overflow (otherwise it would have already been
8647 -- converted to long long integer or bignum). We reexpand to
8648 -- complete the expansion of the if expression (but we do not
8649 -- need to reanalyze).
8651 elsif not Long_Long_Integer_Operands then
8652 Set_Do_Overflow_Check (N, False);
8655 -- Otherwise convert us to long long integer mode. Note that we
8656 -- don't need any further overflow checking at this level.
8659 Convert_To_And_Rewrite (LLIB, Then_DE);
8660 Convert_To_And_Rewrite (LLIB, Else_DE);
8661 Set_Etype (N, LLIB);
8663 -- Now reanalyze with overflow checks off
8665 Set_Do_Overflow_Check (N, False);
8666 Reanalyze (LLIB, Suppress => True);
8672 -- Here for case expression
8674 elsif Nkind (N) = N_Case_Expression then
8675 Bignum_Operands := False;
8676 Long_Long_Integer_Operands := False;
8682 -- Loop through expressions applying recursive call
8684 Alt := First (Alternatives (N));
8685 while Present (Alt) loop
8687 Aexp : constant Node_Id := Expression (Alt);
8690 Minimize_Eliminate_Overflows
8691 (Aexp, Lo, Hi, Top_Level => False);
8693 if Lo = No_Uint then
8694 Bignum_Operands := True;
8695 elsif Etype (Aexp) = LLIB then
8696 Long_Long_Integer_Operands := True;
8703 -- If we have no bignum or long long integer operands, it means
8704 -- that none of our dependent expressions could raise overflow.
8705 -- In this case, we simply return with no changes except for
8706 -- resetting the overflow flag, since we are done with overflow
8707 -- checks for this node. We will reexpand to get the needed
8708 -- expansion for the case expression, but we do not need to
8709 -- reanalyze, since nothing has changed.
8711 if not (Bignum_Operands or Long_Long_Integer_Operands) then
8712 Set_Do_Overflow_Check (N, False);
8713 Reexpand (Suppress => True);
8715 -- Otherwise we are going to rebuild the case expression using
8716 -- either bignum or long long integer operands throughout.
8721 pragma Warnings (Off, Rtype);
8726 New_Alts := New_List;
8727 Alt := First (Alternatives (N));
8728 while Present (Alt) loop
8729 if Bignum_Operands then
8730 New_Exp := Convert_To_Bignum (Expression (Alt));
8731 Rtype := RTE (RE_Bignum);
8733 New_Exp := Convert_To (LLIB, Expression (Alt));
8737 Append_To (New_Alts,
8738 Make_Case_Expression_Alternative (Sloc (Alt),
8740 Discrete_Choices => Discrete_Choices (Alt),
8741 Expression => New_Exp));
8747 Make_Case_Expression (Loc,
8748 Expression => Expression (N),
8749 Alternatives => New_Alts));
8751 Reanalyze (Rtype, Suppress => True);
8759 -- If we have an arithmetic operator we make recursive calls on the
8760 -- operands to get the ranges (and to properly process the subtree
8761 -- that lies below us).
8763 Minimize_Eliminate_Overflows
8764 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
8767 Minimize_Eliminate_Overflows
8768 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
8771 -- Record if we have Long_Long_Integer operands
8773 Long_Long_Integer_Operands :=
8774 Etype (Right_Opnd (N)) = LLIB
8775 or else (Binary and then Etype (Left_Opnd (N)) = LLIB);
8777 -- If either operand is a bignum, then result will be a bignum and we
8778 -- don't need to do any range analysis. As previously discussed we could
8779 -- do range analysis in such cases, but it could mean working with giant
8780 -- numbers at compile time for very little gain (the number of cases
8781 -- in which we could slip back from bignum mode is small).
8783 if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
8786 Bignum_Operands := True;
8788 -- Otherwise compute result range
8791 Bignum_Operands := False;
8799 Hi := UI_Max (abs Rlo, abs Rhi);
8811 -- If the right operand can only be zero, set 0..0
8813 if Rlo = 0 and then Rhi = 0 then
8817 -- Possible bounds of division must come from dividing end
8818 -- values of the input ranges (four possibilities), provided
8819 -- zero is not included in the possible values of the right
8822 -- Otherwise, we just consider two intervals of values for
8823 -- the right operand: the interval of negative values (up to
8824 -- -1) and the interval of positive values (starting at 1).
8825 -- Since division by 1 is the identity, and division by -1
8826 -- is negation, we get all possible bounds of division in that
8827 -- case by considering:
8828 -- - all values from the division of end values of input
8830 -- - the end values of the left operand;
8831 -- - the negation of the end values of the left operand.
8835 Mrk : constant Uintp.Save_Mark := Mark;
8836 -- Mark so we can release the RR and Ev values
8844 -- Discard extreme values of zero for the divisor, since
8845 -- they will simply result in an exception in any case.
8853 -- Compute possible bounds coming from dividing end
8854 -- values of the input ranges.
8861 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8862 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8864 -- If the right operand can be both negative or positive,
8865 -- include the end values of the left operand in the
8866 -- extreme values, as well as their negation.
8868 if Rlo < 0 and then Rhi > 0 then
8875 UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
8877 UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
8880 -- Release the RR and Ev values
8882 Release_And_Save (Mrk, Lo, Hi);
8890 -- Discard negative values for the exponent, since they will
8891 -- simply result in an exception in any case.
8899 -- Estimate number of bits in result before we go computing
8900 -- giant useless bounds. Basically the number of bits in the
8901 -- result is the number of bits in the base multiplied by the
8902 -- value of the exponent. If this is big enough that the result
8903 -- definitely won't fit in Long_Long_Integer, switch to bignum
8904 -- mode immediately, and avoid computing giant bounds.
8906 -- The comparison here is approximate, but conservative, it
8907 -- only clicks on cases that are sure to exceed the bounds.
8909 if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
8913 -- If right operand is zero then result is 1
8920 -- High bound comes either from exponentiation of largest
8921 -- positive value to largest exponent value, or from
8922 -- the exponentiation of most negative value to an
8936 if Rhi mod 2 = 0 then
8939 Hi2 := Llo ** (Rhi - 1);
8945 Hi := UI_Max (Hi1, Hi2);
8948 -- Result can only be negative if base can be negative
8951 if Rhi mod 2 = 0 then
8952 Lo := Llo ** (Rhi - 1);
8957 -- Otherwise low bound is minimum ** minimum
8974 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8975 -- This is the maximum absolute value of the result
8981 -- The result depends only on the sign and magnitude of
8982 -- the right operand, it does not depend on the sign or
8983 -- magnitude of the left operand.
8996 when N_Op_Multiply =>
8998 -- Possible bounds of multiplication must come from multiplying
8999 -- end values of the input ranges (four possibilities).
9002 Mrk : constant Uintp.Save_Mark := Mark;
9003 -- Mark so we can release the Ev values
9005 Ev1 : constant Uint := Llo * Rlo;
9006 Ev2 : constant Uint := Llo * Rhi;
9007 Ev3 : constant Uint := Lhi * Rlo;
9008 Ev4 : constant Uint := Lhi * Rhi;
9011 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
9012 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
9014 -- Release the Ev values
9016 Release_And_Save (Mrk, Lo, Hi);
9019 -- Plus operator (affirmation)
9029 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
9030 -- This is the maximum absolute value of the result. Note
9031 -- that the result range does not depend on the sign of the
9038 -- Case of left operand negative, which results in a range
9039 -- of -Maxabs .. 0 for those negative values. If there are
9040 -- no negative values then Lo value of result is always 0.
9046 -- Case of left operand positive
9055 when N_Op_Subtract =>
9059 -- Nothing else should be possible
9062 raise Program_Error;
9066 -- Here for the case where we have not rewritten anything (no bignum
9067 -- operands or long long integer operands), and we know the result.
9068 -- If we know we are in the result range, and we do not have Bignum
9069 -- operands or Long_Long_Integer operands, we can just reexpand with
9070 -- overflow checks turned off (since we know we cannot have overflow).
9071 -- As always the reexpansion is required to complete expansion of the
9072 -- operator, but we do not need to reanalyze, and we prevent recursion
9073 -- by suppressing the check.
9075 if not (Bignum_Operands or Long_Long_Integer_Operands)
9076 and then In_Result_Range
9078 Set_Do_Overflow_Check (N, False);
9079 Reexpand (Suppress => True);
9082 -- Here we know that we are not in the result range, and in the general
9083 -- case we will move into either the Bignum or Long_Long_Integer domain
9084 -- to compute the result. However, there is one exception. If we are
9085 -- at the top level, and we do not have Bignum or Long_Long_Integer
9086 -- operands, we will have to immediately convert the result back to
9087 -- the result type, so there is no point in Bignum/Long_Long_Integer
9091 and then not (Bignum_Operands or Long_Long_Integer_Operands)
9093 -- One further refinement. If we are at the top level, but our parent
9094 -- is a type conversion, then go into bignum or long long integer node
9095 -- since the result will be converted to that type directly without
9096 -- going through the result type, and we may avoid an overflow. This
9097 -- is the case for example of Long_Long_Integer (A ** 4), where A is
9098 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
9099 -- but does not fit in Integer.
9101 and then Nkind (Parent (N)) /= N_Type_Conversion
9103 -- Here keep original types, but we need to complete analysis
9105 -- One subtlety. We can't just go ahead and do an analyze operation
9106 -- here because it will cause recursion into the whole MINIMIZED/
9107 -- ELIMINATED overflow processing which is not what we want. Here
9108 -- we are at the top level, and we need a check against the result
9109 -- mode (i.e. we want to use STRICT mode). So do exactly that.
9110 -- Also, we have not modified the node, so this is a case where
9111 -- we need to reexpand, but not reanalyze.
9116 -- Cases where we do the operation in Bignum mode. This happens either
9117 -- because one of our operands is in Bignum mode already, or because
9118 -- the computed bounds are outside the bounds of Long_Long_Integer,
9119 -- which in some cases can be indicated by Hi and Lo being No_Uint.
9121 -- Note: we could do better here and in some cases switch back from
9122 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
9123 -- 0 .. 1, but the cases are rare and it is not worth the effort.
9124 -- Failing to do this switching back is only an efficiency issue.
9126 elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
9128 -- OK, we are definitely outside the range of Long_Long_Integer. The
9129 -- question is whether to move to Bignum mode, or stay in the domain
9130 -- of Long_Long_Integer, signalling that an overflow check is needed.
9132 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
9133 -- the Bignum business. In ELIMINATED mode, we will normally move
9134 -- into Bignum mode, but there is an exception if neither of our
9135 -- operands is Bignum now, and we are at the top level (Top_Level
9136 -- set True). In this case, there is no point in moving into Bignum
9137 -- mode to prevent overflow if the caller will immediately convert
9138 -- the Bignum value back to LLI with an overflow check. It's more
9139 -- efficient to stay in LLI mode with an overflow check (if needed)
9141 if Check_Mode = Minimized
9142 or else (Top_Level and not Bignum_Operands)
9144 if Do_Overflow_Check (N) then
9145 Enable_Overflow_Check (N);
9148 -- The result now has to be in Long_Long_Integer mode, so adjust
9149 -- the possible range to reflect this. Note these calls also
9150 -- change No_Uint values from the top level case to LLI bounds.
9155 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
9158 pragma Assert (Check_Mode = Eliminated);
9167 Fent := RTE (RE_Big_Abs);
9170 Fent := RTE (RE_Big_Add);
9173 Fent := RTE (RE_Big_Div);
9176 Fent := RTE (RE_Big_Exp);
9179 Fent := RTE (RE_Big_Neg);
9182 Fent := RTE (RE_Big_Mod);
9184 when N_Op_Multiply =>
9185 Fent := RTE (RE_Big_Mul);
9188 Fent := RTE (RE_Big_Rem);
9190 when N_Op_Subtract =>
9191 Fent := RTE (RE_Big_Sub);
9193 -- Anything else is an internal error, this includes the
9194 -- N_Op_Plus case, since how can plus cause the result
9195 -- to be out of range if the operand is in range?
9198 raise Program_Error;
9201 -- Construct argument list for Bignum call, converting our
9202 -- operands to Bignum form if they are not already there.
9207 Append_To (Args, Convert_To_Bignum (Left_Opnd (N)));
9210 Append_To (Args, Convert_To_Bignum (Right_Opnd (N)));
9212 -- Now rewrite the arithmetic operator with a call to the
9213 -- corresponding bignum function.
9216 Make_Function_Call (Loc,
9217 Name => New_Occurrence_Of (Fent, Loc),
9218 Parameter_Associations => Args));
9219 Reanalyze (RTE (RE_Bignum), Suppress => True);
9221 -- Indicate result is Bignum mode
9229 -- Otherwise we are in range of Long_Long_Integer, so no overflow
9230 -- check is required, at least not yet.
9233 Set_Do_Overflow_Check (N, False);
9236 -- Here we are not in Bignum territory, but we may have long long
9237 -- integer operands that need special handling. First a special check:
9238 -- If an exponentiation operator exponent is of type Long_Long_Integer,
9239 -- it means we converted it to prevent overflow, but exponentiation
9240 -- requires a Natural right operand, so convert it back to Natural.
9241 -- This conversion may raise an exception which is fine.
9243 if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then
9244 Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N));
9247 -- Here we will do the operation in Long_Long_Integer. We do this even
9248 -- if we know an overflow check is required, better to do this in long
9249 -- long integer mode, since we are less likely to overflow.
9251 -- Convert right or only operand to Long_Long_Integer, except that
9252 -- we do not touch the exponentiation right operand.
9254 if Nkind (N) /= N_Op_Expon then
9255 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
9258 -- Convert left operand to Long_Long_Integer for binary case
9261 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
9264 -- Reset node to unanalyzed
9266 Set_Analyzed (N, False);
9267 Set_Etype (N, Empty);
9268 Set_Entity (N, Empty);
9270 -- Now analyze this new node. This reanalysis will complete processing
9271 -- for the node. In particular we will complete the expansion of an
9272 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
9273 -- we will complete any division checks (since we have not changed the
9274 -- setting of the Do_Division_Check flag).
9276 -- We do this reanalysis in STRICT mode to avoid recursion into the
9277 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
9280 SG : constant Overflow_Mode_Type :=
9281 Scope_Suppress.Overflow_Mode_General;
9282 SA : constant Overflow_Mode_Type :=
9283 Scope_Suppress.Overflow_Mode_Assertions;
9286 Scope_Suppress.Overflow_Mode_General := Strict;
9287 Scope_Suppress.Overflow_Mode_Assertions := Strict;
9289 if not Do_Overflow_Check (N) then
9290 Reanalyze (LLIB, Suppress => True);
9295 Scope_Suppress.Overflow_Mode_General := SG;
9296 Scope_Suppress.Overflow_Mode_Assertions := SA;
9298 end Minimize_Eliminate_Overflows;
9300 -------------------------
9301 -- Overflow_Check_Mode --
9302 -------------------------
9304 function Overflow_Check_Mode return Overflow_Mode_Type is
9306 if In_Assertion_Expr = 0 then
9307 return Scope_Suppress.Overflow_Mode_General;
9309 return Scope_Suppress.Overflow_Mode_Assertions;
9311 end Overflow_Check_Mode;
9313 --------------------------------
9314 -- Overflow_Checks_Suppressed --
9315 --------------------------------
9317 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
9319 if Present (E) and then Checks_May_Be_Suppressed (E) then
9320 return Is_Check_Suppressed (E, Overflow_Check);
9322 return Scope_Suppress.Suppress (Overflow_Check);
9324 end Overflow_Checks_Suppressed;
9326 ---------------------------------
9327 -- Predicate_Checks_Suppressed --
9328 ---------------------------------
9330 function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
9332 if Present (E) and then Checks_May_Be_Suppressed (E) then
9333 return Is_Check_Suppressed (E, Predicate_Check);
9335 return Scope_Suppress.Suppress (Predicate_Check);
9337 end Predicate_Checks_Suppressed;
9339 -----------------------------
9340 -- Range_Checks_Suppressed --
9341 -----------------------------
9343 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
9346 if Kill_Range_Checks (E) then
9349 elsif Checks_May_Be_Suppressed (E) then
9350 return Is_Check_Suppressed (E, Range_Check);
9354 return Scope_Suppress.Suppress (Range_Check);
9355 end Range_Checks_Suppressed;
9357 -----------------------------------------
9358 -- Range_Or_Validity_Checks_Suppressed --
9359 -----------------------------------------
9361 -- Note: the coding would be simpler here if we simply made appropriate
9362 -- calls to Range/Validity_Checks_Suppressed, but that would result in
9363 -- duplicated checks which we prefer to avoid.
9365 function Range_Or_Validity_Checks_Suppressed
9366 (Expr : Node_Id) return Boolean
9369 -- Immediate return if scope checks suppressed for either check
9371 if Scope_Suppress.Suppress (Range_Check)
9373 Scope_Suppress.Suppress (Validity_Check)
9378 -- If no expression, that's odd, decide that checks are suppressed,
9379 -- since we don't want anyone trying to do checks in this case, which
9380 -- is most likely the result of some other error.
9386 -- Expression is present, so perform suppress checks on type
9389 Typ : constant Entity_Id := Etype (Expr);
9391 if Checks_May_Be_Suppressed (Typ)
9392 and then (Is_Check_Suppressed (Typ, Range_Check)
9394 Is_Check_Suppressed (Typ, Validity_Check))
9400 -- If expression is an entity name, perform checks on this entity
9402 if Is_Entity_Name (Expr) then
9404 Ent : constant Entity_Id := Entity (Expr);
9406 if Checks_May_Be_Suppressed (Ent) then
9407 return Is_Check_Suppressed (Ent, Range_Check)
9408 or else Is_Check_Suppressed (Ent, Validity_Check);
9413 -- If we fall through, no checks suppressed
9416 end Range_Or_Validity_Checks_Suppressed;
9422 procedure Remove_Checks (Expr : Node_Id) is
9423 function Process (N : Node_Id) return Traverse_Result;
9424 -- Process a single node during the traversal
9426 procedure Traverse is new Traverse_Proc (Process);
9427 -- The traversal procedure itself
9433 function Process (N : Node_Id) return Traverse_Result is
9435 if Nkind (N) not in N_Subexpr then
9439 Set_Do_Range_Check (N, False);
9443 Traverse (Left_Opnd (N));
9446 when N_Attribute_Reference =>
9447 Set_Do_Overflow_Check (N, False);
9449 when N_Function_Call =>
9450 Set_Do_Tag_Check (N, False);
9453 Set_Do_Overflow_Check (N, False);
9457 Set_Do_Division_Check (N, False);
9460 Set_Do_Length_Check (N, False);
9463 Set_Do_Division_Check (N, False);
9466 Set_Do_Length_Check (N, False);
9469 Set_Do_Division_Check (N, False);
9472 Set_Do_Length_Check (N, False);
9479 Traverse (Left_Opnd (N));
9482 when N_Selected_Component =>
9483 Set_Do_Discriminant_Check (N, False);
9485 when N_Type_Conversion =>
9486 Set_Do_Length_Check (N, False);
9487 Set_Do_Tag_Check (N, False);
9488 Set_Do_Overflow_Check (N, False);
9497 -- Start of processing for Remove_Checks
9503 ----------------------------
9504 -- Selected_Length_Checks --
9505 ----------------------------
9507 function Selected_Length_Checks
9509 Target_Typ : Entity_Id;
9510 Source_Typ : Entity_Id;
9511 Warn_Node : Node_Id) return Check_Result
9513 Loc : constant Source_Ptr := Sloc (Ck_Node);
9516 Expr_Actual : Node_Id;
9518 Cond : Node_Id := Empty;
9519 Do_Access : Boolean := False;
9520 Wnode : Node_Id := Warn_Node;
9521 Ret_Result : Check_Result := (Empty, Empty);
9522 Num_Checks : Natural := 0;
9524 procedure Add_Check (N : Node_Id);
9525 -- Adds the action given to Ret_Result if N is non-Empty
9527 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
9528 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
9529 -- Comments required ???
9531 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
9532 -- True for equal literals and for nodes that denote the same constant
9533 -- entity, even if its value is not a static constant. This includes the
9534 -- case of a discriminal reference within an init proc. Removes some
9535 -- obviously superfluous checks.
9537 function Length_E_Cond
9538 (Exptyp : Entity_Id;
9540 Indx : Nat) return Node_Id;
9541 -- Returns expression to compute:
9542 -- Typ'Length /= Exptyp'Length
9544 function Length_N_Cond
9547 Indx : Nat) return Node_Id;
9548 -- Returns expression to compute:
9549 -- Typ'Length /= Expr'Length
9551 function Length_Mismatch_Info_Message
9552 (Left_Element_Count : Uint;
9553 Right_Element_Count : Uint) return String;
9554 -- Returns a message indicating how many elements were expected
9555 -- (Left_Element_Count) and how many were found (Right_Element_Count).
9561 procedure Add_Check (N : Node_Id) is
9565 -- For now, ignore attempt to place more than two checks ???
9566 -- This is really worrisome, are we really discarding checks ???
9568 if Num_Checks = 2 then
9572 pragma Assert (Num_Checks <= 1);
9573 Num_Checks := Num_Checks + 1;
9574 Ret_Result (Num_Checks) := N;
9582 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
9583 SE : constant Entity_Id := Scope (E);
9585 E1 : Entity_Id := E;
9588 if Ekind (Scope (E)) = E_Record_Type
9589 and then Has_Discriminants (Scope (E))
9591 N := Build_Discriminal_Subtype_Of_Component (E);
9594 Insert_Action (Ck_Node, N);
9595 E1 := Defining_Identifier (N);
9599 if Ekind (E1) = E_String_Literal_Subtype then
9601 Make_Integer_Literal (Loc,
9602 Intval => String_Literal_Length (E1));
9604 elsif SE /= Standard_Standard
9605 and then Ekind (Scope (SE)) = E_Protected_Type
9606 and then Has_Discriminants (Scope (SE))
9607 and then Has_Completion (Scope (SE))
9608 and then not Inside_Init_Proc
9610 -- If the type whose length is needed is a private component
9611 -- constrained by a discriminant, we must expand the 'Length
9612 -- attribute into an explicit computation, using the discriminal
9613 -- of the current protected operation. This is because the actual
9614 -- type of the prival is constructed after the protected opera-
9615 -- tion has been fully expanded.
9618 Indx_Type : Node_Id;
9621 Do_Expand : Boolean := False;
9624 Indx_Type := First_Index (E);
9626 for J in 1 .. Indx - 1 loop
9627 Next_Index (Indx_Type);
9630 Get_Index_Bounds (Indx_Type, Lo, Hi);
9632 if Nkind (Lo) = N_Identifier
9633 and then Ekind (Entity (Lo)) = E_In_Parameter
9635 Lo := Get_Discriminal (E, Lo);
9639 if Nkind (Hi) = N_Identifier
9640 and then Ekind (Entity (Hi)) = E_In_Parameter
9642 Hi := Get_Discriminal (E, Hi);
9647 if not Is_Entity_Name (Lo) then
9648 Lo := Duplicate_Subexpr_No_Checks (Lo);
9651 if not Is_Entity_Name (Hi) then
9652 Lo := Duplicate_Subexpr_No_Checks (Hi);
9658 Make_Op_Subtract (Loc,
9662 Right_Opnd => Make_Integer_Literal (Loc, 1));
9667 Make_Attribute_Reference (Loc,
9668 Attribute_Name => Name_Length,
9670 New_Occurrence_Of (E1, Loc));
9673 Set_Expressions (N, New_List (
9674 Make_Integer_Literal (Loc, Indx)));
9683 Make_Attribute_Reference (Loc,
9684 Attribute_Name => Name_Length,
9686 New_Occurrence_Of (E1, Loc));
9689 Set_Expressions (N, New_List (
9690 Make_Integer_Literal (Loc, Indx)));
9701 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
9704 Make_Attribute_Reference (Loc,
9705 Attribute_Name => Name_Length,
9707 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9708 Expressions => New_List (
9709 Make_Integer_Literal (Loc, Indx)));
9716 function Length_E_Cond
9717 (Exptyp : Entity_Id;
9719 Indx : Nat) return Node_Id
9724 Left_Opnd => Get_E_Length (Typ, Indx),
9725 Right_Opnd => Get_E_Length (Exptyp, Indx));
9732 function Length_N_Cond
9735 Indx : Nat) return Node_Id
9740 Left_Opnd => Get_E_Length (Typ, Indx),
9741 Right_Opnd => Get_N_Length (Expr, Indx));
9744 ----------------------------------
9745 -- Length_Mismatch_Info_Message --
9746 ----------------------------------
9748 function Length_Mismatch_Info_Message
9749 (Left_Element_Count : Uint;
9750 Right_Element_Count : Uint) return String
9753 function Plural_Vs_Singular_Ending (Count : Uint) return String;
9754 -- Returns an empty string if Count is 1; otherwise returns "s"
9756 function Plural_Vs_Singular_Ending (Count : Uint) return String is
9763 end Plural_Vs_Singular_Ending;
9766 return "expected " & UI_Image (Left_Element_Count)
9768 & Plural_Vs_Singular_Ending (Left_Element_Count)
9769 & "; found " & UI_Image (Right_Element_Count)
9771 & Plural_Vs_Singular_Ending (Right_Element_Count);
9772 end Length_Mismatch_Info_Message;
9778 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
9781 (Nkind (L) = N_Integer_Literal
9782 and then Nkind (R) = N_Integer_Literal
9783 and then Intval (L) = Intval (R))
9787 and then Ekind (Entity (L)) = E_Constant
9788 and then ((Is_Entity_Name (R)
9789 and then Entity (L) = Entity (R))
9791 (Nkind (R) = N_Type_Conversion
9792 and then Is_Entity_Name (Expression (R))
9793 and then Entity (L) = Entity (Expression (R)))))
9797 and then Ekind (Entity (R)) = E_Constant
9798 and then Nkind (L) = N_Type_Conversion
9799 and then Is_Entity_Name (Expression (L))
9800 and then Entity (R) = Entity (Expression (L)))
9804 and then Is_Entity_Name (R)
9805 and then Entity (L) = Entity (R)
9806 and then Ekind (Entity (L)) = E_In_Parameter
9807 and then Inside_Init_Proc);
9810 -- Start of processing for Selected_Length_Checks
9813 -- Checks will be applied only when generating code
9815 if not Expander_Active then
9819 if Target_Typ = Any_Type
9820 or else Target_Typ = Any_Composite
9821 or else Raises_Constraint_Error (Ck_Node)
9830 T_Typ := Target_Typ;
9832 if No (Source_Typ) then
9833 S_Typ := Etype (Ck_Node);
9835 S_Typ := Source_Typ;
9838 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9842 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9843 S_Typ := Designated_Type (S_Typ);
9844 T_Typ := Designated_Type (T_Typ);
9847 -- A simple optimization for the null case
9849 if Known_Null (Ck_Node) then
9854 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9855 if Is_Constrained (T_Typ) then
9857 -- The checking code to be generated will freeze the corresponding
9858 -- array type. However, we must freeze the type now, so that the
9859 -- freeze node does not appear within the generated if expression,
9862 Freeze_Before (Ck_Node, T_Typ);
9864 Expr_Actual := Get_Referenced_Object (Ck_Node);
9865 Exptyp := Get_Actual_Subtype (Ck_Node);
9867 if Is_Access_Type (Exptyp) then
9868 Exptyp := Designated_Type (Exptyp);
9871 -- String_Literal case. This needs to be handled specially be-
9872 -- cause no index types are available for string literals. The
9873 -- condition is simply:
9875 -- T_Typ'Length = string-literal-length
9877 if Nkind (Expr_Actual) = N_String_Literal
9878 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
9882 Left_Opnd => Get_E_Length (T_Typ, 1),
9884 Make_Integer_Literal (Loc,
9886 String_Literal_Length (Etype (Expr_Actual))));
9888 -- General array case. Here we have a usable actual subtype for
9889 -- the expression, and the condition is built from the two types
9892 -- T_Typ'Length /= Exptyp'Length or else
9893 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9894 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9897 elsif Is_Constrained (Exptyp) then
9899 Ndims : constant Nat := Number_Dimensions (T_Typ);
9912 -- At the library level, we need to ensure that the type of
9913 -- the object is elaborated before the check itself is
9914 -- emitted. This is only done if the object is in the
9915 -- current compilation unit, otherwise the type is frozen
9916 -- and elaborated in its unit.
9918 if Is_Itype (Exptyp)
9920 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
9922 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
9923 and then In_Open_Scopes (Scope (Exptyp))
9925 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
9926 Set_Itype (Ref_Node, Exptyp);
9927 Insert_Action (Ck_Node, Ref_Node);
9930 L_Index := First_Index (T_Typ);
9931 R_Index := First_Index (Exptyp);
9933 for Indx in 1 .. Ndims loop
9934 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9936 Nkind (R_Index) = N_Raise_Constraint_Error)
9938 Get_Index_Bounds (L_Index, L_Low, L_High);
9939 Get_Index_Bounds (R_Index, R_Low, R_High);
9941 -- Deal with compile time length check. Note that we
9942 -- skip this in the access case, because the access
9943 -- value may be null, so we cannot know statically.
9946 and then Compile_Time_Known_Value (L_Low)
9947 and then Compile_Time_Known_Value (L_High)
9948 and then Compile_Time_Known_Value (R_Low)
9949 and then Compile_Time_Known_Value (R_High)
9951 if Expr_Value (L_High) >= Expr_Value (L_Low) then
9952 L_Length := Expr_Value (L_High) -
9953 Expr_Value (L_Low) + 1;
9955 L_Length := UI_From_Int (0);
9958 if Expr_Value (R_High) >= Expr_Value (R_Low) then
9959 R_Length := Expr_Value (R_High) -
9960 Expr_Value (R_Low) + 1;
9962 R_Length := UI_From_Int (0);
9965 if L_Length > R_Length then
9967 (Compile_Time_Constraint_Error
9968 (Wnode, "too few elements for}??", T_Typ,
9969 Extra_Msg => Length_Mismatch_Info_Message
9970 (L_Length, R_Length)));
9972 elsif L_Length < R_Length then
9974 (Compile_Time_Constraint_Error
9975 (Wnode, "too many elements for}??", T_Typ,
9976 Extra_Msg => Length_Mismatch_Info_Message
9977 (L_Length, R_Length)));
9980 -- The comparison for an individual index subtype
9981 -- is omitted if the corresponding index subtypes
9982 -- statically match, since the result is known to
9983 -- be true. Note that this test is worth while even
9984 -- though we do static evaluation, because non-static
9985 -- subtypes can statically match.
9988 Subtypes_Statically_Match
9989 (Etype (L_Index), Etype (R_Index))
9992 (Same_Bounds (L_Low, R_Low)
9993 and then Same_Bounds (L_High, R_High))
9996 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
10005 -- Handle cases where we do not get a usable actual subtype that
10006 -- is constrained. This happens for example in the function call
10007 -- and explicit dereference cases. In these cases, we have to get
10008 -- the length or range from the expression itself, making sure we
10009 -- do not evaluate it more than once.
10011 -- Here Ck_Node is the original expression, or more properly the
10012 -- result of applying Duplicate_Expr to the original tree, forcing
10013 -- the result to be a name.
10017 Ndims : constant Nat := Number_Dimensions (T_Typ);
10020 -- Build the condition for the explicit dereference case
10022 for Indx in 1 .. Ndims loop
10024 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
10031 -- Construct the test and insert into the tree
10033 if Present (Cond) then
10035 Cond := Guard_Access (Cond, Loc, Ck_Node);
10039 (Make_Raise_Constraint_Error (Loc,
10041 Reason => CE_Length_Check_Failed));
10045 end Selected_Length_Checks;
10047 ---------------------------
10048 -- Selected_Range_Checks --
10049 ---------------------------
10051 function Selected_Range_Checks
10052 (Ck_Node : Node_Id;
10053 Target_Typ : Entity_Id;
10054 Source_Typ : Entity_Id;
10055 Warn_Node : Node_Id) return Check_Result
10057 Loc : constant Source_Ptr := Sloc (Ck_Node);
10060 Expr_Actual : Node_Id;
10061 Exptyp : Entity_Id;
10062 Cond : Node_Id := Empty;
10063 Do_Access : Boolean := False;
10064 Wnode : Node_Id := Warn_Node;
10065 Ret_Result : Check_Result := (Empty, Empty);
10066 Num_Checks : Natural := 0;
10068 procedure Add_Check (N : Node_Id);
10069 -- Adds the action given to Ret_Result if N is non-Empty
10071 function Discrete_Range_Cond
10073 Typ : Entity_Id) return Node_Id;
10074 -- Returns expression to compute:
10075 -- Low_Bound (Expr) < Typ'First
10077 -- High_Bound (Expr) > Typ'Last
10079 function Discrete_Expr_Cond
10081 Typ : Entity_Id) return Node_Id;
10082 -- Returns expression to compute:
10083 -- Expr < Typ'First
10087 function Get_E_First_Or_Last
10091 Nam : Name_Id) return Node_Id;
10092 -- Returns an attribute reference
10093 -- E'First or E'Last
10094 -- with a source location of Loc.
10096 -- Nam is Name_First or Name_Last, according to which attribute is
10097 -- desired. If Indx is non-zero, it is passed as a literal in the
10098 -- Expressions of the attribute reference (identifying the desired
10099 -- array dimension).
10101 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
10102 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
10103 -- Returns expression to compute:
10104 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
10106 function Range_E_Cond
10107 (Exptyp : Entity_Id;
10111 -- Returns expression to compute:
10112 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
10114 function Range_Equal_E_Cond
10115 (Exptyp : Entity_Id;
10117 Indx : Nat) return Node_Id;
10118 -- Returns expression to compute:
10119 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
10121 function Range_N_Cond
10124 Indx : Nat) return Node_Id;
10125 -- Return expression to compute:
10126 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
10132 procedure Add_Check (N : Node_Id) is
10134 if Present (N) then
10136 -- For now, ignore attempt to place more than 2 checks ???
10138 if Num_Checks = 2 then
10142 pragma Assert (Num_Checks <= 1);
10143 Num_Checks := Num_Checks + 1;
10144 Ret_Result (Num_Checks) := N;
10148 -------------------------
10149 -- Discrete_Expr_Cond --
10150 -------------------------
10152 function Discrete_Expr_Cond
10154 Typ : Entity_Id) return Node_Id
10162 Convert_To (Base_Type (Typ),
10163 Duplicate_Subexpr_No_Checks (Expr)),
10165 Convert_To (Base_Type (Typ),
10166 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
10171 Convert_To (Base_Type (Typ),
10172 Duplicate_Subexpr_No_Checks (Expr)),
10176 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
10177 end Discrete_Expr_Cond;
10179 -------------------------
10180 -- Discrete_Range_Cond --
10181 -------------------------
10183 function Discrete_Range_Cond
10185 Typ : Entity_Id) return Node_Id
10187 LB : Node_Id := Low_Bound (Expr);
10188 HB : Node_Id := High_Bound (Expr);
10190 Left_Opnd : Node_Id;
10191 Right_Opnd : Node_Id;
10194 if Nkind (LB) = N_Identifier
10195 and then Ekind (Entity (LB)) = E_Discriminant
10197 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
10204 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
10209 Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
10211 if Nkind (HB) = N_Identifier
10212 and then Ekind (Entity (HB)) = E_Discriminant
10214 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
10221 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
10226 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
10228 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
10229 end Discrete_Range_Cond;
10231 -------------------------
10232 -- Get_E_First_Or_Last --
10233 -------------------------
10235 function Get_E_First_Or_Last
10239 Nam : Name_Id) return Node_Id
10244 Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
10249 return Make_Attribute_Reference (Loc,
10250 Prefix => New_Occurrence_Of (E, Loc),
10251 Attribute_Name => Nam,
10252 Expressions => Exprs);
10253 end Get_E_First_Or_Last;
10259 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
10262 Make_Attribute_Reference (Loc,
10263 Attribute_Name => Name_First,
10265 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
10266 Expressions => New_List (
10267 Make_Integer_Literal (Loc, Indx)));
10274 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
10277 Make_Attribute_Reference (Loc,
10278 Attribute_Name => Name_Last,
10280 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
10281 Expressions => New_List (
10282 Make_Integer_Literal (Loc, Indx)));
10289 function Range_E_Cond
10290 (Exptyp : Entity_Id;
10292 Indx : Nat) return Node_Id
10300 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
10302 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
10307 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
10309 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
10312 ------------------------
10313 -- Range_Equal_E_Cond --
10314 ------------------------
10316 function Range_Equal_E_Cond
10317 (Exptyp : Entity_Id;
10319 Indx : Nat) return Node_Id
10327 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
10329 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
10334 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
10336 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
10337 end Range_Equal_E_Cond;
10343 function Range_N_Cond
10346 Indx : Nat) return Node_Id
10354 Get_N_First (Expr, Indx),
10356 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
10361 Get_N_Last (Expr, Indx),
10363 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
10366 -- Start of processing for Selected_Range_Checks
10369 -- Checks will be applied only when generating code. In GNATprove mode,
10370 -- we do not apply the checks, but we still call Selected_Range_Checks
10371 -- to possibly issue errors on SPARK code when a run-time error can be
10372 -- detected at compile time.
10374 if not Expander_Active and not GNATprove_Mode then
10378 if Target_Typ = Any_Type
10379 or else Target_Typ = Any_Composite
10380 or else Raises_Constraint_Error (Ck_Node)
10389 T_Typ := Target_Typ;
10391 if No (Source_Typ) then
10392 S_Typ := Etype (Ck_Node);
10394 S_Typ := Source_Typ;
10397 if S_Typ = Any_Type or else S_Typ = Any_Composite then
10401 -- The order of evaluating T_Typ before S_Typ seems to be critical
10402 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
10403 -- in, and since Node can be an N_Range node, it might be invalid.
10404 -- Should there be an assert check somewhere for taking the Etype of
10405 -- an N_Range node ???
10407 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
10408 S_Typ := Designated_Type (S_Typ);
10409 T_Typ := Designated_Type (T_Typ);
10412 -- A simple optimization for the null case
10414 if Known_Null (Ck_Node) then
10419 -- For an N_Range Node, check for a null range and then if not
10420 -- null generate a range check action.
10422 if Nkind (Ck_Node) = N_Range then
10424 -- There's no point in checking a range against itself
10426 if Ck_Node = Scalar_Range (T_Typ) then
10431 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
10432 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
10433 Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
10434 Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
10436 LB : Node_Id := Low_Bound (Ck_Node);
10437 HB : Node_Id := High_Bound (Ck_Node);
10438 Known_LB : Boolean := False;
10439 Known_HB : Boolean := False;
10441 Null_Range : Boolean;
10442 Out_Of_Range_L : Boolean;
10443 Out_Of_Range_H : Boolean;
10446 -- Compute what is known at compile time
10448 if Known_T_LB and Known_T_HB then
10449 if Compile_Time_Known_Value (LB) then
10452 -- There's no point in checking that a bound is within its
10453 -- own range so pretend that it is known in this case. First
10454 -- deal with low bound.
10456 elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype
10457 and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ)
10463 -- Likewise for the high bound
10465 if Compile_Time_Known_Value (HB) then
10468 elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype
10469 and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ)
10476 -- Check for case where everything is static and we can do the
10477 -- check at compile time. This is skipped if we have an access
10478 -- type, since the access value may be null.
10480 -- ??? This code can be improved since you only need to know that
10481 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
10482 -- compile time to emit pertinent messages.
10484 if Known_T_LB and Known_T_HB and Known_LB and Known_HB
10487 -- Floating-point case
10489 if Is_Floating_Point_Type (S_Typ) then
10490 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
10492 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
10494 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
10497 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
10499 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
10501 -- Fixed or discrete type case
10504 Null_Range := Expr_Value (HB) < Expr_Value (LB);
10506 (Expr_Value (LB) < Expr_Value (T_LB))
10508 (Expr_Value (LB) > Expr_Value (T_HB));
10511 (Expr_Value (HB) > Expr_Value (T_HB))
10513 (Expr_Value (HB) < Expr_Value (T_LB));
10516 if not Null_Range then
10517 if Out_Of_Range_L then
10518 if No (Warn_Node) then
10520 (Compile_Time_Constraint_Error
10521 (Low_Bound (Ck_Node),
10522 "static value out of range of}??", T_Typ));
10526 (Compile_Time_Constraint_Error
10528 "static range out of bounds of}??", T_Typ));
10532 if Out_Of_Range_H then
10533 if No (Warn_Node) then
10535 (Compile_Time_Constraint_Error
10536 (High_Bound (Ck_Node),
10537 "static value out of range of}??", T_Typ));
10541 (Compile_Time_Constraint_Error
10543 "static range out of bounds of}??", T_Typ));
10550 LB : Node_Id := Low_Bound (Ck_Node);
10551 HB : Node_Id := High_Bound (Ck_Node);
10554 -- If either bound is a discriminant and we are within the
10555 -- record declaration, it is a use of the discriminant in a
10556 -- constraint of a component, and nothing can be checked
10557 -- here. The check will be emitted within the init proc.
10558 -- Before then, the discriminal has no real meaning.
10559 -- Similarly, if the entity is a discriminal, there is no
10560 -- check to perform yet.
10562 -- The same holds within a discriminated synchronized type,
10563 -- where the discriminant may constrain a component or an
10566 if Nkind (LB) = N_Identifier
10567 and then Denotes_Discriminant (LB, True)
10569 if Current_Scope = Scope (Entity (LB))
10570 or else Is_Concurrent_Type (Current_Scope)
10571 or else Ekind (Entity (LB)) /= E_Discriminant
10576 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
10580 if Nkind (HB) = N_Identifier
10581 and then Denotes_Discriminant (HB, True)
10583 if Current_Scope = Scope (Entity (HB))
10584 or else Is_Concurrent_Type (Current_Scope)
10585 or else Ekind (Entity (HB)) /= E_Discriminant
10590 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
10594 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
10595 Set_Paren_Count (Cond, 1);
10598 Make_And_Then (Loc,
10602 Convert_To (Base_Type (Etype (HB)),
10603 Duplicate_Subexpr_No_Checks (HB)),
10605 Convert_To (Base_Type (Etype (LB)),
10606 Duplicate_Subexpr_No_Checks (LB))),
10607 Right_Opnd => Cond);
10612 elsif Is_Scalar_Type (S_Typ) then
10614 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
10615 -- except the above simply sets a flag in the node and lets
10616 -- gigi generate the check base on the Etype of the expression.
10617 -- Sometimes, however we want to do a dynamic check against an
10618 -- arbitrary target type, so we do that here.
10620 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
10621 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
10623 -- For literals, we can tell if the constraint error will be
10624 -- raised at compile time, so we never need a dynamic check, but
10625 -- if the exception will be raised, then post the usual warning,
10626 -- and replace the literal with a raise constraint error
10627 -- expression. As usual, skip this for access types
10629 elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
10631 LB : constant Node_Id := Type_Low_Bound (T_Typ);
10632 UB : constant Node_Id := Type_High_Bound (T_Typ);
10634 Out_Of_Range : Boolean;
10635 Static_Bounds : constant Boolean :=
10636 Compile_Time_Known_Value (LB)
10637 and Compile_Time_Known_Value (UB);
10640 -- Following range tests should use Sem_Eval routine ???
10642 if Static_Bounds then
10643 if Is_Floating_Point_Type (S_Typ) then
10645 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
10647 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
10649 -- Fixed or discrete type
10653 Expr_Value (Ck_Node) < Expr_Value (LB)
10655 Expr_Value (Ck_Node) > Expr_Value (UB);
10658 -- Bounds of the type are static and the literal is out of
10659 -- range so output a warning message.
10661 if Out_Of_Range then
10662 if No (Warn_Node) then
10664 (Compile_Time_Constraint_Error
10666 "static value out of range of}??", T_Typ));
10670 (Compile_Time_Constraint_Error
10672 "static value out of range of}??", T_Typ));
10677 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
10681 -- Here for the case of a non-static expression, we need a runtime
10682 -- check unless the source type range is guaranteed to be in the
10683 -- range of the target type.
10686 if not In_Subrange_Of (S_Typ, T_Typ) then
10687 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
10692 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
10693 if Is_Constrained (T_Typ) then
10695 Expr_Actual := Get_Referenced_Object (Ck_Node);
10696 Exptyp := Get_Actual_Subtype (Expr_Actual);
10698 if Is_Access_Type (Exptyp) then
10699 Exptyp := Designated_Type (Exptyp);
10702 -- String_Literal case. This needs to be handled specially be-
10703 -- cause no index types are available for string literals. The
10704 -- condition is simply:
10706 -- T_Typ'Length = string-literal-length
10708 if Nkind (Expr_Actual) = N_String_Literal then
10711 -- General array case. Here we have a usable actual subtype for
10712 -- the expression, and the condition is built from the two types
10714 -- T_Typ'First < Exptyp'First or else
10715 -- T_Typ'Last > Exptyp'Last or else
10716 -- T_Typ'First(1) < Exptyp'First(1) or else
10717 -- T_Typ'Last(1) > Exptyp'Last(1) or else
10720 elsif Is_Constrained (Exptyp) then
10722 Ndims : constant Nat := Number_Dimensions (T_Typ);
10728 L_Index := First_Index (T_Typ);
10729 R_Index := First_Index (Exptyp);
10731 for Indx in 1 .. Ndims loop
10732 if not (Nkind (L_Index) = N_Raise_Constraint_Error
10734 Nkind (R_Index) = N_Raise_Constraint_Error)
10736 -- Deal with compile time length check. Note that we
10737 -- skip this in the access case, because the access
10738 -- value may be null, so we cannot know statically.
10741 Subtypes_Statically_Match
10742 (Etype (L_Index), Etype (R_Index))
10744 -- If the target type is constrained then we
10745 -- have to check for exact equality of bounds
10746 -- (required for qualified expressions).
10748 if Is_Constrained (T_Typ) then
10751 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
10754 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
10764 -- Handle cases where we do not get a usable actual subtype that
10765 -- is constrained. This happens for example in the function call
10766 -- and explicit dereference cases. In these cases, we have to get
10767 -- the length or range from the expression itself, making sure we
10768 -- do not evaluate it more than once.
10770 -- Here Ck_Node is the original expression, or more properly the
10771 -- result of applying Duplicate_Expr to the original tree,
10772 -- forcing the result to be a name.
10776 Ndims : constant Nat := Number_Dimensions (T_Typ);
10779 -- Build the condition for the explicit dereference case
10781 for Indx in 1 .. Ndims loop
10783 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
10789 -- For a conversion to an unconstrained array type, generate an
10790 -- Action to check that the bounds of the source value are within
10791 -- the constraints imposed by the target type (RM 4.6(38)). No
10792 -- check is needed for a conversion to an access to unconstrained
10793 -- array type, as 4.6(24.15/2) requires the designated subtypes
10794 -- of the two access types to statically match.
10796 if Nkind (Parent (Ck_Node)) = N_Type_Conversion
10797 and then not Do_Access
10800 Opnd_Index : Node_Id;
10801 Targ_Index : Node_Id;
10802 Opnd_Range : Node_Id;
10805 Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
10806 Targ_Index := First_Index (T_Typ);
10807 while Present (Opnd_Index) loop
10809 -- If the index is a range, use its bounds. If it is an
10810 -- entity (as will be the case if it is a named subtype
10811 -- or an itype created for a slice) retrieve its range.
10813 if Is_Entity_Name (Opnd_Index)
10814 and then Is_Type (Entity (Opnd_Index))
10816 Opnd_Range := Scalar_Range (Entity (Opnd_Index));
10818 Opnd_Range := Opnd_Index;
10821 if Nkind (Opnd_Range) = N_Range then
10823 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10824 Assume_Valid => True)
10827 (High_Bound (Opnd_Range), Etype (Targ_Index),
10828 Assume_Valid => True)
10832 -- If null range, no check needed
10835 Compile_Time_Known_Value (High_Bound (Opnd_Range))
10837 Compile_Time_Known_Value (Low_Bound (Opnd_Range))
10839 Expr_Value (High_Bound (Opnd_Range)) <
10840 Expr_Value (Low_Bound (Opnd_Range))
10844 elsif Is_Out_Of_Range
10845 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10846 Assume_Valid => True)
10849 (High_Bound (Opnd_Range), Etype (Targ_Index),
10850 Assume_Valid => True)
10853 (Compile_Time_Constraint_Error
10854 (Wnode, "value out of range of}??", T_Typ));
10859 Discrete_Range_Cond
10860 (Opnd_Range, Etype (Targ_Index)));
10864 Next_Index (Opnd_Index);
10865 Next_Index (Targ_Index);
10872 -- Construct the test and insert into the tree
10874 if Present (Cond) then
10876 Cond := Guard_Access (Cond, Loc, Ck_Node);
10880 (Make_Raise_Constraint_Error (Loc,
10882 Reason => CE_Range_Check_Failed));
10886 end Selected_Range_Checks;
10888 -------------------------------
10889 -- Storage_Checks_Suppressed --
10890 -------------------------------
10892 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
10894 if Present (E) and then Checks_May_Be_Suppressed (E) then
10895 return Is_Check_Suppressed (E, Storage_Check);
10897 return Scope_Suppress.Suppress (Storage_Check);
10899 end Storage_Checks_Suppressed;
10901 ---------------------------
10902 -- Tag_Checks_Suppressed --
10903 ---------------------------
10905 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
10908 and then Checks_May_Be_Suppressed (E)
10910 return Is_Check_Suppressed (E, Tag_Check);
10912 return Scope_Suppress.Suppress (Tag_Check);
10914 end Tag_Checks_Suppressed;
10916 ---------------------------------------
10917 -- Validate_Alignment_Check_Warnings --
10918 ---------------------------------------
10920 procedure Validate_Alignment_Check_Warnings is
10922 for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop
10924 AWR : Alignment_Warnings_Record
10925 renames Alignment_Warnings.Table (J);
10927 if Known_Alignment (AWR.E)
10928 and then AWR.A mod Alignment (AWR.E) = 0
10930 Delete_Warning_And_Continuations (AWR.W);
10934 end Validate_Alignment_Check_Warnings;
10936 --------------------------
10937 -- Validity_Check_Range --
10938 --------------------------
10940 procedure Validity_Check_Range
10942 Related_Id : Entity_Id := Empty)
10945 if Validity_Checks_On and Validity_Check_Operands then
10946 if Nkind (N) = N_Range then
10948 (Expr => Low_Bound (N),
10949 Related_Id => Related_Id,
10950 Is_Low_Bound => True);
10953 (Expr => High_Bound (N),
10954 Related_Id => Related_Id,
10955 Is_High_Bound => True);
10958 end Validity_Check_Range;
10960 --------------------------------
10961 -- Validity_Checks_Suppressed --
10962 --------------------------------
10964 function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
10966 if Present (E) and then Checks_May_Be_Suppressed (E) then
10967 return Is_Check_Suppressed (E, Validity_Check);
10969 return Scope_Suppress.Suppress (Validity_Check);
10971 end Validity_Checks_Suppressed;