1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Eval_Fat
; use Eval_Fat
;
33 with Exp_Ch11
; use Exp_Ch11
;
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_Cat
; use Sem_Cat
;
52 with Sem_Disp
; use Sem_Disp
;
53 with Sem_Eval
; use Sem_Eval
;
54 with Sem_Mech
; use Sem_Mech
;
55 with Sem_Res
; use Sem_Res
;
56 with Sem_Util
; use Sem_Util
;
57 with Sem_Warn
; use Sem_Warn
;
58 with Sinfo
; use Sinfo
;
59 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
60 with Sinfo
.Utils
; use Sinfo
.Utils
;
61 with Sinput
; use Sinput
;
62 with Snames
; use Snames
;
63 with Sprint
; use Sprint
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Targparm
; use Targparm
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Validsw
; use Validsw
;
71 package body Checks
is
73 -- General note: many of these routines are concerned with generating
74 -- checking code to make sure that constraint error is raised at runtime.
75 -- Clearly this code is only needed if the expander is active, since
76 -- otherwise we will not be generating code or going into the runtime
79 -- We therefore disconnect most of these checks if the expander is
80 -- inactive. This has the additional benefit that we do not need to
81 -- worry about the tree being messed up by previous errors (since errors
82 -- turn off expansion anyway).
84 -- There are a few exceptions to the above rule. For instance routines
85 -- such as Apply_Scalar_Range_Check that do not insert any code can be
86 -- safely called even when the Expander is inactive (but Errors_Detected
87 -- is 0). The benefit of executing this code when expansion is off, is
88 -- the ability to emit constraint error warnings for static expressions
89 -- even when we are not generating code.
91 -- The above is modified in gnatprove mode to ensure that proper check
92 -- flags are always placed, even if expansion is off.
94 -------------------------------------
95 -- Suppression of Redundant Checks --
96 -------------------------------------
98 -- This unit implements a limited circuit for removal of redundant
99 -- checks. The processing is based on a tracing of simple sequential
100 -- flow. For any sequence of statements, we save expressions that are
101 -- marked to be checked, and then if the same expression appears later
102 -- with the same check, then under certain circumstances, the second
103 -- check can be suppressed.
105 -- Basically, we can suppress the check if we know for certain that
106 -- the previous expression has been elaborated (together with its
107 -- check), and we know that the exception frame is the same, and that
108 -- nothing has happened to change the result of the exception.
110 -- Let us examine each of these three conditions in turn to describe
111 -- how we ensure that this condition is met.
113 -- First, we need to know for certain that the previous expression has
114 -- been executed. This is done principally by the mechanism of calling
115 -- Conditional_Statements_Begin at the start of any statement sequence
116 -- and Conditional_Statements_End at the end. The End call causes all
117 -- checks remembered since the Begin call to be discarded. This does
118 -- miss a few cases, notably the case of a nested BEGIN-END block with
119 -- no exception handlers. But the important thing is to be conservative.
120 -- The other protection is that all checks are discarded if a label
121 -- is encountered, since then the assumption of sequential execution
122 -- is violated, and we don't know enough about the flow.
124 -- Second, we need to know that the exception frame is the same. We
125 -- do this by killing all remembered checks when we enter a new frame.
126 -- Again, that's over-conservative, but generally the cases we can help
127 -- with are pretty local anyway (like the body of a loop for example).
129 -- Third, we must be sure to forget any checks which are no longer valid.
130 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
131 -- used to note any changes to local variables. We only attempt to deal
132 -- with checks involving local variables, so we do not need to worry
133 -- about global variables. Second, a call to any non-global procedure
134 -- causes us to abandon all stored checks, since such a all may affect
135 -- the values of any local variables.
137 -- The following define the data structures used to deal with remembering
138 -- checks so that redundant checks can be eliminated as described above.
140 -- Right now, the only expressions that we deal with are of the form of
141 -- simple local objects (either declared locally, or IN parameters) or
142 -- such objects plus/minus a compile time known constant. We can do
143 -- more later on if it seems worthwhile, but this catches many simple
144 -- cases in practice.
146 -- The following record type reflects a single saved check. An entry
147 -- is made in the stack of saved checks if and only if the expression
148 -- has been elaborated with the indicated checks.
150 type Saved_Check
is record
152 -- Set True if entry is killed by Kill_Checks
155 -- The entity involved in the expression that is checked
158 -- A compile time value indicating the result of adding or
159 -- subtracting a compile time value. This value is to be
160 -- added to the value of the Entity. A value of zero is
161 -- used for the case of a simple entity reference.
163 Check_Type
: Character;
164 -- This is set to 'R' for a range check (in which case Target_Type
165 -- is set to the target type for the range check) or to 'O' for an
166 -- overflow check (in which case Target_Type is set to Empty).
168 Target_Type
: Entity_Id
;
169 -- Used only if Do_Range_Check is set. Records the target type for
170 -- the check. We need this, because a check is a duplicate only if
171 -- it has the same target type (or more accurately one with a
172 -- range that is smaller or equal to the stored target type of a
176 -- The following table keeps track of saved checks. Rather than use an
177 -- extensible table, we just use a table of fixed size, and we discard
178 -- any saved checks that do not fit. That's very unlikely to happen and
179 -- this is only an optimization in any case.
181 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
182 -- Array of saved checks
184 Num_Saved_Checks
: Nat
:= 0;
185 -- Number of saved checks
187 -- The following stack keeps track of statement ranges. It is treated
188 -- as a stack. When Conditional_Statements_Begin is called, an entry
189 -- is pushed onto this stack containing the value of Num_Saved_Checks
190 -- at the time of the call. Then when Conditional_Statements_End is
191 -- called, this value is popped off and used to reset Num_Saved_Checks.
193 -- Note: again, this is a fixed length stack with a size that should
194 -- always be fine. If the value of the stack pointer goes above the
195 -- limit, then we just forget all saved checks.
197 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
198 Saved_Checks_TOS
: Nat
:= 0;
200 -----------------------
201 -- Local Subprograms --
202 -----------------------
204 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
205 -- Used to apply arithmetic overflow checks for all cases except operators
206 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
207 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
208 -- signed integer arithmetic operator (but not an if or case expression).
209 -- It is also called for types other than signed integers.
211 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
212 -- Used to apply arithmetic overflow checks for the case where the overflow
213 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
214 -- arithmetic op (which includes the case of if and case expressions). Note
215 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
216 -- we have work to do even if overflow checking is suppressed.
218 procedure Apply_Division_Check
223 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
224 -- division checks as required if the Do_Division_Check flag is set.
225 -- Rlo and Rhi give the possible range of the right operand, these values
226 -- can be referenced and trusted only if ROK is set True.
228 procedure Apply_Float_Conversion_Check
230 Target_Typ
: Entity_Id
);
231 -- The checks on a conversion from a floating-point type to an integer
232 -- type are delicate. They have to be performed before conversion, they
233 -- have to raise an exception when the operand is a NaN, and rounding must
234 -- be taken into account to determine the safe bounds of the operand.
236 procedure Apply_Selected_Length_Checks
238 Target_Typ
: Entity_Id
;
239 Source_Typ
: Entity_Id
;
240 Do_Static
: Boolean);
241 -- This is the subprogram that does all the work for Apply_Length_Check
242 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
243 -- described for the above routines. The Do_Static flag indicates that
244 -- only a static check is to be done.
246 procedure Compute_Range_For_Arithmetic_Op
255 -- Given an integer arithmetical operation Op and the range of values of
256 -- its operand(s), try to compute a conservative estimate of the possible
257 -- range of values for the result of the operation. Thus if OK is True on
258 -- return, the result is known to lie in the range Lo .. Hi (inclusive).
259 -- If OK is false, both Lo and Hi are set to No_Uint.
261 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
262 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
263 -- This function is used to see if an access or division by zero check is
264 -- needed. The check is to be applied to a single variable appearing in the
265 -- source, and N is the node for the reference. If N is not of this form,
266 -- True is returned with no further processing. If N is of the right form,
267 -- then further processing determines if the given Check is needed.
269 -- The particular circuit is to see if we have the case of a check that is
270 -- not needed because it appears in the right operand of a short circuited
271 -- conditional where the left operand guards the check. For example:
273 -- if Var = 0 or else Q / Var > 12 then
277 -- In this example, the division check is not required. At the same time
278 -- we can issue warnings for suspicious use of non-short-circuited forms,
281 -- if Var = 0 or Q / Var > 12 then
287 Check_Type
: Character;
288 Target_Type
: Entity_Id
;
289 Entry_OK
: out Boolean;
293 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
294 -- to see if a check is of the form for optimization, and if so, to see
295 -- if it has already been performed. Expr is the expression to check,
296 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
297 -- Target_Type is the target type for a range check, and Empty for an
298 -- overflow check. If the entry is not of the form for optimization,
299 -- then Entry_OK is set to False, and the remaining out parameters
300 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
301 -- entity and offset from the expression. Check_Num is the number of
302 -- a matching saved entry in Saved_Checks, or zero if no such entry
305 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
306 -- If a discriminal is used in constraining a prival, Return reference
307 -- to the discriminal of the protected body (which renames the parameter
308 -- of the enclosing protected operation). This clumsy transformation is
309 -- needed because privals are created too late and their actual subtypes
310 -- are not available when analysing the bodies of the protected operations.
311 -- This function is called whenever the bound is an entity and the scope
312 -- indicates a protected operation. If the bound is an in-parameter of
313 -- a protected operation that is not a prival, the function returns the
315 -- To be cleaned up???
317 function Guard_Access
320 Expr
: Node_Id
) return Node_Id
;
321 -- In the access type case, guard the test with a test to ensure
322 -- that the access value is non-null, since the checks do not
323 -- not apply to null access values.
325 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
326 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
327 -- Constraint_Error node.
329 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
330 -- Returns True if node N is for an arithmetic operation with signed
331 -- integer operands. This includes unary and binary operators, and also
332 -- if and case expression nodes where the dependent expressions are of
333 -- a signed integer type. These are the kinds of nodes for which special
334 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
336 function Range_Or_Validity_Checks_Suppressed
337 (Expr
: Node_Id
) return Boolean;
338 -- Returns True if either range or validity checks or both are suppressed
339 -- for the type of the given expression, or, if the expression is the name
340 -- of an entity, if these checks are suppressed for the entity.
342 function Selected_Length_Checks
344 Target_Typ
: Entity_Id
;
345 Source_Typ
: Entity_Id
;
346 Warn_Node
: Node_Id
) return Check_Result
;
347 -- Like Apply_Selected_Length_Checks, except it doesn't modify
348 -- anything, just returns a list of nodes as described in the spec of
349 -- this package for the Range_Check function.
350 -- ??? In fact it does construct the test and insert it into the tree,
351 -- and insert actions in various ways (calling Insert_Action directly
352 -- in particular) so we do not call it in GNATprove mode, contrary to
353 -- Selected_Range_Checks.
355 function Selected_Range_Checks
357 Target_Typ
: Entity_Id
;
358 Source_Typ
: Entity_Id
;
359 Warn_Node
: Node_Id
) return Check_Result
;
360 -- Like Apply_Range_Check, except it does not modify anything, just
361 -- returns a list of nodes as described in the spec of this package
362 -- for the Range_Check function.
364 ------------------------------
365 -- Access_Checks_Suppressed --
366 ------------------------------
368 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
370 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
371 return Is_Check_Suppressed
(E
, Access_Check
);
373 return Scope_Suppress
.Suppress
(Access_Check
);
375 end Access_Checks_Suppressed
;
377 -------------------------------------
378 -- Accessibility_Checks_Suppressed --
379 -------------------------------------
381 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
383 if No_Dynamic_Accessibility_Checks_Enabled
(E
) then
386 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
387 return Is_Check_Suppressed
(E
, Accessibility_Check
);
390 return Scope_Suppress
.Suppress
(Accessibility_Check
);
392 end Accessibility_Checks_Suppressed
;
394 -----------------------------
395 -- Activate_Division_Check --
396 -----------------------------
398 procedure Activate_Division_Check
(N
: Node_Id
) is
400 Set_Do_Division_Check
(N
, True);
401 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
402 end Activate_Division_Check
;
404 -----------------------------
405 -- Activate_Overflow_Check --
406 -----------------------------
408 procedure Activate_Overflow_Check
(N
: Node_Id
) is
409 Typ
: constant Entity_Id
:= Etype
(N
);
412 -- Floating-point case. If Etype is not set (this can happen when we
413 -- activate a check on a node that has not yet been analyzed), then
414 -- we assume we do not have a floating-point type (as per our spec).
416 if Present
(Typ
) and then Is_Floating_Point_Type
(Typ
) then
418 -- Ignore call if we have no automatic overflow checks on the target
419 -- and Check_Float_Overflow mode is not set. These are the cases in
420 -- which we expect to generate infinities and NaN's with no check.
422 if not (Machine_Overflows_On_Target
or Check_Float_Overflow
) then
425 -- Ignore for unary operations ("+", "-", abs) since these can never
426 -- result in overflow for floating-point cases.
428 elsif Nkind
(N
) in N_Unary_Op
then
431 -- Otherwise we will set the flag
440 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
441 -- for zero-divide is a divide check, not an overflow check).
443 if Nkind
(N
) in N_Op_Rem | N_Op_Mod | N_Op_Plus
then
448 -- Fall through for cases where we do set the flag
450 Set_Do_Overflow_Check
(N
);
451 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
452 end Activate_Overflow_Check
;
454 --------------------------
455 -- Activate_Range_Check --
456 --------------------------
458 procedure Activate_Range_Check
(N
: Node_Id
) is
460 Set_Do_Range_Check
(N
);
461 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
462 end Activate_Range_Check
;
464 ---------------------------------
465 -- Alignment_Checks_Suppressed --
466 ---------------------------------
468 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
470 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
471 return Is_Check_Suppressed
(E
, Alignment_Check
);
473 return Scope_Suppress
.Suppress
(Alignment_Check
);
475 end Alignment_Checks_Suppressed
;
477 ----------------------------------
478 -- Allocation_Checks_Suppressed --
479 ----------------------------------
481 -- Note: at the current time there are no calls to this function, because
482 -- the relevant check is in the run-time, so it is not a check that the
483 -- compiler can suppress anyway, but we still have to recognize the check
484 -- name Allocation_Check since it is part of the standard.
486 function Allocation_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
488 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
489 return Is_Check_Suppressed
(E
, Allocation_Check
);
491 return Scope_Suppress
.Suppress
(Allocation_Check
);
493 end Allocation_Checks_Suppressed
;
495 -------------------------
496 -- Append_Range_Checks --
497 -------------------------
499 procedure Append_Range_Checks
500 (Checks
: Check_Result
;
502 Suppress_Typ
: Entity_Id
;
503 Static_Sloc
: Source_Ptr
)
505 Checks_On
: constant Boolean :=
506 not Index_Checks_Suppressed
(Suppress_Typ
)
508 not Range_Checks_Suppressed
(Suppress_Typ
);
511 -- For now we just return if Checks_On is false, however this could be
512 -- enhanced to check for an always True value in the condition and to
513 -- generate a compilation warning.
515 if not Checks_On
then
520 exit when No
(Checks
(J
));
522 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
523 and then Present
(Condition
(Checks
(J
)))
525 Append_To
(Stmts
, Checks
(J
));
529 Make_Raise_Constraint_Error
(Static_Sloc
,
530 Reason
=> CE_Range_Check_Failed
));
533 end Append_Range_Checks
;
535 ------------------------
536 -- Apply_Access_Check --
537 ------------------------
539 procedure Apply_Access_Check
(N
: Node_Id
) is
540 P
: constant Node_Id
:= Prefix
(N
);
543 -- We do not need checks if we are not generating code (i.e. the
544 -- expander is not active). This is not just an optimization, there
545 -- are cases (e.g. with pragma Debug) where generating the checks
546 -- can cause real trouble.
548 if not Expander_Active
then
552 -- No check if short circuiting makes check unnecessary
554 if not Check_Needed
(P
, Access_Check
) then
558 -- No check if accessing the Offset_To_Top component of a dispatch
559 -- table. They are safe by construction.
561 if Tagged_Type_Expansion
562 and then Present
(Etype
(P
))
563 and then Is_RTE
(Etype
(P
), RE_Offset_To_Top_Ptr
)
568 -- Otherwise go ahead and install the check
570 Install_Null_Excluding_Check
(P
);
571 end Apply_Access_Check
;
573 --------------------------------
574 -- Apply_Address_Clause_Check --
575 --------------------------------
577 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
578 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
580 AC
: constant Node_Id
:= Address_Clause
(E
);
581 Loc
: constant Source_Ptr
:= Sloc
(AC
);
582 Typ
: constant Entity_Id
:= Etype
(E
);
585 -- Address expression (not necessarily the same as Aexp, for example
586 -- when Aexp is a reference to a constant, in which case Expr gets
587 -- reset to reference the value expression of the constant).
590 -- See if alignment check needed. Note that we never need a check if the
591 -- maximum alignment is one, since the check will always succeed.
593 -- Note: we do not check for checks suppressed here, since that check
594 -- was done in Sem_Ch13 when the address clause was processed. We are
595 -- only called if checks were not suppressed. The reason for this is
596 -- that we have to delay the call to Apply_Alignment_Check till freeze
597 -- time (so that all types etc are elaborated), but we have to check
598 -- the status of check suppressing at the point of the address clause.
601 or else not Check_Address_Alignment
(AC
)
602 or else Maximum_Alignment
= 1
607 -- Obtain expression from address clause
609 Expr
:= Address_Value
(Expression
(AC
));
611 -- See if we know that Expr has an acceptable value at compile time. If
612 -- it hasn't or we don't know, we defer issuing the warning until the
613 -- end of the compilation to take into account back end annotations.
615 if Compile_Time_Known_Value
(Expr
)
616 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
619 AL
: Uint
:= Alignment
(Typ
);
622 -- The object alignment might be more restrictive than the type
625 if Known_Alignment
(E
) then
629 if Expr_Value
(Expr
) mod AL
= 0 then
634 -- If the expression has the form X'Address, then we can find out if the
635 -- object X has an alignment that is compatible with the object E. If it
636 -- hasn't or we don't know, we defer issuing the warning until the end
637 -- of the compilation to take into account back end annotations.
639 elsif Nkind
(Expr
) = N_Attribute_Reference
640 and then Attribute_Name
(Expr
) = Name_Address
642 Has_Compatible_Alignment
(E
, Prefix
(Expr
), False) = Known_Compatible
647 -- Here we do not know if the value is acceptable. Strictly we don't
648 -- have to do anything, since if the alignment is bad, we have an
649 -- erroneous program. However we are allowed to check for erroneous
650 -- conditions and we decide to do this by default if the check is not
653 -- However, don't do the check if elaboration code is unwanted
655 if Restriction_Active
(No_Elaboration_Code
) then
658 -- Generate a check to raise PE if alignment may be inappropriate
661 -- If the original expression is a nonstatic constant, use the name
662 -- of the constant itself rather than duplicating its initialization
663 -- expression, which was extracted above.
665 -- Note: Expr is empty if the address-clause is applied to in-mode
666 -- actuals (allowed by 13.1(22)).
670 (Is_Entity_Name
(Expression
(AC
))
671 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
672 and then Nkind
(Parent
(Entity
(Expression
(AC
)))) =
673 N_Object_Declaration
)
675 Expr
:= New_Copy_Tree
(Expression
(AC
));
677 Remove_Side_Effects
(Expr
);
680 if No
(Actions
(N
)) then
681 Set_Actions
(N
, New_List
);
684 Prepend_To
(Actions
(N
),
685 Make_Raise_Program_Error
(Loc
,
692 (RTE
(RE_Integer_Address
), Expr
),
694 Make_Attribute_Reference
(Loc
,
695 Prefix
=> New_Occurrence_Of
(E
, Loc
),
696 Attribute_Name
=> Name_Alignment
)),
697 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
698 Reason
=> PE_Misaligned_Address_Value
));
700 Warning_Msg
:= No_Error_Msg
;
701 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
703 -- If the above raise action generated a warning message (for example
704 -- from Warn_On_Non_Local_Exception mode with the active restriction
705 -- No_Exception_Propagation).
707 if Warning_Msg
/= No_Error_Msg
then
709 -- If the expression has a known at compile time value, then
710 -- once we know the alignment of the type, we can check if the
711 -- exception will be raised or not, and if not, we don't need
712 -- the warning so we will kill the warning later on.
714 if Compile_Time_Known_Value
(Expr
) then
715 Alignment_Warnings
.Append
717 A
=> Expr_Value
(Expr
),
721 -- Likewise if the expression is of the form X'Address
723 elsif Nkind
(Expr
) = N_Attribute_Reference
724 and then Attribute_Name
(Expr
) = Name_Address
726 Alignment_Warnings
.Append
732 -- Add explanation of the warning generated by the check
736 ("\address value may be incompatible with alignment of "
746 -- If we have some missing run time component in configurable run time
747 -- mode then just skip the check (it is not required in any case).
749 when RE_Not_Available
=>
751 end Apply_Address_Clause_Check
;
753 -------------------------------------
754 -- Apply_Arithmetic_Overflow_Check --
755 -------------------------------------
757 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
759 -- Use old routine in almost all cases (the only case we are treating
760 -- specially is the case of a signed integer arithmetic op with the
761 -- overflow checking mode set to MINIMIZED or ELIMINATED).
763 if Overflow_Check_Mode
= Strict
764 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
766 Apply_Arithmetic_Overflow_Strict
(N
);
768 -- Otherwise use the new routine for the case of a signed integer
769 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
770 -- mode is MINIMIZED or ELIMINATED.
773 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
775 end Apply_Arithmetic_Overflow_Check
;
777 --------------------------------------
778 -- Apply_Arithmetic_Overflow_Strict --
779 --------------------------------------
781 -- This routine is called only if the type is an integer type and an
782 -- arithmetic overflow check may be needed for op (add, subtract, or
783 -- multiply). This check is performed if Backend_Overflow_Checks_On_Target
784 -- is not enabled and Do_Overflow_Check is set. In this case we expand the
785 -- operation into a more complex sequence of tests that ensures that
786 -- overflow is properly caught.
788 -- This is used in CHECKED modes. It is identical to the code for this
789 -- cases before the big overflow earthquake, thus ensuring that in this
790 -- modes we have compatible behavior (and reliability) to what was there
791 -- before. It is also called for types other than signed integers, and if
792 -- the Do_Overflow_Check flag is off.
794 -- Note: we also call this routine if we decide in the MINIMIZED case
795 -- to give up and just generate an overflow check without any fuss.
797 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
798 Loc
: constant Source_Ptr
:= Sloc
(N
);
799 Typ
: constant Entity_Id
:= Etype
(N
);
800 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
803 -- Nothing to do if Do_Overflow_Check not set or overflow checks
806 if not Do_Overflow_Check
(N
) then
810 -- An interesting special case. If the arithmetic operation appears as
811 -- the operand of a type conversion:
815 -- and all the following conditions apply:
817 -- arithmetic operation is for a signed integer type
818 -- target type type1 is a static integer subtype
819 -- range of x and y are both included in the range of type1
820 -- range of x op y is included in the range of type1
821 -- size of type1 is at least twice the result size of op
823 -- then we don't do an overflow check in any case. Instead, we transform
824 -- the operation so that we end up with:
826 -- type1 (type1 (x) op type1 (y))
828 -- This avoids intermediate overflow before the conversion. It is
829 -- explicitly permitted by RM 3.5.4(24):
831 -- For the execution of a predefined operation of a signed integer
832 -- type, the implementation need not raise Constraint_Error if the
833 -- result is outside the base range of the type, so long as the
834 -- correct result is produced.
836 -- It's hard to imagine that any programmer counts on the exception
837 -- being raised in this case, and in any case it's wrong coding to
838 -- have this expectation, given the RM permission. Furthermore, other
839 -- Ada compilers do allow such out of range results.
841 -- Note that we do this transformation even if overflow checking is
842 -- off, since this is precisely about giving the "right" result and
843 -- avoiding the need for an overflow check.
845 -- Note: this circuit is partially redundant with respect to the similar
846 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
847 -- with cases that do not come through here. We still need the following
848 -- processing even with the Exp_Ch4 code in place, since we want to be
849 -- sure not to generate the arithmetic overflow check in these cases
850 -- (Exp_Ch4 would have a hard time removing them once generated).
852 if Is_Signed_Integer_Type
(Typ
)
853 and then Nkind
(Parent
(N
)) = N_Type_Conversion
855 Conversion_Optimization
: declare
856 Target_Type
: constant Entity_Id
:=
857 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
871 if Is_Integer_Type
(Target_Type
)
872 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
874 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
875 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
878 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
880 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
883 and then Tlo
<= Llo
and then Lhi
<= Thi
884 and then Tlo
<= Rlo
and then Rhi
<= Thi
886 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
888 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
889 -- Rewrite the conversion operand so that the original
890 -- node is retained, in order to avoid the warning for
891 -- redundant conversions in Resolve_Type_Conversion.
894 Op
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
897 Make_Type_Conversion
(Loc
,
899 New_Occurrence_Of
(Target_Type
, Loc
),
900 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
902 Make_Type_Conversion
(Loc
,
904 New_Occurrence_Of
(Target_Type
, Loc
),
905 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
910 Set_Etype
(N
, Target_Type
);
912 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
913 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
915 -- Given that the target type is twice the size of the
916 -- source type, overflow is now impossible, so we can
917 -- safely kill the overflow check and return.
919 Set_Do_Overflow_Check
(N
, False);
924 end Conversion_Optimization
;
927 -- Now see if an overflow check is required
930 Dsiz
: constant Uint
:= 2 * Esize
(Rtyp
);
937 -- Skip check if back end does overflow checks, or the overflow flag
938 -- is not set anyway, or we are not doing code expansion, or the
939 -- parent node is a type conversion whose operand is an arithmetic
940 -- operation on signed integers on which the expander can promote
941 -- later the operands to type Integer (see Expand_N_Type_Conversion).
943 if Backend_Overflow_Checks_On_Target
944 or else not Do_Overflow_Check
(N
)
945 or else not Expander_Active
946 or else (Present
(Parent
(N
))
947 and then Nkind
(Parent
(N
)) = N_Type_Conversion
948 and then Integer_Promotion_Possible
(Parent
(N
)))
953 -- Otherwise, generate the full general code for front end overflow
954 -- detection, which works by doing arithmetic in a larger type:
960 -- Typ (Checktyp (x) op Checktyp (y));
962 -- where Typ is the type of the original expression, and Checktyp is
963 -- an integer type of sufficient length to hold the largest possible
966 -- If the size of the check type exceeds the maximum integer size,
967 -- we use a different approach, expanding to:
969 -- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y)))
971 -- where xxx is Add, Multiply or Subtract as appropriate
973 -- Find check type if one exists
975 if Dsiz
<= System_Max_Integer_Size
then
976 Ctyp
:= Integer_Type_For
(Dsiz
, Uns
=> False);
978 -- No check type exists, use runtime call
981 if System_Max_Integer_Size
= 64 then
982 Ctyp
:= RTE
(RE_Integer_64
);
984 Ctyp
:= RTE
(RE_Integer_128
);
987 if Nkind
(N
) = N_Op_Add
then
988 if System_Max_Integer_Size
= 64 then
989 Cent
:= RE_Add_With_Ovflo_Check64
;
991 Cent
:= RE_Add_With_Ovflo_Check128
;
994 elsif Nkind
(N
) = N_Op_Subtract
then
995 if System_Max_Integer_Size
= 64 then
996 Cent
:= RE_Subtract_With_Ovflo_Check64
;
998 Cent
:= RE_Subtract_With_Ovflo_Check128
;
1001 else pragma Assert
(Nkind
(N
) = N_Op_Multiply
);
1002 if System_Max_Integer_Size
= 64 then
1003 Cent
:= RE_Multiply_With_Ovflo_Check64
;
1005 Cent
:= RE_Multiply_With_Ovflo_Check128
;
1011 Make_Function_Call
(Loc
,
1012 Name
=> New_Occurrence_Of
(RTE
(Cent
), Loc
),
1013 Parameter_Associations
=> New_List
(
1014 OK_Convert_To
(Ctyp
, Left_Opnd
(N
)),
1015 OK_Convert_To
(Ctyp
, Right_Opnd
(N
))))));
1017 Analyze_And_Resolve
(N
, Typ
);
1021 -- If we fall through, we have the case where we do the arithmetic
1022 -- in the next higher type and get the check by conversion. In these
1023 -- cases Ctyp is set to the type to be used as the check type.
1025 Opnod
:= Relocate_Node
(N
);
1027 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1030 Set_Etype
(Opnd
, Ctyp
);
1031 Set_Analyzed
(Opnd
, True);
1032 Set_Left_Opnd
(Opnod
, Opnd
);
1034 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1037 Set_Etype
(Opnd
, Ctyp
);
1038 Set_Analyzed
(Opnd
, True);
1039 Set_Right_Opnd
(Opnod
, Opnd
);
1041 -- The type of the operation changes to the base type of the check
1042 -- type, and we reset the overflow check indication, since clearly no
1043 -- overflow is possible now that we are using a double length type.
1044 -- We also set the Analyzed flag to avoid a recursive attempt to
1047 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1048 Set_Do_Overflow_Check
(Opnod
, False);
1049 Set_Analyzed
(Opnod
, True);
1051 -- Now build the outer conversion
1053 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1055 Set_Etype
(Opnd
, Typ
);
1057 -- In the discrete type case, we directly generate the range check
1058 -- for the outer operand. This range check will implement the
1059 -- required overflow check.
1061 if Is_Discrete_Type
(Typ
) then
1063 Generate_Range_Check
1064 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1066 -- For other types, we enable overflow checking on the conversion,
1067 -- after setting the node as analyzed to prevent recursive attempts
1068 -- to expand the conversion node.
1071 Set_Analyzed
(Opnd
, True);
1072 Enable_Overflow_Check
(Opnd
);
1077 when RE_Not_Available
=>
1080 end Apply_Arithmetic_Overflow_Strict
;
1082 ----------------------------------------------------
1083 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1084 ----------------------------------------------------
1086 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1087 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1089 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1090 P
: constant Node_Id
:= Parent
(Op
);
1092 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1093 -- Operands and results are of this type when we convert
1095 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1096 -- Original result type
1098 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1099 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1102 -- Ranges of values for result
1105 -- Nothing to do if our parent is one of the following:
1107 -- Another signed integer arithmetic op
1108 -- A membership operation
1109 -- A comparison operation
1111 -- In all these cases, we will process at the higher level (and then
1112 -- this node will be processed during the downwards recursion that
1113 -- is part of the processing in Minimize_Eliminate_Overflows).
1115 if Is_Signed_Integer_Arithmetic_Op
(P
)
1116 or else Nkind
(P
) in N_Membership_Test
1117 or else Nkind
(P
) in N_Op_Compare
1119 -- This is also true for an alternative in a case expression
1121 or else Nkind
(P
) = N_Case_Expression_Alternative
1123 -- This is also true for a range operand in a membership test
1125 or else (Nkind
(P
) = N_Range
1126 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1128 -- If_Expressions and Case_Expressions are treated as arithmetic
1129 -- ops, but if they appear in an assignment or similar contexts
1130 -- there is no overflow check that starts from that parent node,
1131 -- so apply check now.
1132 -- Similarly, if these expressions are nested, we should go on.
1134 if Nkind
(P
) in N_If_Expression | N_Case_Expression
1135 and then not Is_Signed_Integer_Arithmetic_Op
(Parent
(P
))
1138 elsif Nkind
(P
) in N_If_Expression | N_Case_Expression
1139 and then Nkind
(Op
) in N_If_Expression | N_Case_Expression
1147 -- Otherwise, we have a top level arithmetic operation node, and this
1148 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1149 -- modes. This is the case where we tell the machinery not to move into
1150 -- Bignum mode at this top level (of course the top level operation
1151 -- will still be in Bignum mode if either of its operands are of type
1154 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1156 -- That call may but does not necessarily change the result type of Op.
1157 -- It is the job of this routine to undo such changes, so that at the
1158 -- top level, we have the proper type. This "undoing" is a point at
1159 -- which a final overflow check may be applied.
1161 -- If the result type was not fiddled we are all set. We go to base
1162 -- types here because things may have been rewritten to generate the
1163 -- base type of the operand types.
1165 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1170 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1172 -- We need a sequence that looks like:
1174 -- Rnn : Result_Type;
1177 -- M : Mark_Id := SS_Mark;
1179 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1183 -- This block is inserted (using Insert_Actions), and then the node
1184 -- is replaced with a reference to Rnn.
1186 -- If our parent is a conversion node then there is no point in
1187 -- generating a conversion to Result_Type. Instead, we let the parent
1188 -- handle this. Note that this special case is not just about
1189 -- optimization. Consider
1193 -- X := Long_Long_Integer'Base (A * (B ** C));
1195 -- Now the product may fit in Long_Long_Integer but not in Integer.
1196 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1197 -- overflow exception for this intermediate value.
1200 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1201 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1207 RHS
:= Convert_From_Bignum
(Op
);
1209 if Nkind
(P
) /= N_Type_Conversion
then
1210 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1211 Rtype
:= Result_Type
;
1213 -- Interesting question, do we need a check on that conversion
1214 -- operation. Answer, not if we know the result is in range.
1215 -- At the moment we are not taking advantage of this. To be
1216 -- looked at later ???
1223 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1224 Make_Assignment_Statement
(Loc
,
1225 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1226 Expression
=> RHS
));
1228 Insert_Actions
(Op
, New_List
(
1229 Make_Object_Declaration
(Loc
,
1230 Defining_Identifier
=> Rnn
,
1231 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1234 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1235 Analyze_And_Resolve
(Op
);
1238 -- Here we know the result is Long_Long_Integer'Base, or that it has
1239 -- been rewritten because the parent operation is a conversion. See
1240 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1244 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1246 -- All we need to do here is to convert the result to the proper
1247 -- result type. As explained above for the Bignum case, we can
1248 -- omit this if our parent is a type conversion.
1250 if Nkind
(P
) /= N_Type_Conversion
then
1251 Convert_To_And_Rewrite
(Result_Type
, Op
);
1254 Analyze_And_Resolve
(Op
);
1256 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1258 ----------------------------
1259 -- Apply_Constraint_Check --
1260 ----------------------------
1262 procedure Apply_Constraint_Check
1265 No_Sliding
: Boolean := False)
1267 Desig_Typ
: Entity_Id
;
1270 -- No checks inside a generic (check the instantiations)
1272 if Inside_A_Generic
then
1276 -- Apply required constraint checks
1278 if Is_Scalar_Type
(Typ
) then
1279 Apply_Scalar_Range_Check
(N
, Typ
);
1281 elsif Is_Array_Type
(Typ
) then
1283 -- A useful optimization: an aggregate with only an others clause
1284 -- always has the right bounds.
1286 if Nkind
(N
) = N_Aggregate
1287 and then No
(Expressions
(N
))
1288 and then Nkind
(First
(Component_Associations
(N
))) =
1289 N_Component_Association
1291 (First
(Choices
(First
(Component_Associations
(N
)))))
1297 if Is_Constrained
(Typ
) then
1298 Apply_Length_Check
(N
, Typ
);
1301 Apply_Range_Check
(N
, Typ
);
1304 Apply_Range_Check
(N
, Typ
);
1307 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1308 and then Has_Discriminants
(Base_Type
(Typ
))
1309 and then Is_Constrained
(Typ
)
1311 Apply_Discriminant_Check
(N
, Typ
);
1313 elsif Is_Access_Type
(Typ
) then
1315 Desig_Typ
:= Designated_Type
(Typ
);
1317 -- No checks necessary if expression statically null
1319 if Known_Null
(N
) then
1320 if Can_Never_Be_Null
(Typ
) then
1321 Install_Null_Excluding_Check
(N
);
1324 -- No sliding possible on access to arrays
1326 elsif Is_Array_Type
(Desig_Typ
) then
1327 if Is_Constrained
(Desig_Typ
) then
1328 Apply_Length_Check
(N
, Typ
);
1331 Apply_Range_Check
(N
, Typ
);
1333 -- Do not install a discriminant check for a constrained subtype
1334 -- created for an unconstrained nominal type because the subtype
1335 -- has the correct constraints by construction.
1337 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1338 and then Is_Constrained
(Desig_Typ
)
1339 and then not Is_Constr_Subt_For_U_Nominal
(Desig_Typ
)
1341 Apply_Discriminant_Check
(N
, Typ
);
1344 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1345 -- this check if the constraint node is illegal, as shown by having
1346 -- an error posted. This additional guard prevents cascaded errors
1347 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1349 if Can_Never_Be_Null
(Typ
)
1350 and then not Can_Never_Be_Null
(Etype
(N
))
1351 and then not Error_Posted
(N
)
1353 Install_Null_Excluding_Check
(N
);
1356 end Apply_Constraint_Check
;
1358 ------------------------------
1359 -- Apply_Discriminant_Check --
1360 ------------------------------
1362 procedure Apply_Discriminant_Check
1365 Lhs
: Node_Id
:= Empty
)
1367 Loc
: constant Source_Ptr
:= Sloc
(N
);
1368 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1369 S_Typ
: Entity_Id
:= Etype
(N
);
1373 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1374 -- A heap object with an indefinite subtype is constrained by its
1375 -- initial value, and assigning to it requires a constraint_check.
1376 -- The target may be an explicit dereference, or a renaming of one.
1378 function Is_Aliased_Unconstrained_Component
return Boolean;
1379 -- It is possible for an aliased component to have a nominal
1380 -- unconstrained subtype (through instantiation). If this is a
1381 -- discriminated component assigned in the expansion of an aggregate
1382 -- in an initialization, the check must be suppressed. This unusual
1383 -- situation requires a predicate of its own.
1385 ----------------------------------
1386 -- Denotes_Explicit_Dereference --
1387 ----------------------------------
1389 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1391 if Is_Entity_Name
(Obj
) then
1392 return Present
(Renamed_Object
(Entity
(Obj
)))
1394 Denotes_Explicit_Dereference
(Renamed_Object
(Entity
(Obj
)));
1396 -- This routine uses the rules of the language so we need to exclude
1397 -- rewritten constructs that introduce artificial dereferences.
1399 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
1400 return not Is_Captured_Function_Call
(Obj
)
1402 (Nkind
(Parent
(Obj
)) = N_Object_Renaming_Declaration
1403 and then Is_Return_Object
(Defining_Entity
(Parent
(Obj
))));
1408 end Denotes_Explicit_Dereference
;
1410 ----------------------------------------
1411 -- Is_Aliased_Unconstrained_Component --
1412 ----------------------------------------
1414 function Is_Aliased_Unconstrained_Component
return Boolean is
1419 if Nkind
(Lhs
) /= N_Selected_Component
then
1422 Comp
:= Entity
(Selector_Name
(Lhs
));
1423 Pref
:= Prefix
(Lhs
);
1426 if Ekind
(Comp
) /= E_Component
1427 or else not Is_Aliased
(Comp
)
1432 return not Comes_From_Source
(Pref
)
1433 and then In_Instance
1434 and then not Is_Constrained
(Etype
(Comp
));
1435 end Is_Aliased_Unconstrained_Component
;
1437 -- Start of processing for Apply_Discriminant_Check
1441 T_Typ
:= Designated_Type
(Typ
);
1446 -- If the expression is a function call that returns a limited object
1447 -- it cannot be copied. It is not clear how to perform the proper
1448 -- discriminant check in this case because the discriminant value must
1449 -- be retrieved from the constructed object itself.
1451 if Nkind
(N
) = N_Function_Call
1452 and then Is_Limited_Type
(Typ
)
1453 and then Is_Entity_Name
(Name
(N
))
1454 and then Returns_By_Ref
(Entity
(Name
(N
)))
1459 -- Only apply checks when generating code and discriminant checks are
1460 -- not suppressed. In GNATprove mode, we do not apply the checks, but we
1461 -- still analyze the expression to possibly issue errors on SPARK code
1462 -- when a run-time error can be detected at compile time.
1464 if not GNATprove_Mode
then
1465 if not Expander_Active
1466 or else Discriminant_Checks_Suppressed
(T_Typ
)
1472 -- No discriminant checks necessary for an access when expression is
1473 -- statically Null. This is not only an optimization, it is fundamental
1474 -- because otherwise discriminant checks may be generated in init procs
1475 -- for types containing an access to a not-yet-frozen record, causing a
1476 -- deadly forward reference.
1478 -- Also, if the expression is of an access type whose designated type is
1479 -- incomplete, then the access value must be null and we suppress the
1482 if Known_Null
(N
) then
1485 elsif Is_Access_Type
(S_Typ
) then
1486 S_Typ
:= Designated_Type
(S_Typ
);
1488 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1493 -- If an assignment target is present, then we need to generate the
1494 -- actual subtype if the target is a parameter or aliased object with
1495 -- an unconstrained nominal subtype.
1497 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1498 -- subtype to the parameter and dereference cases, since other aliased
1499 -- objects are unconstrained (unless the nominal subtype is explicitly
1503 and then (Present
(Param_Entity
(Lhs
))
1504 or else (Ada_Version
< Ada_2005
1505 and then not Is_Constrained
(T_Typ
)
1506 and then Is_Aliased_View
(Lhs
)
1507 and then not Is_Aliased_Unconstrained_Component
)
1508 or else (Ada_Version
>= Ada_2005
1509 and then not Is_Constrained
(T_Typ
)
1510 and then Denotes_Explicit_Dereference
(Lhs
)))
1512 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1515 -- Nothing to do if the type is unconstrained (this is the case where
1516 -- the actual subtype in the RM sense of N is unconstrained and no check
1519 if not Is_Constrained
(T_Typ
) then
1522 -- Ada 2005: nothing to do if the type is one for which there is a
1523 -- partial view that is constrained.
1525 elsif Ada_Version
>= Ada_2005
1526 and then Object_Type_Has_Constrained_Partial_View
1527 (Typ
=> Base_Type
(T_Typ
),
1528 Scop
=> Current_Scope
)
1533 -- Nothing to do if the type is an Unchecked_Union
1535 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1539 -- Suppress checks if the subtypes are the same. The check must be
1540 -- preserved in an assignment to a formal, because the constraint is
1541 -- given by the actual.
1543 if Nkind
(Original_Node
(N
)) /= N_Allocator
1545 or else not Is_Entity_Name
(Lhs
)
1546 or else No
(Param_Entity
(Lhs
)))
1549 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1550 and then not Is_Aliased_View
(Lhs
)
1555 -- We can also eliminate checks on allocators with a subtype mark that
1556 -- coincides with the context type. The context type may be a subtype
1557 -- without a constraint (common case, a generic actual).
1559 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1560 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1563 Alloc_Typ
: constant Entity_Id
:=
1564 Entity
(Expression
(Original_Node
(N
)));
1567 if Alloc_Typ
= T_Typ
1568 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1569 and then Is_Entity_Name
(
1570 Subtype_Indication
(Parent
(T_Typ
)))
1571 and then Alloc_Typ
= Base_Type
(T_Typ
))
1579 -- See if we have a case where the types are both constrained, and all
1580 -- the constraints are constants. In this case, we can do the check
1581 -- successfully at compile time.
1583 -- We skip this check for the case where the node is rewritten as
1584 -- an allocator, because it already carries the context subtype,
1585 -- and extracting the discriminants from the aggregate is messy.
1587 if Is_Constrained
(S_Typ
)
1588 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1598 -- S_Typ may not have discriminants in the case where it is a
1599 -- private type completed by a default discriminated type. In that
1600 -- case, we need to get the constraints from the underlying type.
1601 -- If the underlying type is unconstrained (i.e. has no default
1602 -- discriminants) no check is needed.
1604 if Has_Discriminants
(S_Typ
) then
1605 Discr
:= First_Discriminant
(S_Typ
);
1606 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1609 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1612 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1618 -- A further optimization: if T_Typ is derived from S_Typ
1619 -- without imposing a constraint, no check is needed.
1621 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1622 N_Full_Type_Declaration
1625 Type_Def
: constant Node_Id
:=
1626 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1628 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1629 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1630 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1638 -- Constraint may appear in full view of type
1640 if Ekind
(T_Typ
) = E_Private_Subtype
1641 and then Present
(Full_View
(T_Typ
))
1644 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1647 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1650 while Present
(Discr
) loop
1651 ItemS
:= Node
(DconS
);
1652 ItemT
:= Node
(DconT
);
1654 -- For a discriminated component type constrained by the
1655 -- current instance of an enclosing type, there is no
1656 -- applicable discriminant check.
1658 if Nkind
(ItemT
) = N_Attribute_Reference
1659 and then Is_Access_Type
(Etype
(ItemT
))
1660 and then Is_Entity_Name
(Prefix
(ItemT
))
1661 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1666 -- If the expressions for the discriminants are identical
1667 -- and it is side-effect free (for now just an entity),
1668 -- this may be a shared constraint, e.g. from a subtype
1669 -- without a constraint introduced as a generic actual.
1670 -- Examine other discriminants if any.
1673 and then Is_Entity_Name
(ItemS
)
1677 elsif not Is_OK_Static_Expression
(ItemS
)
1678 or else not Is_OK_Static_Expression
(ItemT
)
1682 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1683 if Do_Access
then -- needs run-time check.
1686 Apply_Compile_Time_Constraint_Error
1687 (N
, "incorrect value for discriminant&??",
1688 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1695 Next_Discriminant
(Discr
);
1704 -- In GNATprove mode, we do not apply the checks
1706 if GNATprove_Mode
then
1710 -- Here we need a discriminant check. First build the expression
1711 -- for the comparisons of the discriminants:
1713 -- (n.disc1 /= typ.disc1) or else
1714 -- (n.disc2 /= typ.disc2) or else
1716 -- (n.discn /= typ.discn)
1718 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1720 -- If Lhs is set and is a parameter, then the condition is guarded by:
1721 -- lhs'constrained and then (condition built above)
1723 if Present
(Param_Entity
(Lhs
)) then
1727 Make_Attribute_Reference
(Loc
,
1728 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1729 Attribute_Name
=> Name_Constrained
),
1730 Right_Opnd
=> Cond
);
1734 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1738 Make_Raise_Constraint_Error
(Loc
,
1740 Reason
=> CE_Discriminant_Check_Failed
));
1741 end Apply_Discriminant_Check
;
1743 -------------------------
1744 -- Apply_Divide_Checks --
1745 -------------------------
1747 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1748 Loc
: constant Source_Ptr
:= Sloc
(N
);
1749 Typ
: constant Entity_Id
:= Etype
(N
);
1750 Left
: constant Node_Id
:= Left_Opnd
(N
);
1751 Right
: constant Node_Id
:= Right_Opnd
(N
);
1753 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1754 -- Current overflow checking mode
1764 pragma Warnings
(Off
, Lhi
);
1765 -- Don't actually use this value
1768 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1769 -- operating on signed integer types, then the only thing this routine
1770 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1771 -- procedure will (possibly later on during recursive downward calls),
1772 -- ensure that any needed overflow/division checks are properly applied.
1774 if Mode
in Minimized_Or_Eliminated
1775 and then Is_Signed_Integer_Type
(Typ
)
1777 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1781 -- Proceed here in SUPPRESSED or CHECKED modes
1784 and then not Backend_Divide_Checks_On_Target
1785 and then Check_Needed
(Right
, Division_Check
)
1787 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1789 -- Deal with division check
1791 if Do_Division_Check
(N
)
1792 and then not Division_Checks_Suppressed
(Typ
)
1794 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1797 -- Deal with overflow check
1799 if Do_Overflow_Check
(N
)
1800 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1802 Set_Do_Overflow_Check
(N
, False);
1804 -- Test for extremely annoying case of xxx'First divided by -1
1805 -- for division of signed integer types (only overflow case).
1807 if Nkind
(N
) = N_Op_Divide
1808 and then Is_Signed_Integer_Type
(Typ
)
1810 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1811 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1813 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1815 ((not LOK
) or else (Llo
= LLB
))
1817 -- Ensure that expressions are not evaluated twice (once
1818 -- for their runtime checks and once for their regular
1821 Force_Evaluation
(Left
, Mode
=> Strict
);
1822 Force_Evaluation
(Right
, Mode
=> Strict
);
1825 Make_Raise_Constraint_Error
(Loc
,
1831 Duplicate_Subexpr_Move_Checks
(Left
),
1832 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1836 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1837 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1839 Reason
=> CE_Overflow_Check_Failed
));
1844 end Apply_Divide_Checks
;
1846 --------------------------
1847 -- Apply_Division_Check --
1848 --------------------------
1850 procedure Apply_Division_Check
1856 pragma Assert
(Do_Division_Check
(N
));
1858 Loc
: constant Source_Ptr
:= Sloc
(N
);
1859 Right
: constant Node_Id
:= Right_Opnd
(N
);
1864 and then not Backend_Divide_Checks_On_Target
1865 and then Check_Needed
(Right
, Division_Check
)
1867 -- See if division by zero possible, and if so generate test. This
1868 -- part of the test is not controlled by the -gnato switch, since it
1869 -- is a Division_Check and not an Overflow_Check.
1871 and then Do_Division_Check
(N
)
1873 Set_Do_Division_Check
(N
, False);
1875 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1876 if Is_Floating_Point_Type
(Etype
(N
)) then
1877 Opnd
:= Make_Real_Literal
(Loc
, Ureal_0
);
1879 Opnd
:= Make_Integer_Literal
(Loc
, 0);
1883 Make_Raise_Constraint_Error
(Loc
,
1886 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1887 Right_Opnd
=> Opnd
),
1888 Reason
=> CE_Divide_By_Zero
));
1891 end Apply_Division_Check
;
1893 ----------------------------------
1894 -- Apply_Float_Conversion_Check --
1895 ----------------------------------
1897 -- Let F and I be the source and target types of the conversion. The RM
1898 -- specifies that a floating-point value X is rounded to the nearest
1899 -- integer, with halfway cases being rounded away from zero. The rounded
1900 -- value of X is checked against I'Range.
1902 -- The catch in the above paragraph is that there is no good way to know
1903 -- whether the round-to-integer operation resulted in overflow. A remedy is
1904 -- to perform a range check in the floating-point domain instead, however:
1906 -- (1) The bounds may not be known at compile time
1907 -- (2) The check must take into account rounding or truncation.
1908 -- (3) The range of type I may not be exactly representable in F.
1909 -- (4) For the rounding case, the end-points I'First - 0.5 and
1910 -- I'Last + 0.5 may or may not be in range, depending on the
1911 -- sign of I'First and I'Last.
1912 -- (5) X may be a NaN, which will fail any comparison
1914 -- The following steps correctly convert X with rounding:
1916 -- (1) If either I'First or I'Last is not known at compile time, use
1917 -- I'Base instead of I in the next three steps and perform a
1918 -- regular range check against I'Range after conversion.
1919 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1920 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1921 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1922 -- In other words, take one of the closest floating-point numbers
1923 -- (which is an integer value) to I'First, and see if it is in
1925 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1926 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1927 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1928 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1929 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1931 -- For the truncating case, replace steps (2) and (3) as follows:
1932 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1933 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1935 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1936 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1939 procedure Apply_Float_Conversion_Check
1941 Target_Typ
: Entity_Id
)
1943 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1944 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1945 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1946 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Expr
));
1947 Target_Base
: constant Entity_Id
:=
1948 Implementation_Base_Type
(Target_Typ
);
1950 Par
: constant Node_Id
:= Parent
(Expr
);
1951 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1952 -- Parent of check node, must be a type conversion
1954 Truncate
: constant Boolean := Float_Truncate
(Par
);
1955 Max_Bound
: constant Uint
:=
1957 (Machine_Radix_Value
(Expr_Type
),
1958 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1960 -- Largest bound, so bound plus or minus half is a machine number of F
1962 Ifirst
, Ilast
: Uint
;
1963 -- Bounds of integer type
1966 -- Bounds to check in floating-point domain
1968 Lo_OK
, Hi_OK
: Boolean;
1969 -- True iff Lo resp. Hi belongs to I'Range
1971 Lo_Chk
, Hi_Chk
: Node_Id
;
1972 -- Expressions that are False iff check fails
1974 Reason
: RT_Exception_Code
;
1977 -- We do not need checks if we are not generating code (i.e. the full
1978 -- expander is not active). In SPARK mode, we specifically don't want
1979 -- the frontend to expand these checks, which are dealt with directly
1980 -- in the formal verification backend.
1982 if not Expander_Active
then
1986 -- Here we will generate an explicit range check, so we don't want to
1987 -- set the Do_Range check flag, since the range check is taken care of
1988 -- by the code we will generate.
1990 Set_Do_Range_Check
(Expr
, False);
1992 if not Compile_Time_Known_Value
(LB
)
1993 or not Compile_Time_Known_Value
(HB
)
1996 -- First check that the value falls in the range of the base type,
1997 -- to prevent overflow during conversion and then perform a
1998 -- regular range check against the (dynamic) bounds.
2000 pragma Assert
(Target_Base
/= Target_Typ
);
2002 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
2005 Apply_Float_Conversion_Check
(Expr
, Target_Base
);
2006 Set_Etype
(Temp
, Target_Base
);
2008 -- Note: Previously the declaration was inserted above the parent
2009 -- of the conversion, apparently as a small optimization for the
2010 -- subequent traversal in Insert_Actions. Unfortunately a similar
2011 -- optimization takes place in Insert_Actions, assuming that the
2012 -- insertion point must be above the expression that creates
2013 -- actions. This is not correct in the presence of conditional
2014 -- expressions, where the insertion must be in the list of actions
2015 -- attached to the current alternative.
2018 Make_Object_Declaration
(Loc
,
2019 Defining_Identifier
=> Temp
,
2020 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
2021 Expression
=> New_Copy_Tree
(Par
)),
2022 Suppress
=> All_Checks
);
2025 Make_Raise_Constraint_Error
(Loc
,
2028 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
2029 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
2030 Reason
=> CE_Range_Check_Failed
));
2031 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
2037 -- Get the (static) bounds of the target type
2039 Ifirst
:= Expr_Value
(LB
);
2040 Ilast
:= Expr_Value
(HB
);
2042 -- A simple optimization: if the expression is a universal literal,
2043 -- we can do the comparison with the bounds and the conversion to
2044 -- an integer type statically. The range checks are unchanged.
2046 if Nkind
(Expr
) = N_Real_Literal
2047 and then Etype
(Expr
) = Universal_Real
2048 and then Is_Integer_Type
(Target_Typ
)
2051 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Expr
));
2054 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
2056 -- Conversion is safe
2058 Rewrite
(Parent
(Expr
),
2059 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
2060 Analyze_And_Resolve
(Parent
(Expr
), Target_Typ
);
2066 -- Check against lower bound
2068 if Truncate
and then Ifirst
> 0 then
2069 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2073 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2076 elsif abs (Ifirst
) < Max_Bound
then
2077 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2078 Lo_OK
:= (Ifirst
> 0);
2081 Lo
:= Machine_Number
(Expr_Type
, UR_From_Uint
(Ifirst
), Expr
);
2082 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2085 -- Saturate the lower bound to that of the expression's type, because
2086 -- we do not want to create an out-of-range value but we still need to
2087 -- do a comparison to catch NaNs.
2089 if Lo
< Expr_Value_R
(Type_Low_Bound
(Expr_Type
)) then
2090 Lo
:= Expr_Value_R
(Type_Low_Bound
(Expr_Type
));
2096 -- Lo_Chk := (X >= Lo)
2098 Lo_Chk
:= Make_Op_Ge
(Loc
,
2099 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
2100 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2103 -- Lo_Chk := (X > Lo)
2105 Lo_Chk
:= Make_Op_Gt
(Loc
,
2106 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
2107 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2110 -- Check against higher bound
2112 if Truncate
and then Ilast
< 0 then
2113 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2117 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2120 elsif abs (Ilast
) < Max_Bound
then
2121 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2122 Hi_OK
:= (Ilast
< 0);
2124 Hi
:= Machine_Number
(Expr_Type
, UR_From_Uint
(Ilast
), Expr
);
2125 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2128 -- Saturate the higher bound to that of the expression's type, because
2129 -- we do not want to create an out-of-range value but we still need to
2130 -- do a comparison to catch NaNs.
2132 if Hi
> Expr_Value_R
(Type_High_Bound
(Expr_Type
)) then
2133 Hi
:= Expr_Value_R
(Type_High_Bound
(Expr_Type
));
2139 -- Hi_Chk := (X <= Hi)
2141 Hi_Chk
:= Make_Op_Le
(Loc
,
2142 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
2143 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2146 -- Hi_Chk := (X < Hi)
2148 Hi_Chk
:= Make_Op_Lt
(Loc
,
2149 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
2150 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2153 -- If the bounds of the target type are the same as those of the base
2154 -- type, the check is an overflow check as a range check is not
2155 -- performed in these cases.
2157 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2158 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2160 Reason
:= CE_Overflow_Check_Failed
;
2162 Reason
:= CE_Range_Check_Failed
;
2165 -- Raise CE if either conditions does not hold
2167 Insert_Action
(Expr
,
2168 Make_Raise_Constraint_Error
(Loc
,
2169 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2171 end Apply_Float_Conversion_Check
;
2173 ------------------------
2174 -- Apply_Length_Check --
2175 ------------------------
2177 procedure Apply_Length_Check
2179 Target_Typ
: Entity_Id
;
2180 Source_Typ
: Entity_Id
:= Empty
)
2183 Apply_Selected_Length_Checks
2184 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2185 end Apply_Length_Check
;
2187 --------------------------------------
2188 -- Apply_Length_Check_On_Assignment --
2189 --------------------------------------
2191 procedure Apply_Length_Check_On_Assignment
2193 Target_Typ
: Entity_Id
;
2195 Source_Typ
: Entity_Id
:= Empty
)
2197 Assign
: constant Node_Id
:= Parent
(Target
);
2200 -- Do not apply length checks if parent is still an assignment statement
2201 -- with Suppress_Assignment_Checks flag set.
2203 if Nkind
(Assign
) = N_Assignment_Statement
2204 and then Suppress_Assignment_Checks
(Assign
)
2209 -- No check is needed for the initialization of an object whose
2210 -- nominal subtype is unconstrained.
2212 if Is_Constr_Subt_For_U_Nominal
(Target_Typ
)
2213 and then Nkind
(Parent
(Assign
)) = N_Freeze_Entity
2214 and then Is_Entity_Name
(Target
)
2215 and then Entity
(Target
) = Entity
(Parent
(Assign
))
2220 Apply_Selected_Length_Checks
2221 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2222 end Apply_Length_Check_On_Assignment
;
2224 -------------------------------------
2225 -- Apply_Parameter_Aliasing_Checks --
2226 -------------------------------------
2228 procedure Apply_Parameter_Aliasing_Checks
2232 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2234 function Parameter_Passing_Mechanism_Specified
2237 -- Returns True if parameter-passing mechanism is specified for type Typ
2239 function May_Cause_Aliasing
2240 (Formal_1
: Entity_Id
;
2241 Formal_2
: Entity_Id
) return Boolean;
2242 -- Determine whether two formal parameters can alias each other
2243 -- depending on their modes.
2245 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2246 -- The expander may replace an actual with a temporary for the sake of
2247 -- side effect removal. The temporary may hide a potential aliasing as
2248 -- it does not share the address of the actual. This routine attempts
2249 -- to retrieve the original actual.
2251 procedure Overlap_Check
2252 (Actual_1
: Node_Id
;
2254 Formal_1
: Entity_Id
;
2255 Formal_2
: Entity_Id
;
2256 Check
: in out Node_Id
);
2257 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2258 -- If detailed exception messages are enabled, the check is augmented to
2259 -- provide information about the names of the corresponding formals. See
2260 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2261 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2262 -- Check contains all and-ed simple tests generated so far or remains
2263 -- unchanged in the case of detailed exception messaged.
2265 -------------------------------------------
2266 -- Parameter_Passing_Mechanism_Specified --
2267 -------------------------------------------
2269 function Parameter_Passing_Mechanism_Specified
2274 return Is_Elementary_Type
(Typ
)
2275 or else Is_By_Reference_Type
(Typ
);
2276 end Parameter_Passing_Mechanism_Specified
;
2278 ------------------------
2279 -- May_Cause_Aliasing --
2280 ------------------------
2282 function May_Cause_Aliasing
2283 (Formal_1
: Entity_Id
;
2284 Formal_2
: Entity_Id
) return Boolean
2287 -- The following combination cannot lead to aliasing
2289 -- Formal 1 Formal 2
2292 if Ekind
(Formal_1
) = E_In_Parameter
2294 Ekind
(Formal_2
) = E_In_Parameter
2298 -- The following combinations may lead to aliasing
2300 -- Formal 1 Formal 2
2310 end May_Cause_Aliasing
;
2312 ---------------------
2313 -- Original_Actual --
2314 ---------------------
2316 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2318 if Nkind
(N
) = N_Type_Conversion
then
2319 return Expression
(N
);
2321 -- The expander created a temporary to capture the result of a type
2322 -- conversion where the expression is the real actual.
2324 elsif Nkind
(N
) = N_Identifier
2325 and then Present
(Original_Node
(N
))
2326 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2328 return Expression
(Original_Node
(N
));
2332 end Original_Actual
;
2338 procedure Overlap_Check
2339 (Actual_1
: Node_Id
;
2341 Formal_1
: Entity_Id
;
2342 Formal_2
: Entity_Id
;
2343 Check
: in out Node_Id
)
2346 Formal_Name
: Bounded_String
;
2350 -- Actual_1'Overlaps_Storage (Actual_2)
2353 Make_Attribute_Reference
(Loc
,
2354 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2355 Attribute_Name
=> Name_Overlaps_Storage
,
2357 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2359 -- Generate the following check when detailed exception messages are
2362 -- if Actual_1'Overlaps_Storage (Actual_2) then
2363 -- raise Program_Error with <detailed message>;
2366 if Exception_Extra_Info
then
2369 -- Do not generate location information for internal calls
2371 if Comes_From_Source
(Call
) then
2372 Store_String_Chars
(Build_Location_String
(Loc
));
2373 Store_String_Char
(' ');
2376 Store_String_Chars
("aliased parameters, actuals for """);
2378 Append
(Formal_Name
, Chars
(Formal_1
));
2379 Adjust_Name_Case
(Formal_Name
, Sloc
(Formal_1
));
2380 Store_String_Chars
(To_String
(Formal_Name
));
2382 Store_String_Chars
(""" and """);
2384 Formal_Name
.Length
:= 0;
2386 Append
(Formal_Name
, Chars
(Formal_2
));
2387 Adjust_Name_Case
(Formal_Name
, Sloc
(Formal_2
));
2388 Store_String_Chars
(To_String
(Formal_Name
));
2390 Store_String_Chars
(""" overlap");
2392 Insert_Action
(Call
,
2393 Make_If_Statement
(Loc
,
2395 Then_Statements
=> New_List
(
2396 Make_Raise_Statement
(Loc
,
2398 New_Occurrence_Of
(Standard_Program_Error
, Loc
),
2399 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2401 -- Create a sequence of overlapping checks by and-ing them all
2411 Right_Opnd
=> Cond
);
2421 Formal_1
: Entity_Id
;
2422 Formal_2
: Entity_Id
;
2423 Orig_Act_1
: Node_Id
;
2424 Orig_Act_2
: Node_Id
;
2426 -- Start of processing for Apply_Parameter_Aliasing_Checks
2431 Actual_1
:= First_Actual
(Call
);
2432 Formal_1
:= First_Formal
(Subp
);
2433 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2434 Orig_Act_1
:= Original_Actual
(Actual_1
);
2436 if Is_Name_Reference
(Orig_Act_1
) then
2437 Actual_2
:= Next_Actual
(Actual_1
);
2438 Formal_2
:= Next_Formal
(Formal_1
);
2439 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2440 Orig_Act_2
:= Original_Actual
(Actual_2
);
2442 -- Generate the check only when the mode of the two formals may
2443 -- lead to aliasing.
2445 if Is_Name_Reference
(Orig_Act_2
)
2446 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2449 -- The aliasing check only applies when some of the formals
2450 -- have their passing mechanism unspecified; RM 6.2 (12/3).
2452 if Parameter_Passing_Mechanism_Specified
(Etype
(Orig_Act_1
))
2454 Parameter_Passing_Mechanism_Specified
(Etype
(Orig_Act_2
))
2458 Remove_Side_Effects
(Actual_1
);
2459 Remove_Side_Effects
(Actual_2
);
2462 (Actual_1
=> Actual_1
,
2463 Actual_2
=> Actual_2
,
2464 Formal_1
=> Formal_1
,
2465 Formal_2
=> Formal_2
,
2470 Next_Actual
(Actual_2
);
2471 Next_Formal
(Formal_2
);
2475 Next_Actual
(Actual_1
);
2476 Next_Formal
(Formal_1
);
2479 -- Place a simple check right before the call
2481 if Present
(Check
) and then not Exception_Extra_Info
then
2482 Insert_Action
(Call
,
2483 Make_Raise_Program_Error
(Loc
,
2485 Reason
=> PE_Aliased_Parameters
));
2487 end Apply_Parameter_Aliasing_Checks
;
2489 -------------------------------------
2490 -- Apply_Parameter_Validity_Checks --
2491 -------------------------------------
2493 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2494 Subp_Decl
: Node_Id
;
2496 procedure Add_Validity_Check
2497 (Formal
: Entity_Id
;
2499 For_Result
: Boolean := False);
2500 -- Add a single 'Valid[_Scalars] check which verifies the initialization
2501 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2502 -- Set flag For_Result when to verify the result of a function.
2504 ------------------------
2505 -- Add_Validity_Check --
2506 ------------------------
2508 procedure Add_Validity_Check
2509 (Formal
: Entity_Id
;
2511 For_Result
: Boolean := False)
2513 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
);
2514 -- Create a pre/postcondition pragma that tests expression Expr
2516 ------------------------------
2517 -- Build_Pre_Post_Condition --
2518 ------------------------------
2520 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
) is
2521 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2529 Pragma_Argument_Associations
=> New_List
(
2530 Make_Pragma_Argument_Association
(Loc
,
2531 Chars
=> Name_Check
,
2532 Expression
=> Expr
)));
2534 -- Add a message unless exception messages are suppressed
2536 if not Exception_Locations_Suppressed
then
2537 Append_To
(Pragma_Argument_Associations
(Prag
),
2538 Make_Pragma_Argument_Association
(Loc
,
2539 Chars
=> Name_Message
,
2541 Make_String_Literal
(Loc
,
2543 & Get_Name_String
(Prag_Nam
)
2545 & Build_Location_String
(Loc
))));
2548 -- Insert the pragma in the tree
2550 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2551 Add_Global_Declaration
(Prag
);
2554 -- PPC pragmas associated with subprogram bodies must be inserted
2555 -- in the declarative part of the body.
2557 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2558 Decls
:= Declarations
(Subp_Decl
);
2562 Set_Declarations
(Subp_Decl
, Decls
);
2565 Prepend_To
(Decls
, Prag
);
2568 -- For subprogram declarations insert the PPC pragma right after
2569 -- the declarative node.
2572 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2574 end Build_Pre_Post_Condition
;
2578 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2579 Typ
: constant Entity_Id
:= Etype
(Formal
);
2583 -- Start of processing for Add_Validity_Check
2586 -- For scalars, generate 'Valid test
2588 if Is_Scalar_Type
(Typ
) then
2591 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2593 elsif Scalar_Part_Present
(Typ
) then
2594 Nam
:= Name_Valid_Scalars
;
2596 -- No test needed for other cases (no scalars to test)
2602 -- Step 1: Create the expression to verify the validity of the
2605 Check
:= New_Occurrence_Of
(Formal
, Loc
);
2607 -- When processing a function result, use 'Result. Generate
2612 Make_Attribute_Reference
(Loc
,
2614 Attribute_Name
=> Name_Result
);
2618 -- Context['Result]'Valid[_Scalars]
2621 Make_Attribute_Reference
(Loc
,
2623 Attribute_Name
=> Nam
);
2625 -- Step 2: Create a pre or post condition pragma
2627 Build_Pre_Post_Condition
(Check
);
2628 end Add_Validity_Check
;
2633 Subp_Spec
: Node_Id
;
2635 -- Start of processing for Apply_Parameter_Validity_Checks
2638 -- Extract the subprogram specification and declaration nodes
2640 Subp_Spec
:= Parent
(Subp
);
2642 if No
(Subp_Spec
) then
2646 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2647 Subp_Spec
:= Parent
(Subp_Spec
);
2650 Subp_Decl
:= Parent
(Subp_Spec
);
2652 if not Comes_From_Source
(Subp
)
2654 -- Do not process formal subprograms because the corresponding actual
2655 -- will receive the proper checks when the instance is analyzed.
2657 or else Is_Formal_Subprogram
(Subp
)
2659 -- Do not process imported subprograms since pre and postconditions
2660 -- are never verified on routines coming from a different language.
2662 or else Is_Imported
(Subp
)
2663 or else Is_Intrinsic_Subprogram
(Subp
)
2665 -- The PPC pragmas generated by this routine do not correspond to
2666 -- source aspects, therefore they cannot be applied to abstract
2669 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2671 -- Do not consider subprogram renaminds because the renamed entity
2672 -- already has the proper PPC pragmas.
2674 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2676 -- Do not process null procedures because there is no benefit of
2677 -- adding the checks to a no action routine.
2679 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2680 and then Null_Present
(Subp_Spec
))
2685 -- Inspect all the formals applying aliasing and scalar initialization
2686 -- checks where applicable.
2688 Formal
:= First_Formal
(Subp
);
2689 while Present
(Formal
) loop
2691 -- Generate the following scalar initialization checks for each
2692 -- formal parameter:
2694 -- mode IN - Pre => Formal'Valid[_Scalars]
2695 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2696 -- mode OUT - Post => Formal'Valid[_Scalars]
2698 if Ekind
(Formal
) in E_In_Parameter | E_In_Out_Parameter
then
2699 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2702 if Ekind
(Formal
) in E_In_Out_Parameter | E_Out_Parameter
then
2703 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2706 Next_Formal
(Formal
);
2709 -- Generate following scalar initialization check for function result:
2711 -- Post => Subp'Result'Valid[_Scalars]
2713 if Ekind
(Subp
) = E_Function
then
2714 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2716 end Apply_Parameter_Validity_Checks
;
2718 ---------------------------
2719 -- Apply_Predicate_Check --
2720 ---------------------------
2722 procedure Apply_Predicate_Check
2725 Fun
: Entity_Id
:= Empty
)
2730 Check_Disabled
: constant Boolean := (not Predicate_Enabled
(Typ
))
2731 or else not Predicate_Check_In_Scope
(N
);
2734 while Present
(S
) and then not Is_Subprogram
(S
) loop
2738 -- If the check appears within the predicate function itself, it means
2739 -- that the user specified a check whose formal is the predicated
2740 -- subtype itself, rather than some covering type. This is likely to be
2741 -- a common error, and thus deserves a warning. We want to emit this
2742 -- warning even if predicate checking is disabled (in which case the
2743 -- warning is still useful even if it is not strictly accurate).
2745 if Present
(S
) and then S
= Predicate_Function
(Typ
) then
2747 ("predicate check includes a call to& that requires a "
2748 & "predicate check??", Parent
(N
), Fun
);
2750 ("\this will result in infinite recursion??", Parent
(N
));
2752 if Is_First_Subtype
(Typ
) then
2754 ("\use an explicit subtype of& to carry the predicate",
2758 if not Check_Disabled
then
2760 Make_Raise_Storage_Error
(Sloc
(N
),
2761 Reason
=> SE_Infinite_Recursion
));
2766 if Check_Disabled
then
2770 -- Normal case of predicate active
2772 -- If the expression is an IN parameter, the predicate will have
2773 -- been applied at the point of call. An additional check would
2774 -- be redundant, or will lead to out-of-scope references if the
2775 -- call appears within an aspect specification for a precondition.
2777 -- However, if the reference is within the body of the subprogram
2778 -- that declares the formal, the predicate can safely be applied,
2779 -- which may be necessary for a nested call whose formal has a
2780 -- different predicate.
2782 if Is_Entity_Name
(N
)
2783 and then Ekind
(Entity
(N
)) = E_In_Parameter
2786 In_Body
: Boolean := False;
2787 P
: Node_Id
:= Parent
(N
);
2790 while Present
(P
) loop
2791 if Nkind
(P
) = N_Subprogram_Body
2793 ((Present
(Corresponding_Spec
(P
))
2795 Corresponding_Spec
(P
) = Scope
(Entity
(N
)))
2797 Defining_Unit_Name
(Specification
(P
)) =
2813 -- If the type has a static predicate and the expression is known
2814 -- at compile time, see if the expression satisfies the predicate.
2816 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2818 if not Expander_Active
then
2823 if Nkind
(Par
) = N_Qualified_Expression
then
2824 Par
:= Parent
(Par
);
2827 -- For an entity of the type, generate a call to the predicate
2828 -- function, unless its type is an actual subtype, which is not
2829 -- visible outside of the enclosing subprogram.
2831 if Is_Entity_Name
(N
)
2832 and then not Is_Actual_Subtype
(Typ
)
2835 Make_Predicate_Check
2836 (Typ
, New_Occurrence_Of
(Entity
(N
), Sloc
(N
))));
2839 elsif Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
2841 -- If the expression is an aggregate in an assignment, apply the
2842 -- check to the LHS after the assignment, rather than create a
2843 -- redundant temporary. This is only necessary in rare cases
2844 -- of array types (including strings) initialized with an
2845 -- aggregate with an "others" clause, either coming from source
2846 -- or generated by an Initialize_Scalars pragma.
2848 if Nkind
(Par
) = N_Assignment_Statement
then
2849 Insert_Action_After
(Par
,
2850 Make_Predicate_Check
2851 (Typ
, Duplicate_Subexpr
(Name
(Par
))));
2854 -- Similarly, if the expression is an aggregate in an object
2855 -- declaration, apply it to the object after the declaration.
2857 -- This is only necessary in cases of tagged extensions
2858 -- initialized with an aggregate with an "others => <>" clause,
2859 -- when the subtypes of LHS and RHS do not statically match or
2860 -- when we know the object's type will be rewritten later.
2861 -- The condition for the later is copied from the
2862 -- Analyze_Object_Declaration procedure when it actually builds the
2865 elsif Nkind
(Par
) = N_Object_Declaration
then
2866 if Subtypes_Statically_Match
2867 (Etype
(Defining_Identifier
(Par
)), Typ
)
2868 and then (Nkind
(N
) = N_Extension_Aggregate
2869 or else (Is_Definite_Subtype
(Typ
)
2870 and then Build_Default_Subtype_OK
(Typ
)))
2872 Insert_Action_After
(Par
,
2873 Make_Predicate_Check
(Typ
,
2874 New_Occurrence_Of
(Defining_Identifier
(Par
), Sloc
(N
))));
2881 -- If the expression is not an entity it may have side effects,
2882 -- and the following call will create an object declaration for
2883 -- it. We disable checks during its analysis, to prevent an
2884 -- infinite recursion.
2887 Make_Predicate_Check
2888 (Typ
, Duplicate_Subexpr
(N
)), Suppress
=> All_Checks
);
2889 end Apply_Predicate_Check
;
2891 -----------------------
2892 -- Apply_Range_Check --
2893 -----------------------
2895 procedure Apply_Range_Check
2897 Target_Typ
: Entity_Id
;
2898 Source_Typ
: Entity_Id
:= Empty
;
2899 Insert_Node
: Node_Id
:= Empty
)
2901 Checks_On
: constant Boolean :=
2902 not Index_Checks_Suppressed
(Target_Typ
)
2904 not Range_Checks_Suppressed
(Target_Typ
);
2906 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2910 R_Result
: Check_Result
;
2913 -- Only apply checks when generating code. In GNATprove mode, we do not
2914 -- apply the checks, but we still call Selected_Range_Checks to possibly
2915 -- issue errors on SPARK code when a run-time error can be detected at
2918 if not GNATprove_Mode
then
2919 if not Expander_Active
or not Checks_On
then
2925 Selected_Range_Checks
(Expr
, Target_Typ
, Source_Typ
, Insert_Node
);
2927 if GNATprove_Mode
then
2931 for J
in 1 .. 2 loop
2932 R_Cno
:= R_Result
(J
);
2933 exit when No
(R_Cno
);
2935 -- The range check requires runtime evaluation. Depending on what its
2936 -- triggering condition is, the check may be converted into a compile
2937 -- time constraint check.
2939 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2940 and then Present
(Condition
(R_Cno
))
2942 Cond
:= Condition
(R_Cno
);
2944 -- Insert the range check before the related context. Note that
2945 -- this action analyses the triggering condition.
2947 if Present
(Insert_Node
) then
2948 Insert_Action
(Insert_Node
, R_Cno
);
2950 Insert_Action
(Expr
, R_Cno
);
2953 -- The triggering condition evaluates to True, the range check
2954 -- can be converted into a compile time constraint check.
2956 if Is_Entity_Name
(Cond
)
2957 and then Entity
(Cond
) = Standard_True
2959 -- Since an N_Range is technically not an expression, we have
2960 -- to set one of the bounds to C_E and then just flag the
2961 -- N_Range. The warning message will point to the lower bound
2962 -- and complain about a range, which seems OK.
2964 if Nkind
(Expr
) = N_Range
then
2965 Apply_Compile_Time_Constraint_Error
2967 "static range out of bounds of}??",
2968 CE_Range_Check_Failed
,
2972 Set_Raises_Constraint_Error
(Expr
);
2975 Apply_Compile_Time_Constraint_Error
2977 "static value out of range of}??",
2978 CE_Range_Check_Failed
,
2984 -- The range check raises Constraint_Error explicitly
2986 elsif Present
(Insert_Node
) then
2988 Make_Raise_Constraint_Error
(Sloc
(Insert_Node
),
2989 Reason
=> CE_Range_Check_Failed
);
2991 Insert_Action
(Insert_Node
, R_Cno
);
2994 Install_Static_Check
(R_Cno
, Loc
);
2997 end Apply_Range_Check
;
2999 ------------------------------
3000 -- Apply_Scalar_Range_Check --
3001 ------------------------------
3003 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
3004 -- off if it is already set on.
3006 procedure Apply_Scalar_Range_Check
3008 Target_Typ
: Entity_Id
;
3009 Source_Typ
: Entity_Id
:= Empty
;
3010 Fixed_Int
: Boolean := False)
3012 Parnt
: constant Node_Id
:= Parent
(Expr
);
3014 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
3015 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
3017 Is_Subscr_Ref
: Boolean;
3018 -- Set true if Expr is a subscript
3020 Is_Unconstrained_Subscr_Ref
: Boolean;
3021 -- Set true if Expr is a subscript of an unconstrained array. In this
3022 -- case we do not attempt to do an analysis of the value against the
3023 -- range of the subscript, since we don't know the actual subtype.
3026 -- Set to True if Expr should be regarded as a real value even though
3027 -- the type of Expr might be discrete.
3029 procedure Bad_Value
(Warn
: Boolean := False);
3030 -- Procedure called if value is determined to be out of range. Warn is
3031 -- True to force a warning instead of an error, even when SPARK_Mode is
3038 procedure Bad_Value
(Warn
: Boolean := False) is
3040 Apply_Compile_Time_Constraint_Error
3041 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
3047 -- Start of processing for Apply_Scalar_Range_Check
3050 -- Return if check obviously not needed
3053 -- Not needed inside generic
3057 -- Not needed if previous error
3059 or else Target_Typ
= Any_Type
3060 or else Nkind
(Expr
) = N_Error
3062 -- Not needed for non-scalar type
3064 or else not Is_Scalar_Type
(Target_Typ
)
3066 -- Not needed if we know node raises CE already
3068 or else Raises_Constraint_Error
(Expr
)
3073 -- Now, see if checks are suppressed
3076 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
3078 if Is_Subscr_Ref
then
3079 Arr
:= Prefix
(Parnt
);
3080 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
3082 if Is_Access_Type
(Arr_Typ
) then
3083 Arr_Typ
:= Designated_Type
(Arr_Typ
);
3087 if not Do_Range_Check
(Expr
) then
3089 -- Subscript reference. Check for Index_Checks suppressed
3091 if Is_Subscr_Ref
then
3093 -- Check array type and its base type
3095 if Index_Checks_Suppressed
(Arr_Typ
)
3096 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
3100 -- Check array itself if it is an entity name
3102 elsif Is_Entity_Name
(Arr
)
3103 and then Index_Checks_Suppressed
(Entity
(Arr
))
3107 -- Check expression itself if it is an entity name
3109 elsif Is_Entity_Name
(Expr
)
3110 and then Index_Checks_Suppressed
(Entity
(Expr
))
3115 -- All other cases, check for Range_Checks suppressed
3118 -- Check target type and its base type
3120 if Range_Checks_Suppressed
(Target_Typ
)
3121 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
3125 -- Check expression itself if it is an entity name
3127 elsif Is_Entity_Name
(Expr
)
3128 and then Range_Checks_Suppressed
(Entity
(Expr
))
3132 -- If Expr is part of an assignment statement, then check left
3133 -- side of assignment if it is an entity name.
3135 elsif Nkind
(Parnt
) = N_Assignment_Statement
3136 and then Is_Entity_Name
(Name
(Parnt
))
3137 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
3144 -- Do not set range checks if they are killed
3146 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
3147 and then Kill_Range_Check
(Expr
)
3152 -- Do not set range checks for any values from System.Scalar_Values
3153 -- since the whole idea of such values is to avoid checking them.
3155 if Is_Entity_Name
(Expr
)
3156 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
3161 -- Now see if we need a check
3163 if No
(Source_Typ
) then
3164 S_Typ
:= Etype
(Expr
);
3166 S_Typ
:= Source_Typ
;
3169 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
3173 Is_Unconstrained_Subscr_Ref
:=
3174 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
3176 -- Special checks for floating-point type
3178 if Is_Floating_Point_Type
(S_Typ
) then
3180 -- Always do a range check if the source type includes infinities and
3181 -- the target type does not include infinities. We do not do this if
3182 -- range checks are killed.
3183 -- If the expression is a literal and the bounds of the type are
3184 -- static constants it may be possible to optimize the check.
3186 if Has_Infinities
(S_Typ
)
3187 and then not Has_Infinities
(Target_Typ
)
3189 -- If the expression is a literal and the bounds of the type are
3190 -- static constants it may be possible to optimize the check.
3192 if Nkind
(Expr
) = N_Real_Literal
then
3194 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
3195 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
3198 if Compile_Time_Known_Value
(Tlo
)
3199 and then Compile_Time_Known_Value
(Thi
)
3200 and then Expr_Value_R
(Expr
) >= Expr_Value_R
(Tlo
)
3201 and then Expr_Value_R
(Expr
) <= Expr_Value_R
(Thi
)
3205 Enable_Range_Check
(Expr
);
3210 Enable_Range_Check
(Expr
);
3215 -- Return if we know expression is definitely in the range of the target
3216 -- type as determined by Determine_Range_To_Discrete. Right now we only
3217 -- do this for discrete target types, i.e. neither for fixed-point nor
3218 -- for floating-point types. But the additional less precise tests below
3219 -- catch these cases.
3221 -- Note: skip this if we are given a source_typ, since the point of
3222 -- supplying a Source_Typ is to stop us looking at the expression.
3223 -- We could sharpen this test to be out parameters only ???
3225 if Is_Discrete_Type
(Target_Typ
)
3226 and then not Is_Unconstrained_Subscr_Ref
3227 and then No
(Source_Typ
)
3230 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
3231 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
3234 if Compile_Time_Known_Value
(Tlo
)
3235 and then Compile_Time_Known_Value
(Thi
)
3238 OK
: Boolean := False; -- initialize to prevent warning
3239 Hiv
: constant Uint
:= Expr_Value
(Thi
);
3240 Lov
: constant Uint
:= Expr_Value
(Tlo
);
3241 Hi
: Uint
:= No_Uint
;
3242 Lo
: Uint
:= No_Uint
;
3245 -- If range is null, we for sure have a constraint error (we
3246 -- don't even need to look at the value involved, since all
3247 -- possible values will raise CE).
3251 -- When SPARK_Mode is On, force a warning instead of
3252 -- an error in that case, as this likely corresponds
3253 -- to deactivated code.
3255 Bad_Value
(Warn
=> SPARK_Mode
= On
);
3260 -- Otherwise determine range of value
3262 Determine_Range_To_Discrete
3263 (Expr
, OK
, Lo
, Hi
, Fixed_Int
, Assume_Valid
=> True);
3267 -- If definitely in range, all OK
3269 if Lo
>= Lov
and then Hi
<= Hiv
then
3272 -- If definitely not in range, warn
3274 elsif Lov
> Hi
or else Hiv
< Lo
then
3276 -- Ignore out of range values for System.Priority in
3277 -- CodePeer mode since the actual target compiler may
3278 -- provide a wider range.
3280 if not CodePeer_Mode
3281 or else not Is_RTE
(Target_Typ
, RE_Priority
)
3288 -- Otherwise we don't know
3300 Is_Floating_Point_Type
(S_Typ
)
3301 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
3303 -- Check if we can determine at compile time whether Expr is in the
3304 -- range of the target type. Note that if S_Typ is within the bounds
3305 -- of Target_Typ then this must be the case. This check is meaningful
3306 -- only if this is not a conversion between integer and real types,
3307 -- unless for a fixed-point type if Fixed_Int is set.
3309 if not Is_Unconstrained_Subscr_Ref
3310 and then (Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
3311 or else (Fixed_Int
and then Is_Discrete_Type
(Target_Typ
)))
3313 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
3315 -- Also check if the expression itself is in the range of the
3316 -- target type if it is a known at compile time value. We skip
3317 -- this test if S_Typ is set since for OUT and IN OUT parameters
3318 -- the Expr itself is not relevant to the checking.
3322 and then Is_In_Range
(Expr
, Target_Typ
,
3323 Assume_Valid
=> True,
3324 Fixed_Int
=> Fixed_Int
,
3325 Int_Real
=> Int_Real
)))
3329 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
3330 Assume_Valid
=> True,
3331 Fixed_Int
=> Fixed_Int
,
3332 Int_Real
=> Int_Real
)
3337 -- Floating-point case
3338 -- In the floating-point case, we only do range checks if the type is
3339 -- constrained. We definitely do NOT want range checks for unconstrained
3340 -- types, since we want to have infinities, except when
3341 -- Check_Float_Overflow is set.
3343 elsif Is_Floating_Point_Type
(S_Typ
) then
3344 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
3345 Enable_Range_Check
(Expr
);
3348 -- For all other cases we enable a range check unconditionally
3351 Enable_Range_Check
(Expr
);
3354 end Apply_Scalar_Range_Check
;
3356 ----------------------------------
3357 -- Apply_Selected_Length_Checks --
3358 ----------------------------------
3360 procedure Apply_Selected_Length_Checks
3362 Target_Typ
: Entity_Id
;
3363 Source_Typ
: Entity_Id
;
3364 Do_Static
: Boolean)
3366 Checks_On
: constant Boolean :=
3367 not Index_Checks_Suppressed
(Target_Typ
)
3369 not Length_Checks_Suppressed
(Target_Typ
);
3371 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
3375 R_Result
: Check_Result
;
3378 -- Only apply checks when generating code
3380 -- Note: this means that we lose some useful warnings if the expander
3383 if not Expander_Active
then
3388 Selected_Length_Checks
(Expr
, Target_Typ
, Source_Typ
, Empty
);
3390 for J
in 1 .. 2 loop
3391 R_Cno
:= R_Result
(J
);
3392 exit when No
(R_Cno
);
3394 -- A length check may mention an Itype which is attached to a
3395 -- subsequent node. At the top level in a package this can cause
3396 -- an order-of-elaboration problem, so we make sure that the itype
3397 -- is referenced now.
3399 if Ekind
(Current_Scope
) = E_Package
3400 and then Is_Compilation_Unit
(Current_Scope
)
3402 Ensure_Defined
(Target_Typ
, Expr
);
3404 if Present
(Source_Typ
) then
3405 Ensure_Defined
(Source_Typ
, Expr
);
3407 elsif Is_Itype
(Etype
(Expr
)) then
3408 Ensure_Defined
(Etype
(Expr
), Expr
);
3412 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3413 and then Present
(Condition
(R_Cno
))
3415 Cond
:= Condition
(R_Cno
);
3417 -- Case where node does not now have a dynamic check
3419 if not Has_Dynamic_Length_Check
(Expr
) then
3421 -- If checks are on, just insert the check
3424 Insert_Action
(Expr
, R_Cno
);
3426 if not Do_Static
then
3427 Set_Has_Dynamic_Length_Check
(Expr
);
3430 -- If checks are off, then analyze the length check after
3431 -- temporarily attaching it to the tree in case the relevant
3432 -- condition can be evaluated at compile time. We still want a
3433 -- compile time warning in this case.
3436 Set_Parent
(R_Cno
, Expr
);
3441 -- Output a warning if the condition is known to be True
3443 if Is_Entity_Name
(Cond
)
3444 and then Entity
(Cond
) = Standard_True
3446 Apply_Compile_Time_Constraint_Error
3447 (Expr
, "wrong length for array of}??",
3448 CE_Length_Check_Failed
,
3452 -- If we were only doing a static check, or if checks are not
3453 -- on, then we want to delete the check, since it is not needed.
3454 -- We do this by replacing the if statement by a null statement
3456 elsif Do_Static
or else not Checks_On
then
3457 Remove_Warning_Messages
(R_Cno
);
3458 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3462 Install_Static_Check
(R_Cno
, Loc
);
3465 end Apply_Selected_Length_Checks
;
3467 -------------------------------
3468 -- Apply_Static_Length_Check --
3469 -------------------------------
3471 procedure Apply_Static_Length_Check
3473 Target_Typ
: Entity_Id
;
3474 Source_Typ
: Entity_Id
:= Empty
)
3477 Apply_Selected_Length_Checks
3478 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3479 end Apply_Static_Length_Check
;
3481 -------------------------------------
3482 -- Apply_Subscript_Validity_Checks --
3483 -------------------------------------
3485 procedure Apply_Subscript_Validity_Checks
3487 No_Check_Needed
: Dimension_Set
:= Empty_Dimension_Set
) is
3490 Dimension
: Pos
:= 1;
3492 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3494 -- Loop through subscripts
3496 Sub
:= First
(Expressions
(Expr
));
3497 while Present
(Sub
) loop
3499 -- Check one subscript. Note that we do not worry about enumeration
3500 -- type with holes, since we will convert the value to a Pos value
3501 -- for the subscript, and that convert will do the necessary validity
3504 if (No_Check_Needed
= Empty_Dimension_Set
)
3505 or else not No_Check_Needed
.Elements
(Dimension
)
3507 Ensure_Valid
(Sub
, Holes_OK
=> True);
3510 -- Move to next subscript
3513 Dimension
:= Dimension
+ 1;
3515 end Apply_Subscript_Validity_Checks
;
3517 ----------------------------------
3518 -- Apply_Type_Conversion_Checks --
3519 ----------------------------------
3521 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3522 Target_Type
: constant Entity_Id
:= Etype
(N
);
3523 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3524 Expr
: constant Node_Id
:= Expression
(N
);
3526 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3527 -- Note: if Etype (Expr) is a private type without discriminants, its
3528 -- full view might have discriminants with defaults, so we need the
3529 -- full view here to retrieve the constraints.
3531 procedure Make_Discriminant_Constraint_Check
3532 (Target_Type
: Entity_Id
;
3533 Expr_Type
: Entity_Id
);
3534 -- Generate a discriminant check based on the target type and expression
3537 ----------------------------------------
3538 -- Make_Discriminant_Constraint_Check --
3539 ----------------------------------------
3541 procedure Make_Discriminant_Constraint_Check
3542 (Target_Type
: Entity_Id
;
3543 Expr_Type
: Entity_Id
)
3545 Loc
: constant Source_Ptr
:= Sloc
(N
);
3547 Constraint
: Elmt_Id
;
3548 Discr_Value
: Node_Id
;
3551 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3552 Old_Constraints
: constant Elist_Id
:=
3553 Discriminant_Constraint
(Expr_Type
);
3556 -- Build an actual discriminant constraint list using the stored
3557 -- constraint, to verify that the expression of the parent type
3558 -- satisfies the constraints imposed by the (unconstrained) derived
3559 -- type. This applies to value conversions, not to view conversions
3562 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3563 while Present
(Constraint
) loop
3564 Discr_Value
:= Node
(Constraint
);
3566 if Is_Entity_Name
(Discr_Value
)
3567 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3569 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3572 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3574 -- Parent is constrained by new discriminant. Obtain
3575 -- Value of original discriminant in expression. If the
3576 -- new discriminant has been used to constrain more than
3577 -- one of the stored discriminants, this will provide the
3578 -- required consistency check.
3581 (Make_Selected_Component
(Loc
,
3583 Duplicate_Subexpr_No_Checks
3584 (Expr
, Name_Req
=> True),
3586 Make_Identifier
(Loc
, Chars
(Discr
))),
3590 -- Discriminant of more remote ancestor ???
3595 -- Derived type definition has an explicit value for this
3596 -- stored discriminant.
3600 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3604 Next_Elmt
(Constraint
);
3607 -- Use the unconstrained expression type to retrieve the
3608 -- discriminants of the parent, and apply momentarily the
3609 -- discriminant constraint synthesized above.
3611 -- Note: We use Expr_Type instead of Target_Type since the number of
3612 -- actual discriminants may be different due to the presence of
3613 -- stored discriminants and cause Build_Discriminant_Checks to fail.
3615 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3616 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3617 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3619 -- Conversion between access types requires that we check for null
3620 -- before checking discriminants.
3622 if Is_Access_Type
(Etype
(Expr
)) then
3623 Cond
:= Make_And_Then
(Loc
,
3627 Duplicate_Subexpr_No_Checks
3628 (Expr
, Name_Req
=> True),
3629 Right_Opnd
=> Make_Null
(Loc
)),
3630 Right_Opnd
=> Cond
);
3634 Make_Raise_Constraint_Error
(Loc
,
3636 Reason
=> CE_Discriminant_Check_Failed
));
3637 end Make_Discriminant_Constraint_Check
;
3639 -- Start of processing for Apply_Type_Conversion_Checks
3642 if Inside_A_Generic
then
3645 -- Skip these checks if serious errors detected, there are some nasty
3646 -- situations of incomplete trees that blow things up.
3648 elsif Serious_Errors_Detected
> 0 then
3651 -- Never generate discriminant checks for Unchecked_Union types
3653 elsif Present
(Expr_Type
)
3654 and then Is_Unchecked_Union
(Expr_Type
)
3658 -- Scalar type conversions of the form Target_Type (Expr) require a
3659 -- range check if we cannot be sure that Expr is in the base type of
3660 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3661 -- are not quite the same condition from an implementation point of
3662 -- view, but clearly the second includes the first.
3664 elsif Is_Scalar_Type
(Target_Type
) then
3666 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3667 -- If the Conversion_OK flag on the type conversion is set and no
3668 -- floating-point type is involved in the type conversion then
3669 -- fixed-point values must be read as integral values.
3671 Float_To_Int
: constant Boolean :=
3672 Is_Floating_Point_Type
(Expr_Type
)
3673 and then Is_Integer_Type
(Target_Type
);
3676 if not Overflow_Checks_Suppressed
(Target_Base
)
3677 and then not Overflow_Checks_Suppressed
(Target_Type
)
3679 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3680 and then not Float_To_Int
3682 -- A small optimization: the attribute 'Pos applied to an
3683 -- enumeration type has a known range, even though its type is
3684 -- Universal_Integer. So in numeric conversions it is usually
3685 -- within range of the target integer type. Use the static
3686 -- bounds of the base types to check. Disable this optimization
3687 -- in case of a descendant of a generic formal discrete type,
3688 -- because we don't necessarily know the upper bound yet.
3690 if Nkind
(Expr
) = N_Attribute_Reference
3691 and then Attribute_Name
(Expr
) = Name_Pos
3692 and then Is_Enumeration_Type
(Etype
(Prefix
(Expr
)))
3694 not Is_Generic_Type
(Root_Type
(Etype
(Prefix
(Expr
))))
3695 and then Is_Integer_Type
(Target_Type
)
3698 Enum_T
: constant Entity_Id
:=
3699 Root_Type
(Etype
(Prefix
(Expr
)));
3700 Int_T
: constant Entity_Id
:= Base_Type
(Target_Type
);
3701 Last_I
: constant Uint
:=
3702 Intval
(High_Bound
(Scalar_Range
(Int_T
)));
3706 -- Character types have no explicit literals, so we use
3707 -- the known number of characters in the type.
3709 if Root_Type
(Enum_T
) = Standard_Character
then
3710 Last_E
:= UI_From_Int
(255);
3712 elsif Enum_T
= Standard_Wide_Character
3713 or else Enum_T
= Standard_Wide_Wide_Character
3715 Last_E
:= UI_From_Int
(65535);
3720 (Entity
(High_Bound
(Scalar_Range
(Enum_T
))));
3723 if Last_E
> Last_I
then
3724 Activate_Overflow_Check
(N
);
3728 Activate_Overflow_Check
(N
);
3732 if not Range_Checks_Suppressed
(Target_Type
)
3733 and then not Range_Checks_Suppressed
(Expr_Type
)
3736 and then not GNATprove_Mode
3738 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3740 -- Raw conversions involving fixed-point types are expanded
3741 -- separately and do not need a Range_Check flag yet, except
3742 -- in GNATprove_Mode where this expansion is not performed.
3743 -- This does not apply to conversion where fixed-point types
3744 -- are treated as integers, which are precisely generated by
3749 or else (not Is_Fixed_Point_Type
(Expr_Type
)
3750 and then not Is_Fixed_Point_Type
(Target_Type
))
3752 Apply_Scalar_Range_Check
3753 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3756 Set_Do_Range_Check
(Expr
, False);
3759 -- If the target type has predicates, we need to indicate
3760 -- the need for a check, even if Determine_Range finds that
3761 -- the value is within bounds. This may be the case e.g for
3762 -- a division with a constant denominator.
3764 if Has_Predicates
(Target_Type
) then
3765 Enable_Range_Check
(Expr
);
3771 -- Generate discriminant constraint checks for access types on the
3772 -- designated target type's stored constraints.
3774 -- Do we need to generate subtype predicate checks here as well ???
3776 elsif Comes_From_Source
(N
)
3777 and then Ekind
(Target_Type
) = E_General_Access_Type
3779 -- Check that both of the designated types have known discriminants,
3780 -- and that such checks on the target type are not suppressed.
3782 and then Has_Discriminants
(Directly_Designated_Type
(Target_Type
))
3783 and then Has_Discriminants
(Directly_Designated_Type
(Expr_Type
))
3784 and then not Discriminant_Checks_Suppressed
3785 (Directly_Designated_Type
(Target_Type
))
3787 -- Verify the designated type of the target has stored constraints
3790 (Stored_Constraint
(Directly_Designated_Type
(Target_Type
)))
3792 Make_Discriminant_Constraint_Check
3793 (Target_Type
=> Directly_Designated_Type
(Target_Type
),
3794 Expr_Type
=> Directly_Designated_Type
(Expr_Type
));
3796 -- Create discriminant checks for the Target_Type's stored constraints
3798 elsif Comes_From_Source
(N
)
3799 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3800 and then Is_Record_Type
(Target_Type
)
3801 and then Is_Derived_Type
(Target_Type
)
3802 and then not Is_Tagged_Type
(Target_Type
)
3803 and then not Is_Constrained
(Target_Type
)
3804 and then Present
(Stored_Constraint
(Target_Type
))
3806 Make_Discriminant_Constraint_Check
(Target_Type
, Expr_Type
);
3808 -- For arrays, checks are set now, but conversions are applied during
3809 -- expansion, to take into accounts changes of representation. The
3810 -- checks become range checks on the base type or length checks on the
3811 -- subtype, depending on whether the target type is unconstrained or
3812 -- constrained. Note that the range check is put on the expression of a
3813 -- type conversion, while the length check is put on the type conversion
3816 elsif Is_Array_Type
(Target_Type
) then
3817 if Is_Constrained
(Target_Type
) then
3818 Set_Do_Length_Check
(N
);
3820 Set_Do_Range_Check
(Expr
);
3823 end Apply_Type_Conversion_Checks
;
3825 ----------------------------------------------
3826 -- Apply_Universal_Integer_Attribute_Checks --
3827 ----------------------------------------------
3829 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3830 Loc
: constant Source_Ptr
:= Sloc
(N
);
3831 Typ
: constant Entity_Id
:= Etype
(N
);
3834 if Inside_A_Generic
then
3837 -- Nothing to do if the result type is universal integer
3839 elsif Typ
= Universal_Integer
then
3842 -- Nothing to do if checks are suppressed
3844 elsif Range_Checks_Suppressed
(Typ
)
3845 and then Overflow_Checks_Suppressed
(Typ
)
3849 -- Nothing to do if the attribute does not come from source. The
3850 -- internal attributes we generate of this type do not need checks,
3851 -- and furthermore the attempt to check them causes some circular
3852 -- elaboration orders when dealing with packed types.
3854 elsif not Comes_From_Source
(N
) then
3857 -- If the prefix is a selected component that depends on a discriminant
3858 -- the check may improperly expose a discriminant instead of using
3859 -- the bounds of the object itself. Set the type of the attribute to
3860 -- the base type of the context, so that a check will be imposed when
3861 -- needed (e.g. if the node appears as an index).
3863 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3864 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3865 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3867 Set_Etype
(N
, Base_Type
(Typ
));
3869 -- Otherwise, replace the attribute node with a type conversion node
3870 -- whose expression is the attribute, retyped to universal integer, and
3871 -- whose subtype mark is the target type. The call to analyze this
3872 -- conversion will set range and overflow checks as required for proper
3873 -- detection of an out of range value.
3876 Set_Etype
(N
, Universal_Integer
);
3877 Set_Analyzed
(N
, True);
3880 Make_Type_Conversion
(Loc
,
3881 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3882 Expression
=> Relocate_Node
(N
)));
3884 Analyze_And_Resolve
(N
, Typ
);
3887 end Apply_Universal_Integer_Attribute_Checks
;
3889 -------------------------------------
3890 -- Atomic_Synchronization_Disabled --
3891 -------------------------------------
3893 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3894 -- using a bogus check called Atomic_Synchronization. This is to make it
3895 -- more convenient to get exactly the same semantics as [Un]Suppress.
3897 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3899 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3900 -- looks enabled, since it is never disabled.
3902 if Debug_Flag_Dot_E
then
3905 -- If debug flag d.d is set then always return True, i.e. all atomic
3906 -- sync looks disabled, since it always tests True.
3908 elsif Debug_Flag_Dot_D
then
3911 -- If entity present, then check result for that entity
3913 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3914 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3916 -- Otherwise result depends on current scope setting
3919 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3921 end Atomic_Synchronization_Disabled
;
3923 -------------------------------
3924 -- Build_Discriminant_Checks --
3925 -------------------------------
3927 function Build_Discriminant_Checks
3929 T_Typ
: Entity_Id
) return Node_Id
3931 Loc
: constant Source_Ptr
:= Sloc
(N
);
3934 Disc_Ent
: Entity_Id
;
3938 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3940 function Replace_Current_Instance
3941 (N
: Node_Id
) return Traverse_Result
;
3942 -- Replace a reference to the current instance of the type with the
3943 -- corresponding _init formal of the initialization procedure. Note:
3944 -- this function relies on us currently being within the initialization
3947 --------------------------------
3948 -- Aggregate_Discriminant_Val --
3949 --------------------------------
3951 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3955 -- The aggregate has been normalized with named associations. We use
3956 -- the Chars field to locate the discriminant to take into account
3957 -- discriminants in derived types, which carry the same name as those
3960 Assoc
:= First
(Component_Associations
(N
));
3961 while Present
(Assoc
) loop
3962 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3963 return Expression
(Assoc
);
3969 -- Discriminant must have been found in the loop above
3971 raise Program_Error
;
3972 end Aggregate_Discriminant_Val
;
3974 ------------------------------
3975 -- Replace_Current_Instance --
3976 ------------------------------
3978 function Replace_Current_Instance
3979 (N
: Node_Id
) return Traverse_Result
is
3981 if Is_Entity_Name
(N
)
3982 and then Etype
(N
) = Entity
(N
)
3985 New_Occurrence_Of
(First_Formal
(Current_Subprogram
), Loc
));
3989 end Replace_Current_Instance
;
3991 procedure Search_And_Replace_Current_Instance
is new
3992 Traverse_Proc
(Replace_Current_Instance
);
3994 -- Start of processing for Build_Discriminant_Checks
3997 -- Loop through discriminants evolving the condition
4000 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
4002 -- For a fully private type, use the discriminants of the parent type
4004 if Is_Private_Type
(T_Typ
)
4005 and then No
(Full_View
(T_Typ
))
4007 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
4009 Disc_Ent
:= First_Discriminant
(T_Typ
);
4012 while Present
(Disc
) loop
4013 Dval
:= Node
(Disc
);
4015 if Nkind
(Dval
) = N_Identifier
4016 and then Ekind
(Entity
(Dval
)) = E_Discriminant
4018 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
4020 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
4023 -- Replace references to the current instance of the type with the
4024 -- corresponding _init formal of the initialization procedure.
4026 if Within_Init_Proc
then
4027 Search_And_Replace_Current_Instance
(Dval
);
4030 -- If we have an Unchecked_Union node, we can infer the discriminants
4033 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
4035 Get_Discriminant_Value
(
4036 First_Discriminant
(T_Typ
),
4038 Stored_Constraint
(T_Typ
)));
4040 elsif Nkind
(N
) = N_Aggregate
then
4042 Duplicate_Subexpr_No_Checks
4043 (Aggregate_Discriminant_Val
(Disc_Ent
));
4045 elsif Is_Access_Type
(Etype
(N
)) then
4047 Make_Selected_Component
(Loc
,
4049 Make_Explicit_Dereference
(Loc
,
4050 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True)),
4051 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
4053 Set_Is_In_Discriminant_Check
(Dref
);
4056 Make_Selected_Component
(Loc
,
4058 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
4059 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
4061 Set_Is_In_Discriminant_Check
(Dref
);
4064 Evolve_Or_Else
(Cond
,
4067 Right_Opnd
=> Dval
));
4070 Next_Discriminant
(Disc_Ent
);
4074 end Build_Discriminant_Checks
;
4080 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
4087 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
4088 -- Return the relevant expression from the left operand of the given
4089 -- short circuit form: this is LO itself, except if LO is a qualified
4090 -- expression, a type conversion, or an expression with actions, in
4091 -- which case this is Left_Expression (Expression (LO)).
4093 ---------------------
4094 -- Left_Expression --
4095 ---------------------
4097 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
4098 LE
: Node_Id
:= Left_Opnd
(Op
);
4100 while Nkind
(LE
) in N_Qualified_Expression
4102 | N_Expression_With_Actions
4104 LE
:= Expression
(LE
);
4108 end Left_Expression
;
4110 -- Start of processing for Check_Needed
4113 -- Always check if not simple entity
4115 if Nkind
(Nod
) not in N_Has_Entity
4116 or else not Comes_From_Source
(Nod
)
4121 -- Look up tree for short circuit
4128 -- Done if out of subexpression (note that we allow generated stuff
4129 -- such as itype declarations in this context, to keep the loop going
4130 -- since we may well have generated such stuff in complex situations.
4131 -- Also done if no parent (probably an error condition, but no point
4132 -- in behaving nasty if we find it).
4135 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
4139 -- Or/Or Else case, where test is part of the right operand, or is
4140 -- part of one of the actions associated with the right operand, and
4141 -- the left operand is an equality test.
4143 elsif K
= N_Op_Or
then
4144 exit when N
= Right_Opnd
(P
)
4145 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
4147 elsif K
= N_Or_Else
then
4148 exit when (N
= Right_Opnd
(P
)
4151 and then List_Containing
(N
) = Actions
(P
)))
4152 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
4154 -- Similar test for the And/And then case, where the left operand
4155 -- is an inequality test.
4157 elsif K
= N_Op_And
then
4158 exit when N
= Right_Opnd
(P
)
4159 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
4161 elsif K
= N_And_Then
then
4162 exit when (N
= Right_Opnd
(P
)
4165 and then List_Containing
(N
) = Actions
(P
)))
4166 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
4172 -- If we fall through the loop, then we have a conditional with an
4173 -- appropriate test as its left operand, so look further.
4175 L
:= Left_Expression
(P
);
4177 -- L is an "=" or "/=" operator: extract its operands
4179 R
:= Right_Opnd
(L
);
4182 -- Left operand of test must match original variable
4184 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
4188 -- Right operand of test must be key value (zero or null)
4191 when Access_Check
=>
4192 if not Known_Null
(R
) then
4196 when Division_Check
=>
4197 if not Compile_Time_Known_Value
(R
)
4198 or else Expr_Value
(R
) /= Uint_0
4204 raise Program_Error
;
4207 -- Here we have the optimizable case, warn if not short-circuited
4209 if K
= N_Op_And
or else K
= N_Op_Or
then
4210 Error_Msg_Warn
:= SPARK_Mode
/= On
;
4213 when Access_Check
=>
4214 if GNATprove_Mode
then
4216 ("Constraint_Error might have been raised (access check)",
4220 ("Constraint_Error may be raised (access check)??",
4224 when Division_Check
=>
4225 if GNATprove_Mode
then
4227 ("Constraint_Error might have been raised (zero divide)",
4231 ("Constraint_Error may be raised (zero divide)??",
4236 raise Program_Error
;
4239 if K
= N_Op_And
then
4240 Error_Msg_N
-- CODEFIX
4241 ("use `AND THEN` instead of AND??", P
);
4243 Error_Msg_N
-- CODEFIX
4244 ("use `OR ELSE` instead of OR??", P
);
4247 -- If not short-circuited, we need the check
4251 -- If short-circuited, we can omit the check
4258 -----------------------------------
4259 -- Check_Valid_Lvalue_Subscripts --
4260 -----------------------------------
4262 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
4264 -- Skip this if range checks are suppressed
4266 if Range_Checks_Suppressed
(Etype
(Expr
)) then
4269 -- Only do this check for expressions that come from source. We assume
4270 -- that expander generated assignments explicitly include any necessary
4271 -- checks. Note that this is not just an optimization, it avoids
4272 -- infinite recursions.
4274 elsif not Comes_From_Source
(Expr
) then
4277 -- For a selected component, check the prefix
4279 elsif Nkind
(Expr
) = N_Selected_Component
then
4280 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4283 -- Case of indexed component
4285 elsif Nkind
(Expr
) = N_Indexed_Component
then
4286 Apply_Subscript_Validity_Checks
(Expr
);
4288 -- Prefix may itself be or contain an indexed component, and these
4289 -- subscripts need checking as well.
4291 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4293 end Check_Valid_Lvalue_Subscripts
;
4295 ----------------------------------
4296 -- Null_Exclusion_Static_Checks --
4297 ----------------------------------
4299 procedure Null_Exclusion_Static_Checks
4301 Comp
: Node_Id
:= Empty
;
4302 Array_Comp
: Boolean := False)
4304 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
4305 Kind
: constant Node_Kind
:= Nkind
(N
);
4306 Error_Nod
: Node_Id
;
4312 (Kind
in N_Component_Declaration
4313 | N_Discriminant_Specification
4314 | N_Function_Specification
4315 | N_Object_Declaration
4316 | N_Parameter_Specification
);
4318 if Kind
= N_Function_Specification
then
4319 Typ
:= Etype
(Defining_Entity
(N
));
4321 Typ
:= Etype
(Defining_Identifier
(N
));
4325 when N_Component_Declaration
=>
4326 if Present
(Access_Definition
(Component_Definition
(N
))) then
4327 Error_Nod
:= Component_Definition
(N
);
4329 Error_Nod
:= Subtype_Indication
(Component_Definition
(N
));
4332 when N_Discriminant_Specification
=>
4333 Error_Nod
:= Discriminant_Type
(N
);
4335 when N_Function_Specification
=>
4336 Error_Nod
:= Result_Definition
(N
);
4338 when N_Object_Declaration
=>
4339 Error_Nod
:= Object_Definition
(N
);
4341 when N_Parameter_Specification
=>
4342 Error_Nod
:= Parameter_Type
(N
);
4345 raise Program_Error
;
4350 -- Enforce legality rule 3.10 (13): A null exclusion can only be
4351 -- applied to an access [sub]type.
4353 if not Is_Access_Type
(Typ
) then
4355 ("`NOT NULL` allowed only for an access type", Error_Nod
);
4357 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4358 -- be applied to a [sub]type that does not exclude null already.
4360 elsif Can_Never_Be_Null
(Typ
) and then Comes_From_Source
(Typ
) then
4362 ("`NOT NULL` not allowed (& already excludes null)",
4367 -- Check that null-excluding objects are always initialized, except for
4368 -- deferred constants, for which the expression will appear in the full
4371 if Kind
= N_Object_Declaration
4372 and then No
(Expression
(N
))
4373 and then not Constant_Present
(N
)
4374 and then not No_Initialization
(N
)
4376 if Present
(Comp
) then
4378 -- Specialize the warning message to indicate that we are dealing
4379 -- with an uninitialized composite object that has a defaulted
4380 -- null-excluding component.
4382 Error_Msg_Name_1
:= Chars
(Defining_Identifier
(Comp
));
4383 Error_Msg_Name_2
:= Chars
(Defining_Identifier
(N
));
4386 (Compile_Time_Constraint_Error
4389 "(Ada 2005) null-excluding component % of object % must "
4390 & "be initialized??",
4391 Ent
=> Defining_Identifier
(Comp
)));
4393 -- This is a case of an array with null-excluding components, so
4394 -- indicate that in the warning.
4396 elsif Array_Comp
then
4398 (Compile_Time_Constraint_Error
4401 "(Ada 2005) null-excluding array components must "
4402 & "be initialized??",
4403 Ent
=> Defining_Identifier
(N
)));
4405 -- Normal case of object of a null-excluding access type
4408 -- Add an expression that assigns null. This node is needed by
4409 -- Apply_Compile_Time_Constraint_Error, which will replace this
4410 -- with a Constraint_Error node.
4412 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
4413 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
4415 Apply_Compile_Time_Constraint_Error
4416 (N
=> Expression
(N
),
4418 "(Ada 2005) null-excluding objects must be initialized??",
4419 Reason
=> CE_Null_Not_Allowed
);
4423 -- Check that a null-excluding component, formal or object is not being
4424 -- assigned a null value. Otherwise generate a warning message and
4425 -- replace Expression (N) by an N_Constraint_Error node.
4427 if Kind
/= N_Function_Specification
then
4428 Expr
:= Expression
(N
);
4430 if Present
(Expr
) and then Known_Null
(Expr
) then
4432 when N_Component_Declaration
4433 | N_Discriminant_Specification
4435 Apply_Compile_Time_Constraint_Error
4438 "(Ada 2005) NULL not allowed in null-excluding "
4440 Reason
=> CE_Null_Not_Allowed
);
4442 when N_Object_Declaration
=>
4443 Apply_Compile_Time_Constraint_Error
4446 "(Ada 2005) NULL not allowed in null-excluding "
4448 Reason
=> CE_Null_Not_Allowed
);
4450 when N_Parameter_Specification
=>
4451 Apply_Compile_Time_Constraint_Error
4454 "(Ada 2005) NULL not allowed in null-excluding "
4456 Reason
=> CE_Null_Not_Allowed
);
4463 end Null_Exclusion_Static_Checks
;
4465 -------------------------------------
4466 -- Compute_Range_For_Arithmetic_Op --
4467 -------------------------------------
4469 procedure Compute_Range_For_Arithmetic_Op
4479 -- Use local variables for possible adjustments
4481 Llo
: Uint
renames Lo_Left
;
4482 Lhi
: Uint
renames Hi_Left
;
4483 Rlo
: Uint
:= Lo_Right
;
4484 Rhi
: Uint
:= Hi_Right
;
4487 -- We will compute a range for the result in almost all cases
4497 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
4509 -- If the right operand can only be zero, set 0..0
4511 if Rlo
= 0 and then Rhi
= 0 then
4515 -- Possible bounds of division must come from dividing end
4516 -- values of the input ranges (four possibilities), provided
4517 -- zero is not included in the possible values of the right
4520 -- Otherwise, we just consider two intervals of values for
4521 -- the right operand: the interval of negative values (up to
4522 -- -1) and the interval of positive values (starting at 1).
4523 -- Since division by 1 is the identity, and division by -1
4524 -- is negation, we get all possible bounds of division in that
4525 -- case by considering:
4526 -- - all values from the division of end values of input
4528 -- - the end values of the left operand;
4529 -- - the negation of the end values of the left operand.
4533 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
4534 -- Mark so we can release the RR and Ev values
4542 -- Discard extreme values of zero for the divisor, since
4543 -- they will simply result in an exception in any case.
4551 -- Compute possible bounds coming from dividing end
4552 -- values of the input ranges.
4559 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
4560 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
4562 -- If the right operand can be both negative or positive,
4563 -- include the end values of the left operand in the
4564 -- extreme values, as well as their negation.
4566 if Rlo
< 0 and then Rhi
> 0 then
4573 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
4575 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
4578 -- Release the RR and Ev values
4580 Release_And_Save
(Mrk
, Lo
, Hi
);
4588 -- Discard negative values for the exponent, since they will
4589 -- simply result in an exception in any case.
4597 -- Estimate number of bits in result before we go computing
4598 -- giant useless bounds. Basically the number of bits in the
4599 -- result is the number of bits in the base multiplied by the
4600 -- value of the exponent. If this is big enough that the result
4601 -- definitely won't fit in Long_Long_Integer, return immediately
4602 -- and avoid computing giant bounds.
4604 -- The comparison here is approximate, but conservative, it
4605 -- only clicks on cases that are sure to exceed the bounds.
4607 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
4613 -- If right operand is zero then result is 1
4620 -- High bound comes either from exponentiation of largest
4621 -- positive value to largest exponent value, or from
4622 -- the exponentiation of most negative value to an
4636 if Rhi
mod 2 = 0 then
4639 Hi2
:= Llo
** (Rhi
- 1);
4645 Hi
:= UI_Max
(Hi1
, Hi2
);
4648 -- Result can only be negative if base can be negative
4651 if Rhi
mod 2 = 0 then
4652 Lo
:= Llo
** (Rhi
- 1);
4657 -- Otherwise low bound is minimum ** minimum
4674 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
4675 -- This is the maximum absolute value of the result
4681 -- The result depends only on the sign and magnitude of
4682 -- the right operand, it does not depend on the sign or
4683 -- magnitude of the left operand.
4696 when N_Op_Multiply
=>
4698 -- Possible bounds of multiplication must come from multiplying
4699 -- end values of the input ranges (four possibilities).
4702 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
4703 -- Mark so we can release the Ev values
4705 Ev1
: constant Uint
:= Llo
* Rlo
;
4706 Ev2
: constant Uint
:= Llo
* Rhi
;
4707 Ev3
: constant Uint
:= Lhi
* Rlo
;
4708 Ev4
: constant Uint
:= Lhi
* Rhi
;
4711 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
4712 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
4714 -- Release the Ev values
4716 Release_And_Save
(Mrk
, Lo
, Hi
);
4719 -- Plus operator (affirmation)
4729 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
4730 -- This is the maximum absolute value of the result. Note
4731 -- that the result range does not depend on the sign of the
4738 -- Case of left operand negative, which results in a range
4739 -- of -Maxabs .. 0 for those negative values. If there are
4740 -- no negative values then Lo value of result is always 0.
4746 -- Case of left operand positive
4755 when N_Op_Subtract
=>
4759 -- Nothing else should be possible
4762 raise Program_Error
;
4764 end Compute_Range_For_Arithmetic_Op
;
4766 ----------------------------------
4767 -- Conditional_Statements_Begin --
4768 ----------------------------------
4770 procedure Conditional_Statements_Begin
is
4772 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
4774 -- If stack overflows, kill all checks, that way we know to simply reset
4775 -- the number of saved checks to zero on return. This should never occur
4778 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4781 -- In the normal case, we just make a new stack entry saving the current
4782 -- number of saved checks for a later restore.
4785 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
4787 if Debug_Flag_CC
then
4788 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
4792 end Conditional_Statements_Begin
;
4794 --------------------------------
4795 -- Conditional_Statements_End --
4796 --------------------------------
4798 procedure Conditional_Statements_End
is
4800 pragma Assert
(Saved_Checks_TOS
> 0);
4802 -- If the saved checks stack overflowed, then we killed all checks, so
4803 -- setting the number of saved checks back to zero is correct. This
4804 -- should never occur in practice.
4806 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4807 Num_Saved_Checks
:= 0;
4809 -- In the normal case, restore the number of saved checks from the top
4813 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
4815 if Debug_Flag_CC
then
4816 w
("Conditional_Statements_End: Num_Saved_Checks = ",
4821 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
4822 end Conditional_Statements_End
;
4824 -------------------------
4825 -- Convert_From_Bignum --
4826 -------------------------
4828 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
4829 Loc
: constant Source_Ptr
:= Sloc
(N
);
4832 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4834 -- Construct call From Bignum
4837 Make_Function_Call
(Loc
,
4839 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4840 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4841 end Convert_From_Bignum
;
4843 -----------------------
4844 -- Convert_To_Bignum --
4845 -----------------------
4847 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4848 Loc
: constant Source_Ptr
:= Sloc
(N
);
4851 -- Nothing to do if Bignum already except call Relocate_Node
4853 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4854 return Relocate_Node
(N
);
4856 -- Otherwise construct call to To_Bignum, converting the operand to the
4857 -- required Long_Long_Integer form.
4860 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4862 Make_Function_Call
(Loc
,
4864 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4865 Parameter_Associations
=> New_List
(
4866 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4868 end Convert_To_Bignum
;
4870 ---------------------
4871 -- Determine_Range --
4872 ---------------------
4874 Cache_Size
: constant := 2 ** 10;
4875 type Cache_Index
is range 0 .. Cache_Size
- 1;
4876 -- Determine size of below cache (power of 2 is more efficient)
4878 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4879 Determine_Range_Cache_O
: array (Cache_Index
) of Node_Id
;
4880 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4881 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4882 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4883 Determine_Range_Cache_Lo_R
: array (Cache_Index
) of Ureal
;
4884 Determine_Range_Cache_Hi_R
: array (Cache_Index
) of Ureal
;
4885 -- The above arrays are used to implement a small direct cache for
4886 -- Determine_Range and Determine_Range_R calls. Because of the way these
4887 -- subprograms recursively traces subexpressions, and because overflow
4888 -- checking calls the routine on the way up the tree, a quadratic behavior
4889 -- can otherwise be encountered in large expressions. The cache entry for
4890 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4891 -- by checking the actual node value stored there. The Range_Cache_O array
4892 -- records the setting of Original_Node (N) so that the cache entry does
4893 -- not become stale when the node N is rewritten. The Range_Cache_V array
4894 -- records the setting of Assume_Valid for the cache entry.
4896 procedure Determine_Range
4901 Assume_Valid
: Boolean := False)
4903 Kind
: constant Node_Kind
:= Nkind
(N
);
4906 function Half_Address_Space
return Uint
;
4907 -- The size of half the total addressable memory space in storage units
4908 -- (minus one, so that the size fits in a signed integer whose size is
4909 -- System_Address_Size, which helps in various cases).
4911 ------------------------
4912 -- Half_Address_Space --
4913 ------------------------
4915 function Half_Address_Space
return Uint
is
4917 return Uint_2
** (System_Address_Size
- 1) - 1;
4918 end Half_Address_Space
;
4922 Typ
: Entity_Id
:= Etype
(N
);
4923 -- Type to use, may get reset to base type for possibly invalid entity
4925 Lo_Left
: Uint
:= No_Uint
;
4926 Hi_Left
: Uint
:= No_Uint
;
4927 -- Lo and Hi bounds of left operand
4929 Lo_Right
: Uint
:= No_Uint
;
4930 Hi_Right
: Uint
:= No_Uint
;
4931 -- Lo and Hi bounds of right (or only) operand
4934 -- Temp variable used to hold a bound node
4937 -- High bound of base type of expression
4941 -- Refined values for low and high bounds, after tightening
4944 -- Used in lower level calls to indicate if call succeeded
4946 Cindex
: Cache_Index
;
4947 -- Used to search cache
4952 -- Start of processing for Determine_Range
4955 -- Prevent junk warnings by initializing range variables
4962 -- For temporary constants internally generated to remove side effects
4963 -- we must use the corresponding expression to determine the range of
4964 -- the expression. But note that the expander can also generate
4965 -- constants in other cases, including deferred constants.
4967 if Is_Entity_Name
(N
)
4968 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4969 and then Ekind
(Entity
(N
)) = E_Constant
4970 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4972 if Present
(Expression
(Parent
(Entity
(N
)))) then
4974 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4976 elsif Present
(Full_View
(Entity
(N
))) then
4978 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4979 OK
, Lo
, Hi
, Assume_Valid
);
4987 -- If type is not defined, we can't determine its range
4991 -- We don't deal with anything except discrete types
4993 or else not Is_Discrete_Type
(Typ
)
4995 -- Don't deal with enumerated types with non-standard representation
4997 or else (Is_Enumeration_Type
(Typ
)
4998 and then Present
(Enum_Pos_To_Rep
4999 (Implementation_Base_Type
(Typ
))))
5001 -- Ignore type for which an error has been posted, since range in
5002 -- this case may well be a bogosity deriving from the error. Also
5003 -- ignore if error posted on the reference node.
5005 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
5011 -- For all other cases, we can determine the range
5015 -- If value is compile time known, then the possible range is the one
5016 -- value that we know this expression definitely has.
5018 if Compile_Time_Known_Value
(N
) then
5019 Lo
:= Expr_Value
(N
);
5024 -- Return if already in the cache
5026 Cindex
:= Cache_Index
(N
mod Cache_Size
);
5028 if Determine_Range_Cache_N
(Cindex
) = N
5030 Determine_Range_Cache_O
(Cindex
) = Original_Node
(N
)
5032 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
5034 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
5035 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
5039 -- Otherwise, start by finding the bounds of the type of the expression,
5040 -- the value cannot be outside this range (if it is, then we have an
5041 -- overflow situation, which is a separate check, we are talking here
5042 -- only about the expression value).
5044 -- First a check, never try to find the bounds of a generic type, since
5045 -- these bounds are always junk values, and it is only valid to look at
5046 -- the bounds in an instance.
5048 if Is_Generic_Type
(Typ
) then
5053 -- First step, change to use base type unless we know the value is valid
5055 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
5056 or else Assume_No_Invalid_Values
5057 or else Assume_Valid
5059 -- If this is a known valid constant with a nonstatic value, it may
5060 -- have inherited a narrower subtype from its initial value; use this
5061 -- saved subtype (see sem_ch3.adb).
5063 if Is_Entity_Name
(N
)
5064 and then Ekind
(Entity
(N
)) = E_Constant
5065 and then Present
(Actual_Subtype
(Entity
(N
)))
5067 Typ
:= Actual_Subtype
(Entity
(N
));
5071 Typ
:= Underlying_Type
(Base_Type
(Typ
));
5074 -- Retrieve the base type. Handle the case where the base type is a
5075 -- private enumeration type.
5077 Btyp
:= Base_Type
(Typ
);
5079 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5080 Btyp
:= Full_View
(Btyp
);
5083 -- We use the actual bound unless it is dynamic, in which case use the
5084 -- corresponding base type bound if possible. If we can't get a bound
5085 -- then we figure we can't determine the range (a peculiar case, that
5086 -- perhaps cannot happen, but there is no point in bombing in this
5087 -- optimization circuit).
5089 -- First the low bound
5091 Bound
:= Type_Low_Bound
(Typ
);
5093 if Compile_Time_Known_Value
(Bound
) then
5094 Lo
:= Expr_Value
(Bound
);
5096 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
5097 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
5104 -- Now the high bound
5106 Bound
:= Type_High_Bound
(Typ
);
5108 -- We need the high bound of the base type later on, and this should
5109 -- always be compile time known. Again, it is not clear that this
5110 -- can ever be false, but no point in bombing.
5112 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
5113 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
5121 -- If we have a static subtype, then that may have a tighter bound so
5122 -- use the upper bound of the subtype instead in this case.
5124 if Compile_Time_Known_Value
(Bound
) then
5125 Hi
:= Expr_Value
(Bound
);
5128 -- We may be able to refine this value in certain situations. If any
5129 -- refinement is possible, then Lor and Hir are set to possibly tighter
5130 -- bounds, and OK1 is set to True.
5134 -- Unary operation case
5141 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5144 Compute_Range_For_Arithmetic_Op
5145 (Kind
, Lo_Left
, Hi_Left
, Lo_Right
, Hi_Right
, OK1
, Lor
, Hir
);
5148 -- Binary operation case
5159 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5163 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5167 Compute_Range_For_Arithmetic_Op
5168 (Kind
, Lo_Left
, Hi_Left
, Lo_Right
, Hi_Right
, OK1
, Lor
, Hir
);
5171 -- Attribute reference cases
5173 when N_Attribute_Reference
=>
5174 case Get_Attribute_Id
(Attribute_Name
(N
)) is
5176 -- For Min/Max attributes, we can refine the range using the
5177 -- possible range of values of the attribute expressions.
5183 (First
(Expressions
(N
)),
5184 OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5188 (Next
(First
(Expressions
(N
))),
5189 OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5193 Lor
:= UI_Min
(Lo_Left
, Lo_Right
);
5194 Hir
:= UI_Max
(Hi_Left
, Hi_Right
);
5197 -- For Pos/Val attributes, we can refine the range using the
5198 -- possible range of values of the attribute expression.
5204 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
5206 -- For Length and Range_Length attributes, use the bounds of
5207 -- the (corresponding index) type to refine the range.
5209 when Attribute_Length
5210 | Attribute_Range_Length
5220 Ptyp
:= Etype
(Prefix
(N
));
5221 if Is_Access_Type
(Ptyp
) then
5222 Ptyp
:= Designated_Type
(Ptyp
);
5225 -- For string literal, we know exact value
5227 if Ekind
(Ptyp
) = E_String_Literal_Subtype
then
5229 Lo
:= String_Literal_Length
(Ptyp
);
5230 Hi
:= String_Literal_Length
(Ptyp
);
5234 if Is_Array_Type
(Ptyp
) then
5235 Ityp
:= Get_Index_Subtype
(N
);
5240 -- If the (index) type is a formal type or derived from
5241 -- one, the bounds are not static.
5243 if Is_Generic_Type
(Root_Type
(Ityp
)) then
5249 (Type_Low_Bound
(Ityp
), OK1
, LL
, LU
, Assume_Valid
);
5253 (Type_High_Bound
(Ityp
), OK1
, UL
, UU
, Assume_Valid
);
5256 -- The maximum value for Length is the biggest
5257 -- possible gap between the values of the bounds.
5258 -- But of course, this value cannot be negative.
5260 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
5262 -- For a constrained array, the minimum value for
5263 -- Length is taken from the actual value of the
5264 -- bounds, since the index will be exactly of this
5267 if Is_Constrained
(Ptyp
) then
5268 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
5270 -- For an unconstrained array, the minimum value
5271 -- for length is always zero.
5279 -- Small optimization: the maximum size in storage units
5280 -- an object can have with GNAT is half of the address
5281 -- space, so we can bound the length of an array declared
5282 -- in Interfaces (or its children) because its component
5283 -- size is at least the storage unit and it is meant to
5284 -- be used to interface actual array objects.
5286 if Is_Array_Type
(Ptyp
) then
5288 S
: constant Entity_Id
:= Scope
(Base_Type
(Ptyp
));
5290 if Is_RTU
(S
, Interfaces
)
5291 or else (S
/= Standard_Standard
5292 and then Is_RTU
(Scope
(S
), Interfaces
))
5294 Hir
:= UI_Min
(Hir
, Half_Address_Space
);
5300 -- The maximum default alignment is quite low, but GNAT accepts
5301 -- alignment clauses that are fairly large, but not as large as
5302 -- the maximum size of objects, see below.
5304 when Attribute_Alignment
=>
5306 Hir
:= Half_Address_Space
;
5309 -- The attribute should have been folded if a component clause
5310 -- was specified, so we assume there is none.
5313 | Attribute_First_Bit
5316 Hir
:= UI_From_Int
(System_Storage_Unit
- 1);
5319 -- Likewise about the component clause. Note that Last_Bit
5320 -- yields -1 for a field of size 0 if First_Bit is 0.
5322 when Attribute_Last_Bit
=>
5323 Lor
:= Uint_Minus_1
;
5327 -- Likewise about the component clause for Position. The
5328 -- maximum size in storage units that an object can have
5329 -- with GNAT is half of the address space.
5331 when Attribute_Max_Size_In_Storage_Elements
5332 | Attribute_Position
5335 Hir
:= Half_Address_Space
;
5338 -- These attributes yield a nonnegative value (we do not set
5339 -- the maximum value because it is too large to be useful).
5341 when Attribute_Bit_Position
5342 | Attribute_Component_Size
5343 | Attribute_Object_Size
5345 | Attribute_Value_Size
5351 -- The maximum size is the sum of twice the size of the largest
5352 -- integer for every dimension, rounded up to the next multiple
5353 -- of the maximum alignment, but we add instead of rounding.
5355 when Attribute_Descriptor_Size
=>
5357 Max_Align
: constant Pos
:=
5358 Maximum_Alignment
* System_Storage_Unit
;
5359 Max_Size
: constant Uint
:=
5360 2 * Esize
(Universal_Integer
);
5361 Ndims
: constant Pos
:=
5362 Number_Dimensions
(Etype
(Prefix
(N
)));
5365 Hir
:= Max_Size
* Ndims
+ Max_Align
;
5369 -- No special handling for other attributes for now
5376 when N_Type_Conversion
=>
5377 -- For a type conversion, we can try to refine the range using the
5380 Determine_Range_To_Discrete
5381 (Expression
(N
), OK1
, Lor
, Hir
, Conversion_OK
(N
), Assume_Valid
);
5383 -- Nothing special to do for all other expression kinds
5391 -- At this stage, if OK1 is true, then we know that the actual result of
5392 -- the computed expression is in the range Lor .. Hir. We can use this
5393 -- to restrict the possible range of results.
5397 -- If the refined value of the low bound is greater than the type
5398 -- low bound, then reset it to the more restrictive value. However,
5399 -- we do NOT do this for the case of a modular type where the
5400 -- possible upper bound on the value is above the base type high
5401 -- bound, because that means the result could wrap.
5402 -- Same applies for the lower bound if it is negative.
5404 if Is_Modular_Integer_Type
(Typ
) then
5405 if Lor
> Lo
and then Hir
<= Hbound
then
5409 if Hir
< Hi
and then Lor
>= Uint_0
then
5414 if Lor
> Hi
or else Hir
< Lo
then
5416 -- If the ranges are disjoint, return the computed range.
5418 -- The current range-constraining logic would require returning
5419 -- the base type's bounds. However, this would miss an
5420 -- opportunity to warn about out-of-range values for some cases
5421 -- (e.g. when type's upper bound is equal to base type upper
5424 -- The alternative of always returning the computed values,
5425 -- even when ranges are intersecting, has unwanted effects
5426 -- (mainly useless constraint checks are inserted) in the
5427 -- Enable_Overflow_Check and Apply_Scalar_Range_Check as these
5428 -- bounds have a special interpretation.
5434 -- If the ranges Lor .. Hir and Lo .. Hi intersect, try to
5435 -- refine the returned range.
5448 -- Set cache entry for future call and we are all done
5450 Determine_Range_Cache_N
(Cindex
) := N
;
5451 Determine_Range_Cache_O
(Cindex
) := Original_Node
(N
);
5452 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5453 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
5454 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
5457 -- If any exception occurs, it means that we have some bug in the compiler,
5458 -- possibly triggered by a previous error, or by some unforeseen peculiar
5459 -- occurrence. However, this is only an optimization attempt, so there is
5460 -- really no point in crashing the compiler. Instead we just decide, too
5461 -- bad, we can't figure out a range in this case after all.
5466 -- Debug flag K disables this behavior (useful for debugging)
5468 if Debug_Flag_K
then
5476 end Determine_Range
;
5478 -----------------------
5479 -- Determine_Range_R --
5480 -----------------------
5482 procedure Determine_Range_R
5487 Assume_Valid
: Boolean := False)
5489 Typ
: Entity_Id
:= Etype
(N
);
5490 -- Type to use, may get reset to base type for possibly invalid entity
5494 -- Lo and Hi bounds of left operand
5496 Lo_Right
: Ureal
:= No_Ureal
;
5497 Hi_Right
: Ureal
:= No_Ureal
;
5498 -- Lo and Hi bounds of right (or only) operand
5501 -- Temp variable used to hold a bound node
5504 -- High bound of base type of expression
5508 -- Refined values for low and high bounds, after tightening
5511 -- Used in lower level calls to indicate if call succeeded
5513 Cindex
: Cache_Index
;
5514 -- Used to search cache
5519 function OK_Operands
return Boolean;
5520 -- Used for binary operators. Determines the ranges of the left and
5521 -- right operands, and if they are both OK, returns True, and puts
5522 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
5524 function Round_Machine
(B
: Ureal
) return Ureal
;
5525 -- B is a real bound. Round it to the nearest machine number.
5531 function OK_Operands
return Boolean is
5534 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5541 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5549 function Round_Machine
(B
: Ureal
) return Ureal
is
5551 return Machine_Number
(Typ
, B
, N
);
5554 -- Start of processing for Determine_Range_R
5557 -- Prevent junk warnings by initializing range variables
5564 -- For temporary constants internally generated to remove side effects
5565 -- we must use the corresponding expression to determine the range of
5566 -- the expression. But note that the expander can also generate
5567 -- constants in other cases, including deferred constants.
5569 if Is_Entity_Name
(N
)
5570 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
5571 and then Ekind
(Entity
(N
)) = E_Constant
5572 and then Is_Internal_Name
(Chars
(Entity
(N
)))
5574 if Present
(Expression
(Parent
(Entity
(N
)))) then
5576 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
5578 elsif Present
(Full_View
(Entity
(N
))) then
5580 (Expression
(Parent
(Full_View
(Entity
(N
)))),
5581 OK
, Lo
, Hi
, Assume_Valid
);
5590 -- If type is not defined, we can't determine its range
5592 pragma Warnings
(Off
, "condition can only be True if invalid");
5593 -- Otherwise the compiler warns on the check of Float_Rep below, because
5594 -- there is only one value (see types.ads).
5598 -- We don't deal with anything except IEEE floating-point types
5600 or else not Is_Floating_Point_Type
(Typ
)
5601 or else Float_Rep
(Typ
) /= IEEE_Binary
5603 -- Ignore type for which an error has been posted, since range in
5604 -- this case may well be a bogosity deriving from the error. Also
5605 -- ignore if error posted on the reference node.
5607 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
5609 pragma Warnings
(On
, "condition can only be True if invalid");
5614 -- For all other cases, we can determine the range
5618 -- If value is compile time known, then the possible range is the one
5619 -- value that we know this expression definitely has.
5621 if Compile_Time_Known_Value
(N
) then
5622 Lo
:= Expr_Value_R
(N
);
5627 -- Return if already in the cache
5629 Cindex
:= Cache_Index
(N
mod Cache_Size
);
5631 if Determine_Range_Cache_N
(Cindex
) = N
5633 Determine_Range_Cache_O
(Cindex
) = Original_Node
(N
)
5635 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
5637 Lo
:= Determine_Range_Cache_Lo_R
(Cindex
);
5638 Hi
:= Determine_Range_Cache_Hi_R
(Cindex
);
5642 -- Otherwise, start by finding the bounds of the type of the expression,
5643 -- the value cannot be outside this range (if it is, then we have an
5644 -- overflow situation, which is a separate check, we are talking here
5645 -- only about the expression value).
5647 -- First a check, never try to find the bounds of a generic type, since
5648 -- these bounds are always junk values, and it is only valid to look at
5649 -- the bounds in an instance.
5651 if Is_Generic_Type
(Typ
) then
5656 -- First step, change to use base type unless we know the value is valid
5658 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
5659 or else Assume_No_Invalid_Values
5660 or else Assume_Valid
5664 Typ
:= Underlying_Type
(Base_Type
(Typ
));
5667 -- Retrieve the base type. Handle the case where the base type is a
5670 Btyp
:= Base_Type
(Typ
);
5672 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5673 Btyp
:= Full_View
(Btyp
);
5676 -- We use the actual bound unless it is dynamic, in which case use the
5677 -- corresponding base type bound if possible. If we can't get a bound
5678 -- then we figure we can't determine the range (a peculiar case, that
5679 -- perhaps cannot happen, but there is no point in bombing in this
5680 -- optimization circuit).
5682 -- First the low bound
5684 Bound
:= Type_Low_Bound
(Typ
);
5686 if Compile_Time_Known_Value
(Bound
) then
5687 Lo
:= Expr_Value_R
(Bound
);
5689 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
5690 Lo
:= Expr_Value_R
(Type_Low_Bound
(Btyp
));
5697 -- Now the high bound
5699 Bound
:= Type_High_Bound
(Typ
);
5701 -- We need the high bound of the base type later on, and this should
5702 -- always be compile time known. Again, it is not clear that this
5703 -- can ever be false, but no point in bombing.
5705 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
5706 Hbound
:= Expr_Value_R
(Type_High_Bound
(Btyp
));
5714 -- If we have a static subtype, then that may have a tighter bound so
5715 -- use the upper bound of the subtype instead in this case.
5717 if Compile_Time_Known_Value
(Bound
) then
5718 Hi
:= Expr_Value_R
(Bound
);
5721 -- We may be able to refine this value in certain situations. If any
5722 -- refinement is possible, then Lor and Hir are set to possibly tighter
5723 -- bounds, and OK1 is set to True.
5727 -- For unary plus, result is limited by range of operand
5731 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5733 -- For unary minus, determine range of operand, and negate it
5737 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5744 -- For binary addition, get range of each operand and do the
5745 -- addition to get the result range.
5749 Lor
:= Round_Machine
(Lo_Left
+ Lo_Right
);
5750 Hir
:= Round_Machine
(Hi_Left
+ Hi_Right
);
5753 -- For binary subtraction, get range of each operand and do the worst
5754 -- case subtraction to get the result range.
5756 when N_Op_Subtract
=>
5758 Lor
:= Round_Machine
(Lo_Left
- Hi_Right
);
5759 Hir
:= Round_Machine
(Hi_Left
- Lo_Right
);
5762 -- For multiplication, get range of each operand and do the
5763 -- four multiplications to get the result range.
5765 when N_Op_Multiply
=>
5768 M1
: constant Ureal
:= Round_Machine
(Lo_Left
* Lo_Right
);
5769 M2
: constant Ureal
:= Round_Machine
(Lo_Left
* Hi_Right
);
5770 M3
: constant Ureal
:= Round_Machine
(Hi_Left
* Lo_Right
);
5771 M4
: constant Ureal
:= Round_Machine
(Hi_Left
* Hi_Right
);
5774 Lor
:= UR_Min
(UR_Min
(M1
, M2
), UR_Min
(M3
, M4
));
5775 Hir
:= UR_Max
(UR_Max
(M1
, M2
), UR_Max
(M3
, M4
));
5779 -- For division, consider separately the cases where the right
5780 -- operand is positive or negative. Otherwise, the right operand
5781 -- can be arbitrarily close to zero, so the result is likely to
5782 -- be unbounded in one direction, do not attempt to compute it.
5787 -- Right operand is positive
5789 if Lo_Right
> Ureal_0
then
5791 -- If the low bound of the left operand is negative, obtain
5792 -- the overall low bound by dividing it by the smallest
5793 -- value of the right operand, and otherwise by the largest
5794 -- value of the right operand.
5796 if Lo_Left
< Ureal_0
then
5797 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5799 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5802 -- If the high bound of the left operand is negative, obtain
5803 -- the overall high bound by dividing it by the largest
5804 -- value of the right operand, and otherwise by the
5805 -- smallest value of the right operand.
5807 if Hi_Left
< Ureal_0
then
5808 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5810 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5813 -- Right operand is negative
5815 elsif Hi_Right
< Ureal_0
then
5817 -- If the low bound of the left operand is negative, obtain
5818 -- the overall low bound by dividing it by the largest
5819 -- value of the right operand, and otherwise by the smallest
5820 -- value of the right operand.
5822 if Lo_Left
< Ureal_0
then
5823 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5825 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5828 -- If the high bound of the left operand is negative, obtain
5829 -- the overall high bound by dividing it by the smallest
5830 -- value of the right operand, and otherwise by the
5831 -- largest value of the right operand.
5833 if Hi_Left
< Ureal_0
then
5834 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5836 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5844 when N_Type_Conversion
=>
5846 -- For type conversion from one floating-point type to another, we
5847 -- can refine the range using the converted value.
5849 if Is_Floating_Point_Type
(Etype
(Expression
(N
))) then
5850 Determine_Range_R
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5852 -- When converting an integer to a floating-point type, determine
5853 -- the range in integer first, and then convert the bounds.
5855 elsif Is_Discrete_Type
(Etype
(Expression
(N
))) then
5862 (Expression
(N
), OK1
, Lor_Int
, Hir_Int
, Assume_Valid
);
5865 Lor
:= Round_Machine
(UR_From_Uint
(Lor_Int
));
5866 Hir
:= Round_Machine
(UR_From_Uint
(Hir_Int
));
5874 -- Nothing special to do for all other expression kinds
5882 -- At this stage, if OK1 is true, then we know that the actual result of
5883 -- the computed expression is in the range Lor .. Hir. We can use this
5884 -- to restrict the possible range of results.
5888 -- If the refined value of the low bound is greater than the type
5889 -- low bound, then reset it to the more restrictive value.
5895 -- Similarly, if the refined value of the high bound is less than the
5896 -- value so far, then reset it to the more restrictive value.
5903 -- Set cache entry for future call and we are all done
5905 Determine_Range_Cache_N
(Cindex
) := N
;
5906 Determine_Range_Cache_O
(Cindex
) := Original_Node
(N
);
5907 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5908 Determine_Range_Cache_Lo_R
(Cindex
) := Lo
;
5909 Determine_Range_Cache_Hi_R
(Cindex
) := Hi
;
5912 -- If any exception occurs, it means that we have some bug in the compiler,
5913 -- possibly triggered by a previous error, or by some unforeseen peculiar
5914 -- occurrence. However, this is only an optimization attempt, so there is
5915 -- really no point in crashing the compiler. Instead we just decide, too
5916 -- bad, we can't figure out a range in this case after all.
5921 -- Debug flag K disables this behavior (useful for debugging)
5923 if Debug_Flag_K
then
5931 end Determine_Range_R
;
5933 ---------------------------------
5934 -- Determine_Range_To_Discrete --
5935 ---------------------------------
5937 procedure Determine_Range_To_Discrete
5942 Fixed_Int
: Boolean := False;
5943 Assume_Valid
: Boolean := False)
5945 Typ
: constant Entity_Id
:= Etype
(N
);
5948 -- For a discrete type, simply defer to Determine_Range
5950 if Is_Discrete_Type
(Typ
) then
5951 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
);
5953 -- For a fixed point type treated as an integer, we can determine the
5954 -- range using the Corresponding_Integer_Value of the bounds of the
5955 -- type or base type. This is done by the calls to Expr_Value below.
5957 elsif Is_Fixed_Point_Type
(Typ
) and then Fixed_Int
then
5959 Btyp
, Ftyp
: Entity_Id
;
5963 if Assume_Valid
then
5966 Ftyp
:= Underlying_Type
(Base_Type
(Typ
));
5969 Btyp
:= Base_Type
(Ftyp
);
5971 -- First the low bound
5973 Bound
:= Type_Low_Bound
(Ftyp
);
5975 if Compile_Time_Known_Value
(Bound
) then
5976 Lo
:= Expr_Value
(Bound
);
5978 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
5981 -- Then the high bound
5983 Bound
:= Type_High_Bound
(Ftyp
);
5985 if Compile_Time_Known_Value
(Bound
) then
5986 Hi
:= Expr_Value
(Bound
);
5988 Hi
:= Expr_Value
(Type_High_Bound
(Btyp
));
5994 -- For a floating-point type, we can determine the range in real first,
5995 -- and then convert the bounds using UR_To_Uint, which correctly rounds
5996 -- away from zero when half way between two integers, as required by
5997 -- normal Ada 95 rounding semantics. But this is only possible because
5998 -- GNATprove's analysis rules out the possibility of a NaN or infinite.
6000 elsif GNATprove_Mode
and then Is_Floating_Point_Type
(Typ
) then
6002 Lo_Real
, Hi_Real
: Ureal
;
6005 Determine_Range_R
(N
, OK
, Lo_Real
, Hi_Real
, Assume_Valid
);
6008 Lo
:= UR_To_Uint
(Lo_Real
);
6009 Hi
:= UR_To_Uint
(Hi_Real
);
6021 end Determine_Range_To_Discrete
;
6023 ------------------------------------
6024 -- Discriminant_Checks_Suppressed --
6025 ------------------------------------
6027 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6030 if Is_Unchecked_Union
(E
) then
6032 elsif Checks_May_Be_Suppressed
(E
) then
6033 return Is_Check_Suppressed
(E
, Discriminant_Check
);
6037 return Scope_Suppress
.Suppress
(Discriminant_Check
);
6038 end Discriminant_Checks_Suppressed
;
6040 --------------------------------
6041 -- Division_Checks_Suppressed --
6042 --------------------------------
6044 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6046 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6047 return Is_Check_Suppressed
(E
, Division_Check
);
6049 return Scope_Suppress
.Suppress
(Division_Check
);
6051 end Division_Checks_Suppressed
;
6053 --------------------------------------
6054 -- Duplicated_Tag_Checks_Suppressed --
6055 --------------------------------------
6057 function Duplicated_Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6059 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6060 return Is_Check_Suppressed
(E
, Duplicated_Tag_Check
);
6062 return Scope_Suppress
.Suppress
(Duplicated_Tag_Check
);
6064 end Duplicated_Tag_Checks_Suppressed
;
6066 -----------------------------------
6067 -- Elaboration_Checks_Suppressed --
6068 -----------------------------------
6070 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6072 -- The complication in this routine is that if we are in the dynamic
6073 -- model of elaboration, we also check All_Checks, since All_Checks
6074 -- does not set Elaboration_Check explicitly.
6077 if Kill_Elaboration_Checks
(E
) then
6080 elsif Checks_May_Be_Suppressed
(E
) then
6081 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
6084 elsif Dynamic_Elaboration_Checks
then
6085 return Is_Check_Suppressed
(E
, All_Checks
);
6093 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
6096 elsif Dynamic_Elaboration_Checks
then
6097 return Scope_Suppress
.Suppress
(All_Checks
);
6102 end Elaboration_Checks_Suppressed
;
6104 ---------------------------
6105 -- Enable_Overflow_Check --
6106 ---------------------------
6108 procedure Enable_Overflow_Check
(N
: Node_Id
) is
6109 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6110 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6118 Do_Ovflow_Check
: Boolean;
6121 if Debug_Flag_CC
then
6122 w
("Enable_Overflow_Check for node ", Int
(N
));
6123 Write_Str
(" Source location = ");
6128 -- No check if overflow checks suppressed for type of node
6130 if Overflow_Checks_Suppressed
(Etype
(N
)) then
6133 -- Nothing to do for unsigned integer types, which do not overflow
6135 elsif Is_Modular_Integer_Type
(Typ
) then
6139 -- This is the point at which processing for STRICT mode diverges
6140 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
6141 -- probably more extreme that it needs to be, but what is going on here
6142 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
6143 -- to leave the processing for STRICT mode untouched. There were
6144 -- two reasons for this. First it avoided any incompatible change of
6145 -- behavior. Second, it guaranteed that STRICT mode continued to be
6148 -- The big difference is that in STRICT mode there is a fair amount of
6149 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
6150 -- know that no check is needed. We skip all that in the two new modes,
6151 -- since really overflow checking happens over a whole subtree, and we
6152 -- do the corresponding optimizations later on when applying the checks.
6154 if Mode
in Minimized_Or_Eliminated
then
6155 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
6156 and then not (Is_Entity_Name
(N
)
6157 and then Overflow_Checks_Suppressed
(Entity
(N
)))
6159 Activate_Overflow_Check
(N
);
6162 if Debug_Flag_CC
then
6163 w
("Minimized/Eliminated mode");
6169 -- Remainder of processing is for STRICT case, and is unchanged from
6170 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
6172 -- Nothing to do if the range of the result is known OK. We skip this
6173 -- for conversions, since the caller already did the check, and in any
6174 -- case the condition for deleting the check for a type conversion is
6177 if Nkind
(N
) /= N_Type_Conversion
then
6178 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
6180 -- Note in the test below that we assume that the range is not OK
6181 -- if a bound of the range is equal to that of the type. That's not
6182 -- quite accurate but we do this for the following reasons:
6184 -- a) The way that Determine_Range works, it will typically report
6185 -- the bounds of the value as being equal to the bounds of the
6186 -- type, because it either can't tell anything more precise, or
6187 -- does not think it is worth the effort to be more precise.
6189 -- b) It is very unusual to have a situation in which this would
6190 -- generate an unnecessary overflow check (an example would be
6191 -- a subtype with a range 0 .. Integer'Last - 1 to which the
6192 -- literal value one is added).
6194 -- c) The alternative is a lot of special casing in this routine
6195 -- which would partially duplicate Determine_Range processing.
6198 Do_Ovflow_Check
:= True;
6200 -- Note that the following checks are quite deliberately > and <
6201 -- rather than >= and <= as explained above.
6203 if Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
6205 Hi
< Expr_Value
(Type_High_Bound
(Typ
))
6207 Do_Ovflow_Check
:= False;
6209 -- Despite the comments above, it is worth dealing specially with
6210 -- division. The only case where integer division can overflow is
6211 -- (largest negative number) / (-1). So we will do an extra range
6212 -- analysis to see if this is possible.
6214 elsif Nkind
(N
) = N_Op_Divide
then
6216 (Left_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6218 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
6219 Do_Ovflow_Check
:= False;
6223 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6225 if OK
and then (Lo
> Uint_Minus_1
6229 Do_Ovflow_Check
:= False;
6233 -- Likewise for Abs/Minus, the only case where the operation can
6234 -- overflow is when the operand is the largest negative number.
6236 elsif Nkind
(N
) in N_Op_Abs | N_Op_Minus
then
6238 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6240 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
6241 Do_Ovflow_Check
:= False;
6245 -- If no overflow check required, we are done
6247 if not Do_Ovflow_Check
then
6248 if Debug_Flag_CC
then
6249 w
("No overflow check required");
6257 -- If not in optimizing mode, set flag and we are done. We are also done
6258 -- (and just set the flag) if the type is not a discrete type, since it
6259 -- is not worth the effort to eliminate checks for other than discrete
6260 -- types. In addition, we take this same path if we have stored the
6261 -- maximum number of checks possible already (a very unlikely situation,
6262 -- but we do not want to blow up).
6264 if Optimization_Level
= 0
6265 or else not Is_Discrete_Type
(Etype
(N
))
6266 or else Num_Saved_Checks
= Saved_Checks
'Last
6268 Activate_Overflow_Check
(N
);
6270 if Debug_Flag_CC
then
6271 w
("Optimization off");
6277 -- Otherwise evaluate and check the expression
6282 Target_Type
=> Empty
,
6288 if Debug_Flag_CC
then
6289 w
("Called Find_Check");
6293 w
(" Check_Num = ", Chk
);
6294 w
(" Ent = ", Int
(Ent
));
6295 Write_Str
(" Ofs = ");
6300 -- If check is not of form to optimize, then set flag and we are done
6303 Activate_Overflow_Check
(N
);
6307 -- If check is already performed, then return without setting flag
6310 if Debug_Flag_CC
then
6311 w
("Check suppressed!");
6317 -- Here we will make a new entry for the new check
6319 Activate_Overflow_Check
(N
);
6320 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
6321 Saved_Checks
(Num_Saved_Checks
) :=
6326 Target_Type
=> Empty
);
6328 if Debug_Flag_CC
then
6329 w
("Make new entry, check number = ", Num_Saved_Checks
);
6330 w
(" Entity = ", Int
(Ent
));
6331 Write_Str
(" Offset = ");
6333 w
(" Check_Type = O");
6334 w
(" Target_Type = Empty");
6337 -- If we get an exception, then something went wrong, probably because of
6338 -- an error in the structure of the tree due to an incorrect program. Or
6339 -- it may be a bug in the optimization circuit. In either case the safest
6340 -- thing is simply to set the check flag unconditionally.
6344 Activate_Overflow_Check
(N
);
6346 if Debug_Flag_CC
then
6347 w
(" exception occurred, overflow flag set");
6351 end Enable_Overflow_Check
;
6353 ------------------------
6354 -- Enable_Range_Check --
6355 ------------------------
6357 procedure Enable_Range_Check
(N
: Node_Id
) is
6366 -- Return if unchecked type conversion with range check killed. In this
6367 -- case we never set the flag (that's what Kill_Range_Check is about).
6369 if Nkind
(N
) = N_Unchecked_Type_Conversion
6370 and then Kill_Range_Check
(N
)
6375 -- Do not set range check flag if parent is assignment statement or
6376 -- object declaration with Suppress_Assignment_Checks flag set.
6378 if Nkind
(Parent
(N
)) in N_Assignment_Statement | N_Object_Declaration
6379 and then Suppress_Assignment_Checks
(Parent
(N
))
6384 -- Check for various cases where we should suppress the range check
6386 -- No check if range checks suppressed for type of node
6388 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
6391 -- No check if node is an entity name, and range checks are suppressed
6392 -- for this entity, or for the type of this entity.
6394 elsif Is_Entity_Name
(N
)
6395 and then (Range_Checks_Suppressed
(Entity
(N
))
6396 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
6400 -- No checks if index of array, and index checks are suppressed for
6401 -- the array object or the type of the array.
6403 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
6405 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
6407 if Is_Entity_Name
(Pref
)
6408 and then Index_Checks_Suppressed
(Entity
(Pref
))
6411 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
6417 -- Debug trace output
6419 if Debug_Flag_CC
then
6420 w
("Enable_Range_Check for node ", Int
(N
));
6421 Write_Str
(" Source location = ");
6426 -- If not in optimizing mode, set flag and we are done. We are also done
6427 -- (and just set the flag) if the type is not a discrete type, since it
6428 -- is not worth the effort to eliminate checks for other than discrete
6429 -- types. In addition, we take this same path if we have stored the
6430 -- maximum number of checks possible already (a very unlikely situation,
6431 -- but we do not want to blow up).
6433 if Optimization_Level
= 0
6434 or else No
(Etype
(N
))
6435 or else not Is_Discrete_Type
(Etype
(N
))
6436 or else Num_Saved_Checks
= Saved_Checks
'Last
6438 Activate_Range_Check
(N
);
6440 if Debug_Flag_CC
then
6441 w
("Optimization off");
6447 -- Otherwise find out the target type
6451 -- For assignment, use left side subtype
6453 if Nkind
(P
) = N_Assignment_Statement
6454 and then Expression
(P
) = N
6456 Ttyp
:= Etype
(Name
(P
));
6458 -- For indexed component, use subscript subtype
6460 elsif Nkind
(P
) = N_Indexed_Component
then
6467 Atyp
:= Etype
(Prefix
(P
));
6469 if Is_Access_Type
(Atyp
) then
6470 Atyp
:= Designated_Type
(Atyp
);
6472 -- If the prefix is an access to an unconstrained array,
6473 -- perform check unconditionally: it depends on the bounds of
6474 -- an object and we cannot currently recognize whether the test
6475 -- may be redundant.
6477 if not Is_Constrained
(Atyp
) then
6478 Activate_Range_Check
(N
);
6482 -- Ditto if prefix is simply an unconstrained array. We used
6483 -- to think this case was OK, if the prefix was not an explicit
6484 -- dereference, but we have now seen a case where this is not
6485 -- true, so it is safer to just suppress the optimization in this
6486 -- case. The back end is getting better at eliminating redundant
6487 -- checks in any case, so the loss won't be important.
6489 elsif Is_Array_Type
(Atyp
)
6490 and then not Is_Constrained
(Atyp
)
6492 Activate_Range_Check
(N
);
6496 Indx
:= First_Index
(Atyp
);
6497 Subs
:= First
(Expressions
(P
));
6500 Ttyp
:= Etype
(Indx
);
6509 -- For now, ignore all other cases, they are not so interesting
6512 if Debug_Flag_CC
then
6513 w
(" target type not found, flag set");
6516 Activate_Range_Check
(N
);
6520 -- Evaluate and check the expression
6525 Target_Type
=> Ttyp
,
6531 if Debug_Flag_CC
then
6532 w
("Called Find_Check");
6533 w
("Target_Typ = ", Int
(Ttyp
));
6537 w
(" Check_Num = ", Chk
);
6538 w
(" Ent = ", Int
(Ent
));
6539 Write_Str
(" Ofs = ");
6544 -- If check is not of form to optimize, then set flag and we are done
6547 if Debug_Flag_CC
then
6548 w
(" expression not of optimizable type, flag set");
6551 Activate_Range_Check
(N
);
6555 -- If check is already performed, then return without setting flag
6558 if Debug_Flag_CC
then
6559 w
("Check suppressed!");
6565 -- Here we will make a new entry for the new check
6567 Activate_Range_Check
(N
);
6568 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
6569 Saved_Checks
(Num_Saved_Checks
) :=
6574 Target_Type
=> Ttyp
);
6576 if Debug_Flag_CC
then
6577 w
("Make new entry, check number = ", Num_Saved_Checks
);
6578 w
(" Entity = ", Int
(Ent
));
6579 Write_Str
(" Offset = ");
6581 w
(" Check_Type = R");
6582 w
(" Target_Type = ", Int
(Ttyp
));
6583 pg
(Union_Id
(Ttyp
));
6586 -- If we get an exception, then something went wrong, probably because of
6587 -- an error in the structure of the tree due to an incorrect program. Or
6588 -- it may be a bug in the optimization circuit. In either case the safest
6589 -- thing is simply to set the check flag unconditionally.
6593 Activate_Range_Check
(N
);
6595 if Debug_Flag_CC
then
6596 w
(" exception occurred, range flag set");
6600 end Enable_Range_Check
;
6606 procedure Ensure_Valid
6608 Holes_OK
: Boolean := False;
6609 Related_Id
: Entity_Id
:= Empty
;
6610 Is_Low_Bound
: Boolean := False;
6611 Is_High_Bound
: Boolean := False)
6613 Typ
: constant Entity_Id
:= Etype
(Expr
);
6616 -- Ignore call if we are not doing any validity checking
6618 if not Validity_Checks_On
then
6621 -- Ignore call if range or validity checks suppressed on entity or type
6623 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
6626 -- No check required if expression is from the expander, we assume the
6627 -- expander will generate whatever checks are needed. Note that this is
6628 -- not just an optimization, it avoids infinite recursions.
6630 -- Unchecked conversions must be checked, unless they are initialized
6631 -- scalar values, as in a component assignment in an init proc.
6633 -- In addition, we force a check if Force_Validity_Checks is set
6635 elsif not Comes_From_Source
(Expr
)
6637 (Nkind
(Expr
) = N_Identifier
6638 and then Present
(Renamed_Entity_Or_Object
(Entity
(Expr
)))
6640 Comes_From_Source
(Renamed_Entity_Or_Object
(Entity
(Expr
))))
6641 and then not Force_Validity_Checks
6642 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
6643 or else Kill_Range_Check
(Expr
))
6647 -- No check required if expression is known to have valid value
6649 elsif Expr_Known_Valid
(Expr
) then
6652 -- No check needed within a generated predicate function. Validity
6653 -- of input value will have been checked earlier.
6655 elsif Ekind
(Current_Scope
) = E_Function
6656 and then Is_Predicate_Function
(Current_Scope
)
6660 -- Ignore case of enumeration with holes where the flag is set not to
6661 -- worry about holes, since no special validity check is needed
6663 elsif Is_Enumeration_Type
(Typ
)
6664 and then Has_Non_Standard_Rep
(Typ
)
6669 -- No check required on the left-hand side of an assignment
6671 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
6672 and then Expr
= Name
(Parent
(Expr
))
6676 -- No check on a universal real constant. The context will eventually
6677 -- convert it to a machine number for some target type, or report an
6680 elsif Nkind
(Expr
) = N_Real_Literal
6681 and then Etype
(Expr
) = Universal_Real
6685 -- If the expression denotes a component of a packed boolean array,
6686 -- no possible check applies. We ignore the old ACATS chestnuts that
6687 -- involve Boolean range True..True.
6689 -- Note: validity checks are generated for expressions that yield a
6690 -- scalar type, when it is possible to create a value that is outside of
6691 -- the type. If this is a one-bit boolean no such value exists. This is
6692 -- an optimization, and it also prevents compiler blowing up during the
6693 -- elaboration of improperly expanded packed array references.
6695 elsif Nkind
(Expr
) = N_Indexed_Component
6696 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
6697 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
6701 -- For an expression with actions, we want to insert the validity check
6702 -- on the final Expression.
6704 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
6705 Ensure_Valid
(Expression
(Expr
));
6708 -- An annoying special case. If this is an out parameter of a scalar
6709 -- type, then the value is not going to be accessed, therefore it is
6710 -- inappropriate to do any validity check at the call site. Likewise
6711 -- if the parameter is passed by reference.
6714 -- Only need to worry about scalar types
6716 if Is_Scalar_Type
(Typ
) then
6726 -- Find actual argument (which may be a parameter association)
6727 -- and the parent of the actual argument (the call statement)
6732 if Nkind
(P
) = N_Parameter_Association
then
6737 -- If this is an indirect or dispatching call, get signature
6738 -- from the subprogram type.
6740 if Nkind
(P
) in N_Entry_Call_Statement
6742 | N_Procedure_Call_Statement
6744 E
:= Get_Called_Entity
(P
);
6745 L
:= Parameter_Associations
(P
);
6747 -- Only need to worry if there are indeed actuals, and if
6748 -- this could be a subprogram call, otherwise we cannot get
6749 -- a match (either we are not an argument, or the mode of
6750 -- the formal is not OUT). This test also filters out the
6753 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
6755 -- This is the loop through parameters, looking for an
6756 -- OUT parameter for which we are the argument.
6758 F
:= First_Formal
(E
);
6760 while Present
(F
) loop
6762 and then (Ekind
(F
) = E_Out_Parameter
6763 or else Mechanism
(F
) = By_Reference
)
6777 -- If this is a boolean expression, only its elementary operands need
6778 -- checking: if they are valid, a boolean or short-circuit operation
6779 -- with them will be valid as well.
6781 if Base_Type
(Typ
) = Standard_Boolean
6783 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
6788 -- If we fall through, a validity check is required
6790 Insert_Valid_Check
(Expr
, Related_Id
, Is_Low_Bound
, Is_High_Bound
);
6792 if Is_Entity_Name
(Expr
)
6793 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
6795 Set_Is_Known_Valid
(Entity
(Expr
));
6799 ----------------------
6800 -- Expr_Known_Valid --
6801 ----------------------
6803 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
6804 Typ
: constant Entity_Id
:= Etype
(Expr
);
6807 -- Non-scalar types are always considered valid, since they never give
6808 -- rise to the issues of erroneous or bounded error behavior that are
6809 -- the concern. In formal reference manual terms the notion of validity
6810 -- only applies to scalar types. Note that even when packed arrays are
6811 -- represented using modular types, they are still arrays semantically,
6812 -- so they are also always valid (in particular, the unused bits can be
6813 -- random rubbish without affecting the validity of the array value).
6815 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Impl_Type
(Typ
) then
6818 -- If no validity checking, then everything is considered valid
6820 elsif not Validity_Checks_On
then
6823 -- Floating-point types are considered valid unless floating-point
6824 -- validity checks have been specifically turned on.
6826 elsif Is_Floating_Point_Type
(Typ
)
6827 and then not Validity_Check_Floating_Point
6831 -- If the expression is the value of an object that is known to be
6832 -- valid, then clearly the expression value itself is valid.
6834 elsif Is_Entity_Name
(Expr
)
6835 and then Is_Known_Valid
(Entity
(Expr
))
6837 -- Exclude volatile variables
6839 and then not Treat_As_Volatile
(Entity
(Expr
))
6843 -- References to discriminants are always considered valid. The value
6844 -- of a discriminant gets checked when the object is built. Within the
6845 -- record, we consider it valid, and it is important to do so, since
6846 -- otherwise we can try to generate bogus validity checks which
6847 -- reference discriminants out of scope. Discriminants of concurrent
6848 -- types are excluded for the same reason.
6850 elsif Is_Entity_Name
(Expr
)
6851 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
6855 -- If the type is one for which all values are known valid, then we are
6856 -- sure that the value is valid except in the slightly odd case where
6857 -- the expression is a reference to a variable whose size has been
6858 -- explicitly set to a value greater than the object size.
6860 elsif Is_Known_Valid
(Typ
) then
6861 if Is_Entity_Name
(Expr
)
6862 and then Ekind
(Entity
(Expr
)) = E_Variable
6863 and then Known_Esize
(Entity
(Expr
))
6864 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
6871 -- Integer and character literals always have valid values, where
6872 -- appropriate these will be range checked in any case.
6874 elsif Nkind
(Expr
) in N_Integer_Literal | N_Character_Literal
then
6877 -- If we have a type conversion or a qualification of a known valid
6878 -- value, then the result will always be valid.
6880 elsif Nkind
(Expr
) in N_Type_Conversion | N_Qualified_Expression
then
6881 return Expr_Known_Valid
(Expression
(Expr
));
6883 -- Case of expression is a non-floating-point operator. In this case we
6884 -- can assume the result is valid the generated code for the operator
6885 -- will include whatever checks are needed (e.g. range checks) to ensure
6886 -- validity. This assumption does not hold for the floating-point case,
6887 -- since floating-point operators can generate Infinite or NaN results
6888 -- which are considered invalid.
6890 -- Historical note: in older versions, the exemption of floating-point
6891 -- types from this assumption was done only in cases where the parent
6892 -- was an assignment, function call or parameter association. Presumably
6893 -- the idea was that in other contexts, the result would be checked
6894 -- elsewhere, but this list of cases was missing tests (at least the
6895 -- N_Object_Declaration case, as shown by a reported missing validity
6896 -- check), and it is not clear why function calls but not procedure
6897 -- calls were tested for. It really seems more accurate and much
6898 -- safer to recognize that expressions which are the result of a
6899 -- floating-point operator can never be assumed to be valid.
6901 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
6904 -- The result of a membership test is always valid, since it is true or
6905 -- false, there are no other possibilities.
6907 elsif Nkind
(Expr
) in N_Membership_Test
then
6910 -- For all other cases, we do not know the expression is valid
6915 end Expr_Known_Valid
;
6921 procedure Find_Check
6923 Check_Type
: Character;
6924 Target_Type
: Entity_Id
;
6925 Entry_OK
: out Boolean;
6926 Check_Num
: out Nat
;
6927 Ent
: out Entity_Id
;
6930 function Within_Range_Of
6931 (Target_Type
: Entity_Id
;
6932 Check_Type
: Entity_Id
) return Boolean;
6933 -- Given a requirement for checking a range against Target_Type, and
6934 -- and a range Check_Type against which a check has already been made,
6935 -- determines if the check against check type is sufficient to ensure
6936 -- that no check against Target_Type is required.
6938 ---------------------
6939 -- Within_Range_Of --
6940 ---------------------
6942 function Within_Range_Of
6943 (Target_Type
: Entity_Id
;
6944 Check_Type
: Entity_Id
) return Boolean
6947 if Target_Type
= Check_Type
then
6952 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
6953 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
6954 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
6955 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
6959 or else (Compile_Time_Known_Value
(Tlo
)
6961 Compile_Time_Known_Value
(Clo
)
6963 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
6966 or else (Compile_Time_Known_Value
(Thi
)
6968 Compile_Time_Known_Value
(Chi
)
6970 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
6978 end Within_Range_Of
;
6980 -- Start of processing for Find_Check
6983 -- Establish default, in case no entry is found
6987 -- Case of expression is simple entity reference
6989 if Is_Entity_Name
(Expr
) then
6990 Ent
:= Entity
(Expr
);
6993 -- Case of expression is entity + known constant
6995 elsif Nkind
(Expr
) = N_Op_Add
6996 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6997 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6999 Ent
:= Entity
(Left_Opnd
(Expr
));
7000 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
7002 -- Case of expression is entity - known constant
7004 elsif Nkind
(Expr
) = N_Op_Subtract
7005 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
7006 and then Is_Entity_Name
(Left_Opnd
(Expr
))
7008 Ent
:= Entity
(Left_Opnd
(Expr
));
7009 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
7011 -- Any other expression is not of the right form
7020 -- Come here with expression of appropriate form, check if entity is an
7021 -- appropriate one for our purposes.
7023 if (Ekind
(Ent
) = E_Variable
7024 or else Is_Constant_Object
(Ent
))
7025 and then not Is_Library_Level_Entity
(Ent
)
7033 -- See if there is matching check already
7035 for J
in reverse 1 .. Num_Saved_Checks
loop
7037 SC
: Saved_Check
renames Saved_Checks
(J
);
7039 if SC
.Killed
= False
7040 and then SC
.Entity
= Ent
7041 and then SC
.Offset
= Ofs
7042 and then SC
.Check_Type
= Check_Type
7043 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
7051 -- If we fall through entry was not found
7056 ---------------------------------
7057 -- Generate_Discriminant_Check --
7058 ---------------------------------
7060 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
7061 Loc
: constant Source_Ptr
:= Sloc
(N
);
7062 Pref
: constant Node_Id
:= Prefix
(N
);
7063 Sel
: constant Node_Id
:= Selector_Name
(N
);
7065 Orig_Comp
: constant Entity_Id
:=
7066 Original_Record_Component
(Entity
(Sel
));
7067 -- The original component to be checked
7069 Discr_Fct
: constant Entity_Id
:=
7070 Discriminant_Checking_Func
(Orig_Comp
);
7071 -- The discriminant checking function
7074 -- One discriminant to be checked in the type
7076 Real_Discr
: Entity_Id
;
7077 -- Actual discriminant in the call
7079 Pref_Type
: Entity_Id
;
7080 -- Type of relevant prefix (ignoring private/access stuff)
7083 -- List of arguments for function call
7086 -- Keep track of the formal corresponding to the actual we build for
7087 -- each discriminant, in order to be able to perform the necessary type
7091 -- Selected component reference for checking function argument
7094 Pref_Type
:= Etype
(Pref
);
7096 -- Force evaluation of the prefix, so that it does not get evaluated
7097 -- twice (once for the check, once for the actual reference). Such a
7098 -- double evaluation is always a potential source of inefficiency, and
7099 -- is functionally incorrect in the volatile case, or when the prefix
7100 -- may have side effects. A nonvolatile entity or a component of a
7101 -- nonvolatile entity requires no evaluation.
7103 if Is_Entity_Name
(Pref
) then
7104 if Treat_As_Volatile
(Entity
(Pref
)) then
7105 Force_Evaluation
(Pref
, Name_Req
=> True);
7108 elsif Treat_As_Volatile
(Etype
(Pref
)) then
7109 Force_Evaluation
(Pref
, Name_Req
=> True);
7111 elsif Nkind
(Pref
) = N_Selected_Component
7112 and then Is_Entity_Name
(Prefix
(Pref
))
7117 Force_Evaluation
(Pref
, Name_Req
=> True);
7120 -- For a tagged type, use the scope of the original component to
7121 -- obtain the type, because ???
7123 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
7124 Pref_Type
:= Scope
(Orig_Comp
);
7126 -- For an untagged derived type, use the discriminants of the parent
7127 -- which have been renamed in the derivation, possibly by a one-to-many
7128 -- discriminant constraint. For untagged type, initially get the Etype
7132 if Is_Derived_Type
(Pref_Type
)
7133 and then Number_Discriminants
(Pref_Type
) /=
7134 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
7136 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
7140 -- We definitely should have a checking function, This routine should
7141 -- not be called if no discriminant checking function is present.
7143 pragma Assert
(Present
(Discr_Fct
));
7145 -- Create the list of the actual parameters for the call. This list
7146 -- is the list of the discriminant fields of the record expression to
7147 -- be discriminant checked.
7150 Formal
:= First_Formal
(Discr_Fct
);
7151 Discr
:= First_Discriminant
(Pref_Type
);
7152 while Present
(Discr
) loop
7154 -- If we have a corresponding discriminant field, and a parent
7155 -- subtype is present, then we want to use the corresponding
7156 -- discriminant since this is the one with the useful value.
7158 if Present
(Corresponding_Discriminant
(Discr
))
7159 and then Ekind
(Pref_Type
) = E_Record_Type
7160 and then Present
(Parent_Subtype
(Pref_Type
))
7162 Real_Discr
:= Corresponding_Discriminant
(Discr
);
7164 Real_Discr
:= Discr
;
7167 -- Construct the reference to the discriminant
7170 Make_Selected_Component
(Loc
,
7172 Unchecked_Convert_To
(Pref_Type
,
7173 Duplicate_Subexpr
(Pref
)),
7174 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
7176 -- Manually analyze and resolve this selected component. We really
7177 -- want it just as it appears above, and do not want the expander
7178 -- playing discriminal games etc with this reference. Then we append
7179 -- the argument to the list we are gathering.
7181 Set_Etype
(Scomp
, Etype
(Real_Discr
));
7182 Set_Analyzed
(Scomp
, True);
7183 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
7185 Next_Formal_With_Extras
(Formal
);
7186 Next_Discriminant
(Discr
);
7189 -- Now build and insert the call
7192 Make_Raise_Constraint_Error
(Loc
,
7194 Make_Function_Call
(Loc
,
7195 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
7196 Parameter_Associations
=> Args
),
7197 Reason
=> CE_Discriminant_Check_Failed
));
7198 end Generate_Discriminant_Check
;
7200 ---------------------------
7201 -- Generate_Index_Checks --
7202 ---------------------------
7204 procedure Generate_Index_Checks
7206 Checks_Generated
: out Dimension_Set
)
7209 function Entity_Of_Prefix
return Entity_Id
;
7210 -- Returns the entity of the prefix of N (or Empty if not found)
7212 ----------------------
7213 -- Entity_Of_Prefix --
7214 ----------------------
7216 function Entity_Of_Prefix
return Entity_Id
is
7221 while not Is_Entity_Name
(P
) loop
7222 if Nkind
(P
) not in N_Selected_Component | N_Indexed_Component
then
7230 end Entity_Of_Prefix
;
7234 Loc
: constant Source_Ptr
:= Sloc
(N
);
7235 A
: constant Node_Id
:= Prefix
(N
);
7236 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
7239 -- Start of processing for Generate_Index_Checks
7242 Checks_Generated
.Elements
:= (others => False);
7244 -- Ignore call if the prefix is not an array since we have a serious
7245 -- error in the sources. Ignore it also if index checks are suppressed
7246 -- for array object or type.
7248 if not Is_Array_Type
(Etype
(A
))
7249 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
7250 or else Index_Checks_Suppressed
(Etype
(A
))
7254 -- The indexed component we are dealing with contains 'Loop_Entry in its
7255 -- prefix. This case arises when analysis has determined that constructs
7258 -- Prefix'Loop_Entry (Expr)
7259 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
7261 -- require rewriting for error detection purposes. A side effect of this
7262 -- action is the generation of index checks that mention 'Loop_Entry.
7263 -- Delay the generation of the check until 'Loop_Entry has been properly
7264 -- expanded. This is done in Expand_Loop_Entry_Attributes.
7266 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
7267 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
7272 -- Generate a raise of constraint error with the appropriate reason and
7273 -- a condition of the form:
7275 -- Base_Type (Sub) not in Array'Range (Subscript)
7277 -- Note that the reason we generate the conversion to the base type here
7278 -- is that we definitely want the range check to take place, even if it
7279 -- looks like the subtype is OK. Optimization considerations that allow
7280 -- us to omit the check have already been taken into account in the
7281 -- setting of the Do_Range_Check flag earlier on.
7283 Sub
:= First
(Expressions
(N
));
7285 -- Handle string literals
7287 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
7288 if Do_Range_Check
(Sub
) then
7289 Set_Do_Range_Check
(Sub
, False);
7291 -- For string literals we obtain the bounds of the string from the
7292 -- associated subtype.
7295 Make_Raise_Constraint_Error
(Loc
,
7299 Convert_To
(Base_Type
(Etype
(Sub
)),
7300 Duplicate_Subexpr_Move_Checks
(Sub
)),
7302 Make_Attribute_Reference
(Loc
,
7303 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
7304 Attribute_Name
=> Name_Range
)),
7305 Reason
=> CE_Index_Check_Failed
));
7307 Checks_Generated
.Elements
(1) := True;
7321 A_Idx
:= First_Index
(Etype
(A
));
7323 while Present
(Sub
) loop
7324 if Do_Range_Check
(Sub
) then
7325 Set_Do_Range_Check
(Sub
, False);
7327 -- Force evaluation except for the case of a simple name of
7328 -- a nonvolatile entity.
7330 if not Is_Entity_Name
(Sub
)
7331 or else Treat_As_Volatile
(Entity
(Sub
))
7333 Force_Evaluation
(Sub
);
7336 if Nkind
(A_Idx
) = N_Range
then
7339 elsif Nkind
(A_Idx
) in N_Identifier | N_Expanded_Name
then
7340 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
7342 if Nkind
(A_Range
) = N_Subtype_Indication
then
7343 A_Range
:= Range_Expression
(Constraint
(A_Range
));
7346 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
7347 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
7350 -- For array objects with constant bounds we can generate
7351 -- the index check using the bounds of the type of the index
7354 and then Ekind
(A_Ent
) = E_Variable
7355 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
7356 and then Is_Constant_Bound
(High_Bound
(A_Range
))
7359 Make_Attribute_Reference
(Loc
,
7361 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
7362 Attribute_Name
=> Name_Range
);
7364 -- For arrays with non-constant bounds we cannot generate
7365 -- the index check using the bounds of the type of the index
7366 -- since it may reference discriminants of some enclosing
7367 -- type. We obtain the bounds directly from the prefix
7374 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
7378 Make_Attribute_Reference
(Loc
,
7380 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
7381 Attribute_Name
=> Name_Range
,
7382 Expressions
=> Num
);
7386 Make_Raise_Constraint_Error
(Loc
,
7390 Convert_To
(Base_Type
(Etype
(Sub
)),
7391 Duplicate_Subexpr_Move_Checks
(Sub
)),
7392 Right_Opnd
=> Range_N
),
7393 Reason
=> CE_Index_Check_Failed
));
7395 Checks_Generated
.Elements
(Ind
) := True;
7404 end Generate_Index_Checks
;
7406 --------------------------
7407 -- Generate_Range_Check --
7408 --------------------------
7410 procedure Generate_Range_Check
7412 Target_Type
: Entity_Id
;
7413 Reason
: RT_Exception_Code
)
7415 Loc
: constant Source_Ptr
:= Sloc
(N
);
7416 Source_Type
: constant Entity_Id
:= Etype
(N
);
7417 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
7418 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
7420 procedure Convert_And_Check_Range
(Suppress
: Check_Id
);
7421 -- Convert N to the target base type and save the result in a temporary.
7422 -- The action is analyzed using the default checks as modified by the
7423 -- given Suppress argument. Then check the converted value against the
7424 -- range of the target subtype.
7426 function Is_Single_Attribute_Reference
(N
: Node_Id
) return Boolean;
7427 -- Return True if N is an expression that contains a single attribute
7428 -- reference, possibly as operand among only integer literal operands.
7430 -----------------------------
7431 -- Convert_And_Check_Range --
7432 -----------------------------
7434 procedure Convert_And_Check_Range
(Suppress
: Check_Id
) is
7435 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7439 -- For enumeration types with non-standard representation this is a
7440 -- direct conversion from the enumeration type to the target integer
7441 -- type, which is treated by the back end as a normal integer type
7442 -- conversion, treating the enumeration type as an integer, which is
7443 -- exactly what we want. We set Conversion_OK to make sure that the
7444 -- analyzer does not complain about what otherwise might be an
7445 -- illegal conversion.
7447 if Is_Enumeration_Type
(Source_Base_Type
)
7448 and then Present
(Enum_Pos_To_Rep
(Source_Base_Type
))
7449 and then Is_Integer_Type
(Target_Base_Type
)
7451 Conv_N
:= OK_Convert_To
(Target_Base_Type
, Duplicate_Subexpr
(N
));
7453 Conv_N
:= Convert_To
(Target_Base_Type
, Duplicate_Subexpr
(N
));
7456 -- We make a temporary to hold the value of the conversion to the
7457 -- target base type, and then do the test against this temporary.
7458 -- N itself is replaced by an occurrence of Tnn and followed by
7459 -- the explicit range check.
7461 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
7462 -- [constraint_error when Tnn not in Target_Type]
7465 Insert_Actions
(N
, New_List
(
7466 Make_Object_Declaration
(Loc
,
7467 Defining_Identifier
=> Tnn
,
7468 Object_Definition
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
7469 Constant_Present
=> True,
7470 Expression
=> Conv_N
),
7472 Make_Raise_Constraint_Error
(Loc
,
7475 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
7476 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
7478 Suppress
=> Suppress
);
7480 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
7482 -- Set the type of N, because the declaration for Tnn might not
7483 -- be analyzed yet, as is the case if N appears within a record
7484 -- declaration, as a discriminant constraint or expression.
7486 Set_Etype
(N
, Target_Base_Type
);
7487 end Convert_And_Check_Range
;
7489 -------------------------------------
7490 -- Is_Single_Attribute_Reference --
7491 -------------------------------------
7493 function Is_Single_Attribute_Reference
(N
: Node_Id
) return Boolean is
7495 if Nkind
(N
) = N_Attribute_Reference
then
7498 elsif Nkind
(N
) in N_Binary_Op
then
7499 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
7500 return Is_Single_Attribute_Reference
(Left_Opnd
(N
));
7502 elsif Nkind
(Left_Opnd
(N
)) = N_Integer_Literal
then
7503 return Is_Single_Attribute_Reference
(Right_Opnd
(N
));
7512 end Is_Single_Attribute_Reference
;
7514 -- Start of processing for Generate_Range_Check
7517 -- First special case, if the source type is already within the range
7518 -- of the target type, then no check is needed (probably we should have
7519 -- stopped Do_Range_Check from being set in the first place, but better
7520 -- late than never in preventing junk code and junk flag settings).
7522 if In_Subrange_Of
(Source_Type
, Target_Type
)
7524 -- We do NOT apply this if the source node is a literal, since in this
7525 -- case the literal has already been labeled as having the subtype of
7530 N_Integer_Literal | N_Real_Literal | N_Character_Literal
7533 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
7535 Set_Do_Range_Check
(N
, False);
7539 -- Here a check is needed. If the expander is not active (which is also
7540 -- the case in GNATprove mode), then simply set the Do_Range_Check flag
7541 -- and we are done. We just want to see the range check flag set, we do
7542 -- not want to generate the explicit range check code.
7544 if not Expander_Active
then
7545 Set_Do_Range_Check
(N
);
7549 -- Here we will generate an explicit range check, so we don't want to
7550 -- set the Do_Range check flag, since the range check is taken care of
7551 -- by the code we will generate.
7553 Set_Do_Range_Check
(N
, False);
7555 -- Force evaluation of the node, so that it does not get evaluated twice
7556 -- (once for the check, once for the actual reference). Such a double
7557 -- evaluation is always a potential source of inefficiency, and is
7558 -- functionally incorrect in the volatile case.
7560 -- We skip the evaluation of attribute references because, after these
7561 -- runtime checks are generated, the expander may need to rewrite this
7562 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in
7563 -- Expand_N_Attribute_Reference) and, in many cases, their return type
7564 -- is universal integer, which is a very large type for a temporary.
7566 if not Is_Single_Attribute_Reference
(N
)
7567 and then (not Is_Entity_Name
(N
)
7568 or else Treat_As_Volatile
(Entity
(N
)))
7570 Force_Evaluation
(N
, Mode
=> Strict
);
7573 -- The easiest case is when Source_Base_Type and Target_Base_Type are
7574 -- the same since in this case we can simply do a direct check of the
7575 -- value of N against the bounds of Target_Type.
7577 -- [constraint_error when N not in Target_Type]
7579 -- Note: this is by far the most common case, for example all cases of
7580 -- checks on the RHS of assignments are in this category, but not all
7581 -- cases are like this. Notably conversions can involve two types.
7583 if Source_Base_Type
= Target_Base_Type
then
7585 -- Insert the explicit range check. Note that we suppress checks for
7586 -- this code, since we don't want a recursive range check popping up.
7589 Make_Raise_Constraint_Error
(Loc
,
7592 Left_Opnd
=> Duplicate_Subexpr
(N
),
7593 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
7595 Suppress
=> All_Checks
);
7597 -- Next test for the case where the target type is within the bounds
7598 -- of the base type of the source type, since in this case we can
7599 -- simply convert the bounds of the target type to this base type
7602 -- [constraint_error when N not in
7603 -- Source_Base_Type (Target_Type'First)
7605 -- Source_Base_Type(Target_Type'Last))]
7607 -- The conversions will always work and need no check
7609 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
7610 -- of converting from an enumeration value to an integer type, such as
7611 -- occurs for the case of generating a range check on Enum'Val(Exp)
7612 -- (which used to be handled by gigi). This is OK, since the conversion
7613 -- itself does not require a check.
7615 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
7617 -- Insert the explicit range check. Note that we suppress checks for
7618 -- this code, since we don't want a recursive range check popping up.
7620 if Is_Discrete_Type
(Source_Base_Type
)
7622 Is_Discrete_Type
(Target_Base_Type
)
7625 Make_Raise_Constraint_Error
(Loc
,
7628 Left_Opnd
=> Duplicate_Subexpr
(N
),
7633 Unchecked_Convert_To
(Source_Base_Type
,
7634 Make_Attribute_Reference
(Loc
,
7636 New_Occurrence_Of
(Target_Type
, Loc
),
7637 Attribute_Name
=> Name_First
)),
7640 Unchecked_Convert_To
(Source_Base_Type
,
7641 Make_Attribute_Reference
(Loc
,
7643 New_Occurrence_Of
(Target_Type
, Loc
),
7644 Attribute_Name
=> Name_Last
)))),
7646 Suppress
=> All_Checks
);
7648 -- For conversions involving at least one type that is not discrete,
7649 -- first convert to the target base type and then generate the range
7650 -- check. This avoids problems with values that are close to a bound
7651 -- of the target type that would fail a range check when done in a
7652 -- larger source type before converting but pass if converted with
7653 -- rounding and then checked (such as in float-to-float conversions).
7655 -- Note that overflow checks are not suppressed for this code because
7656 -- we do not know whether the source type is in range of the target
7657 -- base type (unlike in the next case below).
7660 Convert_And_Check_Range
(Suppress
=> Range_Check
);
7663 -- Note that at this stage we know that the Target_Base_Type is not in
7664 -- the range of the Source_Base_Type (since even the Target_Type itself
7665 -- is not in this range). It could still be the case that Source_Type is
7666 -- in range of the target base type since we have not checked that case.
7668 -- If that is the case, we can freely convert the source to the target,
7669 -- and then test the target result against the bounds. Note that checks
7670 -- are suppressed for this code, since we don't want a recursive range
7671 -- check popping up.
7673 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
7674 Convert_And_Check_Range
(Suppress
=> All_Checks
);
7676 -- At this stage, we know that we have two scalar types, which are
7677 -- directly convertible, and where neither scalar type has a base
7678 -- range that is in the range of the other scalar type.
7680 -- The only way this can happen is with a signed and unsigned type.
7681 -- So test for these two cases:
7684 -- Case of the source is unsigned and the target is signed
7686 if Is_Unsigned_Type
(Source_Base_Type
)
7687 and then not Is_Unsigned_Type
(Target_Base_Type
)
7689 -- If the source is unsigned and the target is signed, then we
7690 -- know that the source is not shorter than the target (otherwise
7691 -- the source base type would be in the target base type range).
7693 -- In other words, the unsigned type is either the same size as
7694 -- the target, or it is larger. It cannot be smaller.
7697 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
7699 -- We only need to check the low bound if the low bound of the
7700 -- target type is non-negative. If the low bound of the target
7701 -- type is negative, then we know that we will fit fine.
7703 -- If the high bound of the target type is negative, then we
7704 -- know we have a constraint error, since we can't possibly
7705 -- have a negative source.
7707 -- With these two checks out of the way, we can do the check
7708 -- using the source type safely
7710 -- This is definitely the most annoying case.
7712 -- [constraint_error
7713 -- when (Target_Type'First >= 0
7715 -- N < Source_Base_Type (Target_Type'First))
7716 -- or else Target_Type'Last < 0
7717 -- or else N > Source_Base_Type (Target_Type'Last)];
7719 -- We turn off all checks since we know that the conversions
7720 -- will work fine, given the guards for negative values.
7723 Make_Raise_Constraint_Error
(Loc
,
7729 Left_Opnd
=> Make_Op_Ge
(Loc
,
7731 Make_Attribute_Reference
(Loc
,
7733 New_Occurrence_Of
(Target_Type
, Loc
),
7734 Attribute_Name
=> Name_First
),
7735 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7739 Left_Opnd
=> Duplicate_Subexpr
(N
),
7741 Convert_To
(Source_Base_Type
,
7742 Make_Attribute_Reference
(Loc
,
7744 New_Occurrence_Of
(Target_Type
, Loc
),
7745 Attribute_Name
=> Name_First
)))),
7750 Make_Attribute_Reference
(Loc
,
7751 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7752 Attribute_Name
=> Name_Last
),
7753 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
7757 Left_Opnd
=> Duplicate_Subexpr
(N
),
7759 Convert_To
(Source_Base_Type
,
7760 Make_Attribute_Reference
(Loc
,
7761 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7762 Attribute_Name
=> Name_Last
)))),
7765 Suppress
=> All_Checks
);
7767 -- Only remaining possibility is that the source is signed and
7768 -- the target is unsigned.
7771 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
7772 and then Is_Unsigned_Type
(Target_Base_Type
));
7774 -- If the source is signed and the target is unsigned, then we
7775 -- know that the target is not shorter than the source (otherwise
7776 -- the target base type would be in the source base type range).
7778 -- In other words, the unsigned type is either the same size as
7779 -- the target, or it is larger. It cannot be smaller.
7781 -- Clearly we have an error if the source value is negative since
7782 -- no unsigned type can have negative values. If the source type
7783 -- is non-negative, then the check can be done using the target
7786 -- Tnn : constant Target_Base_Type (N) := Target_Type;
7788 -- [constraint_error
7789 -- when N < 0 or else Tnn not in Target_Type];
7791 -- We turn off all checks for the conversion of N to the target
7792 -- base type, since we generate the explicit check to ensure that
7793 -- the value is non-negative
7796 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7799 Insert_Actions
(N
, New_List
(
7800 Make_Object_Declaration
(Loc
,
7801 Defining_Identifier
=> Tnn
,
7802 Object_Definition
=>
7803 New_Occurrence_Of
(Target_Base_Type
, Loc
),
7804 Constant_Present
=> True,
7806 Unchecked_Convert_To
7807 (Target_Base_Type
, Duplicate_Subexpr
(N
))),
7809 Make_Raise_Constraint_Error
(Loc
,
7814 Left_Opnd
=> Duplicate_Subexpr
(N
),
7815 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7819 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
7821 New_Occurrence_Of
(Target_Type
, Loc
))),
7824 Suppress
=> All_Checks
);
7826 -- Set the Etype explicitly, because Insert_Actions may have
7827 -- placed the declaration in the freeze list for an enclosing
7828 -- construct, and thus it is not analyzed yet.
7830 Set_Etype
(Tnn
, Target_Base_Type
);
7831 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
7835 end Generate_Range_Check
;
7841 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
7843 -- For standard check name, we can do a direct computation
7845 if N
in First_Check_Name
.. Last_Check_Name
then
7846 return Check_Id
(N
- (First_Check_Name
- 1));
7848 -- For non-standard names added by pragma Check_Name, search table
7851 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
7852 if Check_Names
.Table
(J
) = N
then
7858 -- No matching name found
7863 ---------------------
7864 -- Get_Discriminal --
7865 ---------------------
7867 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
7868 Loc
: constant Source_Ptr
:= Sloc
(E
);
7873 -- The bound can be a bona fide parameter of a protected operation,
7874 -- rather than a prival encoded as an in-parameter.
7876 if No
(Discriminal_Link
(Entity
(Bound
))) then
7880 -- Climb the scope stack looking for an enclosing protected type. If
7881 -- we run out of scopes, return the bound itself.
7884 while Present
(Sc
) loop
7885 if Sc
= Standard_Standard
then
7887 elsif Ekind
(Sc
) = E_Protected_Type
then
7894 D
:= First_Discriminant
(Sc
);
7895 while Present
(D
) loop
7896 if Chars
(D
) = Chars
(Bound
) then
7897 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
7900 Next_Discriminant
(D
);
7904 end Get_Discriminal
;
7906 ----------------------
7907 -- Get_Range_Checks --
7908 ----------------------
7910 function Get_Range_Checks
7912 Target_Typ
: Entity_Id
;
7913 Source_Typ
: Entity_Id
:= Empty
;
7914 Warn_Node
: Node_Id
:= Empty
) return Check_Result
7918 Selected_Range_Checks
(Expr
, Target_Typ
, Source_Typ
, Warn_Node
);
7919 end Get_Range_Checks
;
7925 function Guard_Access
7928 Expr
: Node_Id
) return Node_Id
7931 if Nkind
(Cond
) = N_Or_Else
then
7932 Set_Paren_Count
(Cond
, 1);
7935 if Nkind
(Expr
) = N_Allocator
then
7943 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
7944 Right_Opnd
=> Make_Null
(Loc
)),
7945 Right_Opnd
=> Cond
);
7949 -----------------------------
7950 -- Index_Checks_Suppressed --
7951 -----------------------------
7953 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7955 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7956 return Is_Check_Suppressed
(E
, Index_Check
);
7958 return Scope_Suppress
.Suppress
(Index_Check
);
7960 end Index_Checks_Suppressed
;
7966 procedure Initialize
is
7968 for J
in Determine_Range_Cache_N
'Range loop
7969 Determine_Range_Cache_N
(J
) := Empty
;
7974 for J
in Int
range 1 .. All_Checks
loop
7975 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
7979 -------------------------
7980 -- Insert_Range_Checks --
7981 -------------------------
7983 procedure Insert_Range_Checks
7984 (Checks
: Check_Result
;
7986 Suppress_Typ
: Entity_Id
;
7987 Static_Sloc
: Source_Ptr
;
7988 Do_Before
: Boolean := False)
7990 Checks_On
: constant Boolean :=
7991 not Index_Checks_Suppressed
(Suppress_Typ
)
7993 not Range_Checks_Suppressed
(Suppress_Typ
);
7995 Check_Node
: Node_Id
;
7998 -- For now we just return if Checks_On is false, however this should be
7999 -- enhanced to check for an always True value in the condition and to
8000 -- generate a compilation warning.
8002 if not Expander_Active
or not Checks_On
then
8006 for J
in 1 .. 2 loop
8007 exit when No
(Checks
(J
));
8009 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
8010 and then Present
(Condition
(Checks
(J
)))
8012 Check_Node
:= Checks
(J
);
8015 Make_Raise_Constraint_Error
(Static_Sloc
,
8016 Reason
=> CE_Range_Check_Failed
);
8019 Mark_Rewrite_Insertion
(Check_Node
);
8022 Insert_Before_And_Analyze
(Node
, Check_Node
);
8024 Insert_After_And_Analyze
(Node
, Check_Node
);
8027 end Insert_Range_Checks
;
8029 ------------------------
8030 -- Insert_Valid_Check --
8031 ------------------------
8033 procedure Insert_Valid_Check
8035 Related_Id
: Entity_Id
:= Empty
;
8036 Is_Low_Bound
: Boolean := False;
8037 Is_High_Bound
: Boolean := False)
8039 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
8040 Typ
: Entity_Id
:= Etype
(Expr
);
8044 -- Do not insert if checks off, or if not checking validity or if
8045 -- expression is known to be valid.
8047 if not Validity_Checks_On
8048 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
8049 or else Expr_Known_Valid
(Expr
)
8053 -- Do not insert checks within a predicate function. This will arise
8054 -- if the current unit and the predicate function are being compiled
8055 -- with validity checks enabled.
8057 elsif Present
(Predicate_Function
(Typ
))
8058 and then Current_Scope
= Predicate_Function
(Typ
)
8062 -- If the expression is a packed component of a modular type of the
8063 -- right size, the data is always valid.
8065 elsif Nkind
(Expr
) = N_Selected_Component
8066 and then Present
(Component_Clause
(Entity
(Selector_Name
(Expr
))))
8067 and then Is_Modular_Integer_Type
(Typ
)
8068 and then Modulus
(Typ
) = 2 ** Esize
(Entity
(Selector_Name
(Expr
)))
8072 -- Do not generate a validity check when inside a generic unit as this
8073 -- is an expansion activity.
8075 elsif Inside_A_Generic
then
8079 -- Entities declared in Lock_free protected types must be treated as
8080 -- volatile, and we must inhibit validity checks to prevent improper
8081 -- constant folding.
8083 if Is_Entity_Name
(Expr
)
8084 and then Is_Subprogram
(Scope
(Entity
(Expr
)))
8085 and then Present
(Protected_Subprogram
(Scope
(Entity
(Expr
))))
8086 and then Uses_Lock_Free
8087 (Scope
(Protected_Subprogram
(Scope
(Entity
(Expr
)))))
8092 -- If we have a checked conversion, then validity check applies to
8093 -- the expression inside the conversion, not the result, since if
8094 -- the expression inside is valid, then so is the conversion result.
8097 while Nkind
(Exp
) = N_Type_Conversion
loop
8098 Exp
:= Expression
(Exp
);
8102 -- Do not generate a check for a variable which already validates the
8103 -- value of an assignable object.
8105 if Is_Validation_Variable_Reference
(Exp
) then
8115 -- If the expression denotes an assignable object, capture its value
8116 -- in a variable and replace the original expression by the variable.
8117 -- This approach has several effects:
8119 -- 1) The evaluation of the object results in only one read in the
8120 -- case where the object is atomic or volatile.
8122 -- Var ... := Object; -- read
8124 -- 2) The captured value is the one verified by attribute 'Valid.
8125 -- As a result the object is not evaluated again, which would
8126 -- result in an unwanted read in the case where the object is
8127 -- atomic or volatile.
8129 -- if not Var'Valid then -- OK, no read of Object
8131 -- if not Object'Valid then -- Wrong, extra read of Object
8133 -- 3) The captured value replaces the original object reference.
8134 -- As a result the object is not evaluated again, in the same
8137 -- ... Var ... -- OK, no read of Object
8139 -- ... Object ... -- Wrong, extra read of Object
8141 -- 4) The use of a variable to capture the value of the object
8142 -- allows the propagation of any changes back to the original
8145 -- procedure Call (Val : in out ...);
8147 -- Var : ... := Object; -- read Object
8148 -- if not Var'Valid then -- validity check
8149 -- Call (Var); -- modify Var
8150 -- Object := Var; -- update Object
8152 if Is_Variable
(Exp
) then
8153 Var_Id
:= Make_Temporary
(Loc
, 'T', Exp
);
8155 -- Because we could be dealing with a transient scope which would
8156 -- cause our object declaration to remain unanalyzed we must do
8157 -- some manual decoration.
8159 Mutate_Ekind
(Var_Id
, E_Variable
);
8160 Set_Etype
(Var_Id
, Typ
);
8163 Make_Object_Declaration
(Loc
,
8164 Defining_Identifier
=> Var_Id
,
8165 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8166 Expression
=> New_Copy_Tree
(Exp
)),
8167 Suppress
=> Validity_Check
);
8169 Set_Validated_Object
(Var_Id
, New_Copy_Tree
(Exp
));
8171 Rewrite
(Exp
, New_Occurrence_Of
(Var_Id
, Loc
));
8173 -- Move the Do_Range_Check flag over to the new Exp so it doesn't
8174 -- get lost and doesn't leak elsewhere.
8176 if Do_Range_Check
(Validated_Object
(Var_Id
)) then
8177 Set_Do_Range_Check
(Exp
);
8178 Set_Do_Range_Check
(Validated_Object
(Var_Id
), False);
8181 -- In case of a type conversion, an expansion of the expr may be
8182 -- needed (eg. fixed-point as actual).
8185 pragma Assert
(Nkind
(Expr
) = N_Type_Conversion
);
8186 Analyze_And_Resolve
(Expr
);
8189 PV
:= New_Occurrence_Of
(Var_Id
, Loc
);
8191 -- Otherwise the expression does not denote a variable. Force its
8192 -- evaluation by capturing its value in a constant. Generate:
8194 -- Temp : constant ... := Exp;
8199 Related_Id
=> Related_Id
,
8200 Is_Low_Bound
=> Is_Low_Bound
,
8201 Is_High_Bound
=> Is_High_Bound
);
8203 PV
:= New_Copy_Tree
(Exp
);
8206 -- A rather specialized test. If PV is an analyzed expression which
8207 -- is an indexed component of a packed array that has not been
8208 -- properly expanded, turn off its Analyzed flag to make sure it
8209 -- gets properly reexpanded. If the prefix is an access value,
8210 -- the dereference will be added later.
8212 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
8213 -- an analyze with the old parent pointer. This may point e.g. to
8214 -- a subprogram call, which deactivates this expansion.
8217 and then Nkind
(PV
) = N_Indexed_Component
8218 and then Is_Array_Type
(Etype
(Prefix
(PV
)))
8219 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(PV
))))
8221 Set_Analyzed
(PV
, False);
8224 -- Build the raise CE node to check for validity. We build a type
8225 -- qualification for the prefix, since it may not be of the form of
8226 -- a name, and we don't care in this context!
8229 Make_Raise_Constraint_Error
(Loc
,
8233 Make_Attribute_Reference
(Loc
,
8235 Attribute_Name
=> Name_Valid
)),
8236 Reason
=> CE_Invalid_Data
);
8238 -- Insert the validity check. Note that we do this with validity
8239 -- checks turned off, to avoid recursion, we do not want validity
8240 -- checks on the validity checking code itself.
8242 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
8244 -- If the expression is a reference to an element of a bit-packed
8245 -- array, then it is rewritten as a renaming declaration. If the
8246 -- expression is an actual in a call, it has not been expanded,
8247 -- waiting for the proper point at which to do it. The same happens
8248 -- with renamings, so that we have to force the expansion now. This
8249 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
8252 if Is_Entity_Name
(Exp
)
8253 and then Nkind
(Parent
(Entity
(Exp
))) =
8254 N_Object_Renaming_Declaration
8257 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
8259 if Nkind
(Old_Exp
) = N_Indexed_Component
8260 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
8262 Expand_Packed_Element_Reference
(Old_Exp
);
8267 end Insert_Valid_Check
;
8269 -------------------------------------
8270 -- Is_Signed_Integer_Arithmetic_Op --
8271 -------------------------------------
8273 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
8287 return Is_Signed_Integer_Type
(Etype
(N
));
8289 when N_Case_Expression
8292 return Is_Signed_Integer_Type
(Etype
(N
));
8297 end Is_Signed_Integer_Arithmetic_Op
;
8299 ----------------------------------
8300 -- Install_Null_Excluding_Check --
8301 ----------------------------------
8303 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
8304 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
8305 Typ
: constant Entity_Id
:= Etype
(N
);
8307 procedure Mark_Non_Null
;
8308 -- After installation of check, if the node in question is an entity
8309 -- name, then mark this entity as non-null if possible.
8315 procedure Mark_Non_Null
is
8317 -- Only case of interest is if node N is an entity name
8319 if Is_Entity_Name
(N
) then
8321 -- For sure, we want to clear an indication that this is known to
8322 -- be null, since if we get past this check, it definitely is not.
8324 Set_Is_Known_Null
(Entity
(N
), False);
8326 -- We can mark the entity as known to be non-null if it is safe to
8327 -- capture the value.
8329 if Safe_To_Capture_Value
(N
, Entity
(N
)) then
8330 Set_Is_Known_Non_Null
(Entity
(N
));
8335 -- Start of processing for Install_Null_Excluding_Check
8338 -- No need to add null-excluding checks when the tree may not be fully
8341 if Serious_Errors_Detected
> 0 then
8345 pragma Assert
(Is_Access_Type
(Typ
));
8347 -- No check inside a generic, check will be emitted in instance
8349 if Inside_A_Generic
then
8353 -- No check needed if known to be non-null
8355 if Known_Non_Null
(N
) then
8359 -- If known to be null, here is where we generate a compile time check
8361 if Known_Null
(N
) then
8363 -- Avoid generating warning message inside init procs. In SPARK mode
8364 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
8365 -- since it will be turned into an error in any case.
8367 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
8369 -- Do not emit the warning within a conditional expression,
8370 -- where the expression might not be evaluated, and the warning
8371 -- appear as extraneous noise.
8373 and then not Within_Case_Or_If_Expression
(N
)
8375 Apply_Compile_Time_Constraint_Error
8376 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
8378 -- Remaining cases, where we silently insert the raise
8382 Make_Raise_Constraint_Error
(Loc
,
8383 Reason
=> CE_Access_Check_Failed
));
8390 -- If entity is never assigned, for sure a warning is appropriate
8392 if Is_Entity_Name
(N
) then
8393 Check_Unset_Reference
(N
);
8396 -- No check needed if checks are suppressed on the range. Note that we
8397 -- don't set Is_Known_Non_Null in this case (we could legitimately do
8398 -- so, since the program is erroneous, but we don't like to casually
8399 -- propagate such conclusions from erroneosity).
8401 if Access_Checks_Suppressed
(Typ
) then
8405 -- No check needed for access to concurrent record types generated by
8406 -- the expander. This is not just an optimization (though it does indeed
8407 -- remove junk checks). It also avoids generation of junk warnings.
8409 if Nkind
(N
) in N_Has_Chars
8410 and then Chars
(N
) = Name_uObject
8411 and then Is_Concurrent_Record_Type
8412 (Directly_Designated_Type
(Etype
(N
)))
8417 -- No check needed in interface thunks since the runtime check is
8418 -- already performed at the caller side.
8420 if Is_Thunk
(Current_Scope
) then
8424 -- In GNATprove mode, we do not apply the check
8426 if GNATprove_Mode
then
8430 -- Otherwise install access check
8433 Make_Raise_Constraint_Error
(Loc
,
8436 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
8437 Right_Opnd
=> Make_Null
(Loc
)),
8438 Reason
=> CE_Access_Check_Failed
));
8441 end Install_Null_Excluding_Check
;
8443 -----------------------------------------
8444 -- Install_Primitive_Elaboration_Check --
8445 -----------------------------------------
8447 procedure Install_Primitive_Elaboration_Check
(Subp_Body
: Node_Id
) is
8448 function Within_Compilation_Unit_Instance
8449 (Subp_Id
: Entity_Id
) return Boolean;
8450 -- Determine whether subprogram Subp_Id appears within an instance which
8451 -- acts as a compilation unit.
8453 --------------------------------------
8454 -- Within_Compilation_Unit_Instance --
8455 --------------------------------------
8457 function Within_Compilation_Unit_Instance
8458 (Subp_Id
: Entity_Id
) return Boolean
8463 -- Examine the scope chain looking for a compilation-unit-level
8466 Pack
:= Scope
(Subp_Id
);
8467 while Present
(Pack
) and then Pack
/= Standard_Standard
loop
8468 if Ekind
(Pack
) = E_Package
8469 and then Is_Generic_Instance
(Pack
)
8470 and then Nkind
(Parent
(Unit_Declaration_Node
(Pack
))) =
8476 Pack
:= Scope
(Pack
);
8480 end Within_Compilation_Unit_Instance
;
8482 -- Local declarations
8484 Context
: constant Node_Id
:= Parent
(Subp_Body
);
8485 Loc
: constant Source_Ptr
:= Sloc
(Subp_Body
);
8486 Subp_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Body
);
8487 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
8490 Flag_Id
: Entity_Id
;
8493 Tag_Typ
: Entity_Id
;
8495 -- Start of processing for Install_Primitive_Elaboration_Check
8498 -- Do not generate an elaboration check in compilation modes where
8499 -- expansion is not desirable.
8501 if GNATprove_Mode
then
8504 -- Do not generate an elaboration check if all checks have been
8507 elsif Suppress_Checks
then
8510 -- Do not generate an elaboration check if the related subprogram is
8511 -- not subject to elaboration checks.
8513 elsif Elaboration_Checks_Suppressed
(Subp_Id
) then
8516 -- Do not generate an elaboration check if such code is not desirable
8518 elsif Restriction_Active
(No_Elaboration_Code
) then
8521 -- If pragma Pure or Preelaborate applies, then these elaboration checks
8522 -- cannot fail, so do not generate them.
8524 elsif In_Preelaborated_Unit
then
8527 -- Do not generate an elaboration check if exceptions cannot be used,
8528 -- caught, or propagated.
8530 elsif not Exceptions_OK
then
8533 -- Do not consider subprograms that are compilation units, because they
8534 -- cannot be the target of a dispatching call.
8536 elsif Nkind
(Context
) = N_Compilation_Unit
then
8539 -- Do not consider anything other than nonabstract library-level source
8543 (Comes_From_Source
(Subp_Id
)
8544 and then Is_Library_Level_Entity
(Subp_Id
)
8545 and then Is_Primitive
(Subp_Id
)
8546 and then not Is_Abstract_Subprogram
(Subp_Id
))
8550 -- Do not consider inlined primitives, because once the body is inlined
8551 -- the reference to the elaboration flag will be out of place and will
8552 -- result in an undefined symbol.
8554 elsif Is_Inlined
(Subp_Id
) or else Has_Pragma_Inline
(Subp_Id
) then
8557 -- Do not generate a duplicate elaboration check. This happens only in
8558 -- the case of primitives completed by an expression function, as the
8559 -- corresponding body is apparently analyzed and expanded twice.
8561 elsif Analyzed
(Subp_Body
) then
8564 -- Do not consider primitives that occur within an instance that is a
8565 -- compilation unit. Such an instance defines its spec and body out of
8566 -- order (body is first) within the tree, which causes the reference to
8567 -- the elaboration flag to appear as an undefined symbol.
8569 elsif Within_Compilation_Unit_Instance
(Subp_Id
) then
8573 Tag_Typ
:= Find_Dispatching_Type
(Subp_Id
);
8575 -- Only tagged primitives may be the target of a dispatching call
8577 if No
(Tag_Typ
) then
8580 -- Do not consider finalization-related primitives, because they may
8581 -- need to be called while elaboration is taking place.
8583 elsif Is_Controlled
(Tag_Typ
)
8585 Chars
(Subp_Id
) in Name_Adjust | Name_Finalize | Name_Initialize
8590 -- Create the declaration of the elaboration flag. The name carries a
8591 -- unique counter in case of name overloading.
8594 Make_Defining_Identifier
(Loc
,
8595 Chars
=> New_External_Name
(Chars
(Subp_Id
), 'E', -1));
8596 Set_Is_Frozen
(Flag_Id
);
8598 -- Insert the declaration of the elaboration flag in front of the
8599 -- primitive spec and analyze it in the proper context.
8601 Push_Scope
(Scope
(Subp_Id
));
8604 -- E : Boolean := False;
8606 Insert_Action
(Subp_Decl
,
8607 Make_Object_Declaration
(Loc
,
8608 Defining_Identifier
=> Flag_Id
,
8609 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8610 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
8613 -- Prevent the compiler from optimizing the elaboration check by killing
8614 -- the current value of the flag and the associated assignment.
8616 Set_Current_Value
(Flag_Id
, Empty
);
8617 Set_Last_Assignment
(Flag_Id
, Empty
);
8619 -- Add a check at the top of the body declarations to ensure that the
8620 -- elaboration flag has been set.
8622 Decls
:= Declarations
(Subp_Body
);
8626 Set_Declarations
(Subp_Body
, Decls
);
8631 -- raise Program_Error with "access before elaboration";
8635 Make_Raise_Program_Error
(Loc
,
8638 Right_Opnd
=> New_Occurrence_Of
(Flag_Id
, Loc
)),
8639 Reason
=> PE_Access_Before_Elaboration
));
8641 Analyze
(First
(Decls
));
8643 -- Set the elaboration flag once the body has been elaborated. Insert
8644 -- the statement after the subprogram stub when the primitive body is
8647 if Nkind
(Context
) = N_Subunit
then
8648 Set_Ins
:= Corresponding_Stub
(Context
);
8650 Set_Ins
:= Subp_Body
;
8657 Make_Assignment_Statement
(Loc
,
8658 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
8659 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
8661 -- Mark the assignment statement as elaboration code. This allows the
8662 -- early call region mechanism (see Sem_Elab) to properly ignore such
8663 -- assignments even though they are non-preelaborable code.
8665 Set_Is_Elaboration_Code
(Set_Stmt
);
8667 Insert_After_And_Analyze
(Set_Ins
, Set_Stmt
);
8668 end Install_Primitive_Elaboration_Check
;
8670 --------------------------
8671 -- Install_Static_Check --
8672 --------------------------
8674 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
8675 Stat
: constant Boolean := Is_OK_Static_Expression
(R_Cno
);
8676 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
8680 Make_Raise_Constraint_Error
(Loc
,
8681 Reason
=> CE_Range_Check_Failed
));
8682 Set_Analyzed
(R_Cno
);
8683 Set_Etype
(R_Cno
, Typ
);
8684 Set_Raises_Constraint_Error
(R_Cno
);
8685 Set_Is_Static_Expression
(R_Cno
, Stat
);
8687 -- Now deal with possible local raise handling
8689 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
8690 end Install_Static_Check
;
8692 -------------------------
8693 -- Is_Check_Suppressed --
8694 -------------------------
8696 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
8697 Ptr
: Suppress_Stack_Entry_Ptr
;
8700 -- First search the local entity suppress stack. We search this from the
8701 -- top of the stack down so that we get the innermost entry that applies
8702 -- to this case if there are nested entries.
8704 Ptr
:= Local_Suppress_Stack_Top
;
8705 while Ptr
/= null loop
8706 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8707 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8709 return Ptr
.Suppress
;
8715 -- Now search the global entity suppress table for a matching entry.
8716 -- We also search this from the top down so that if there are multiple
8717 -- pragmas for the same entity, the last one applies (not clear what
8718 -- or whether the RM specifies this handling, but it seems reasonable).
8720 Ptr
:= Global_Suppress_Stack_Top
;
8721 while Ptr
/= null loop
8722 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8723 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8725 return Ptr
.Suppress
;
8731 -- If we did not find a matching entry, then use the normal scope
8732 -- suppress value after all (actually this will be the global setting
8733 -- since it clearly was not overridden at any point). For a predefined
8734 -- check, we test the specific flag. For a user defined check, we check
8735 -- the All_Checks flag. The Overflow flag requires special handling to
8736 -- deal with the General vs Assertion case.
8738 if C
= Overflow_Check
then
8739 return Overflow_Checks_Suppressed
(Empty
);
8741 elsif C
in Predefined_Check_Id
then
8742 return Scope_Suppress
.Suppress
(C
);
8745 return Scope_Suppress
.Suppress
(All_Checks
);
8747 end Is_Check_Suppressed
;
8749 ---------------------
8750 -- Kill_All_Checks --
8751 ---------------------
8753 procedure Kill_All_Checks
is
8755 if Debug_Flag_CC
then
8756 w
("Kill_All_Checks");
8759 -- We reset the number of saved checks to zero, and also modify all
8760 -- stack entries for statement ranges to indicate that the number of
8761 -- checks at each level is now zero.
8763 Num_Saved_Checks
:= 0;
8765 -- Note: the Int'Min here avoids any possibility of J being out of
8766 -- range when called from e.g. Conditional_Statements_Begin.
8768 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
8769 Saved_Checks_Stack
(J
) := 0;
8771 end Kill_All_Checks
;
8777 procedure Kill_Checks
(V
: Entity_Id
) is
8779 if Debug_Flag_CC
then
8780 w
("Kill_Checks for entity", Int
(V
));
8783 for J
in 1 .. Num_Saved_Checks
loop
8784 if Saved_Checks
(J
).Entity
= V
then
8785 if Debug_Flag_CC
then
8786 w
(" Checks killed for saved check ", J
);
8789 Saved_Checks
(J
).Killed
:= True;
8794 ------------------------------
8795 -- Length_Checks_Suppressed --
8796 ------------------------------
8798 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8800 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8801 return Is_Check_Suppressed
(E
, Length_Check
);
8803 return Scope_Suppress
.Suppress
(Length_Check
);
8805 end Length_Checks_Suppressed
;
8807 -----------------------
8808 -- Make_Bignum_Block --
8809 -----------------------
8811 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
8812 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
8815 Make_Block_Statement
(Loc
,
8817 New_List
(Build_SS_Mark_Call
(Loc
, M
)),
8818 Handled_Statement_Sequence
=>
8819 Make_Handled_Sequence_Of_Statements
(Loc
,
8820 Statements
=> New_List
(Build_SS_Release_Call
(Loc
, M
))));
8821 end Make_Bignum_Block
;
8823 ----------------------------------
8824 -- Minimize_Eliminate_Overflows --
8825 ----------------------------------
8827 -- This is a recursive routine that is called at the top of an expression
8828 -- tree to properly process overflow checking for a whole subtree by making
8829 -- recursive calls to process operands. This processing may involve the use
8830 -- of bignum or long long integer arithmetic, which will change the types
8831 -- of operands and results. That's why we can't do this bottom up (since
8832 -- it would interfere with semantic analysis).
8834 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
8835 -- the operator expansion routines, as well as the expansion routines for
8836 -- if/case expression, do nothing (for the moment) except call the routine
8837 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
8838 -- routine does nothing for non top-level nodes, so at the point where the
8839 -- call is made for the top level node, the entire expression subtree has
8840 -- not been expanded, or processed for overflow. All that has to happen as
8841 -- a result of the top level call to this routine.
8843 -- As noted above, the overflow processing works by making recursive calls
8844 -- for the operands, and figuring out what to do, based on the processing
8845 -- of these operands (e.g. if a bignum operand appears, the parent op has
8846 -- to be done in bignum mode), and the determined ranges of the operands.
8848 -- After possible rewriting of a constituent subexpression node, a call is
8849 -- made to either reexpand the node (if nothing has changed) or reanalyze
8850 -- the node (if it has been modified by the overflow check processing). The
8851 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
8852 -- a recursive call into the whole overflow apparatus, an important rule
8853 -- for this call is that the overflow handling mode must be temporarily set
8856 procedure Minimize_Eliminate_Overflows
8860 Top_Level
: Boolean)
8862 Rtyp
: constant Entity_Id
:= Etype
(N
);
8863 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
8864 -- Result type, must be a signed integer type
8866 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
8867 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
8869 Loc
: constant Source_Ptr
:= Sloc
(N
);
8872 -- Ranges of values for right operand (operator case)
8874 Llo
: Uint
:= No_Uint
; -- initialize to prevent warning
8875 Lhi
: Uint
:= No_Uint
; -- initialize to prevent warning
8876 -- Ranges of values for left operand (operator case)
8878 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
8879 -- Operands and results are of this type when we convert
8881 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
8882 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
8883 -- Bounds of Long_Long_Integer
8885 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
8886 -- Indicates binary operator case
8889 -- Used in call to Determine_Range
8891 Bignum_Operands
: Boolean;
8892 -- Set True if one or more operands is already of type Bignum, meaning
8893 -- that for sure (regardless of Top_Level setting) we are committed to
8894 -- doing the operation in Bignum mode (or in the case of a case or if
8895 -- expression, converting all the dependent expressions to Bignum).
8897 Long_Long_Integer_Operands
: Boolean;
8898 -- Set True if one or more operands is already of type Long_Long_Integer
8899 -- which means that if the result is known to be in the result type
8900 -- range, then we must convert such operands back to the result type.
8902 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
8903 -- This is called when we have modified the node and we therefore need
8904 -- to reanalyze it. It is important that we reset the mode to STRICT for
8905 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
8906 -- we would reenter this routine recursively which would not be good.
8907 -- The argument Suppress is set True if we also want to suppress
8908 -- overflow checking for the reexpansion (this is set when we know
8909 -- overflow is not possible). Typ is the type for the reanalysis.
8911 procedure Reexpand
(Suppress
: Boolean := False);
8912 -- This is like Reanalyze, but does not do the Analyze step, it only
8913 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
8914 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
8915 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
8916 -- Note that skipping reanalysis is not just an optimization, testing
8917 -- has showed up several complex cases in which reanalyzing an already
8918 -- analyzed node causes incorrect behavior.
8920 function In_Result_Range
return Boolean;
8921 -- Returns True iff Lo .. Hi are within range of the result type
8923 procedure Max
(A
: in out Uint
; B
: Uint
);
8924 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
8926 procedure Min
(A
: in out Uint
; B
: Uint
);
8927 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
8929 ---------------------
8930 -- In_Result_Range --
8931 ---------------------
8933 function In_Result_Range
return Boolean is
8935 if No
(Lo
) or else No
(Hi
) then
8938 elsif Is_OK_Static_Subtype
(Etype
(N
)) then
8939 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
8941 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
8944 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
8946 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
8948 end In_Result_Range
;
8954 procedure Max
(A
: in out Uint
; B
: Uint
) is
8956 if No
(A
) or else B
> A
then
8965 procedure Min
(A
: in out Uint
; B
: Uint
) is
8967 if No
(A
) or else B
< A
then
8976 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
8977 Svg
: constant Overflow_Mode_Type
:=
8978 Scope_Suppress
.Overflow_Mode_General
;
8979 Sva
: constant Overflow_Mode_Type
:=
8980 Scope_Suppress
.Overflow_Mode_Assertions
;
8981 Svo
: constant Boolean :=
8982 Scope_Suppress
.Suppress
(Overflow_Check
);
8985 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
8986 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
8989 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
8992 Analyze_And_Resolve
(N
, Typ
);
8994 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
8995 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
8996 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
9003 procedure Reexpand
(Suppress
: Boolean := False) is
9004 Svg
: constant Overflow_Mode_Type
:=
9005 Scope_Suppress
.Overflow_Mode_General
;
9006 Sva
: constant Overflow_Mode_Type
:=
9007 Scope_Suppress
.Overflow_Mode_Assertions
;
9008 Svo
: constant Boolean :=
9009 Scope_Suppress
.Suppress
(Overflow_Check
);
9012 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9013 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9014 Set_Analyzed
(N
, False);
9017 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
9022 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
9023 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
9024 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
9027 -- Start of processing for Minimize_Eliminate_Overflows
9030 -- Default initialize Lo and Hi since these are not guaranteed to be
9036 -- Case where we do not have a signed integer arithmetic operation
9038 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
9040 -- Use the normal Determine_Range routine to get the range. We
9041 -- don't require operands to be valid, invalid values may result in
9042 -- rubbish results where the result has not been properly checked for
9043 -- overflow, that's fine.
9045 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
9047 -- If Determine_Range did not work (can this in fact happen? Not
9048 -- clear but might as well protect), use type bounds.
9051 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
9052 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
9055 -- If we don't have a binary operator, all we have to do is to set
9056 -- the Hi/Lo range, so we are done.
9060 -- Processing for if expression
9062 elsif Nkind
(N
) = N_If_Expression
then
9064 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
9065 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
9068 Bignum_Operands
:= False;
9070 Minimize_Eliminate_Overflows
9071 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
9074 Bignum_Operands
:= True;
9077 Minimize_Eliminate_Overflows
9078 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
9081 Bignum_Operands
:= True;
9083 Long_Long_Integer_Operands
:=
9084 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
9090 -- If at least one of our operands is now Bignum, we must rebuild
9091 -- the if expression to use Bignum operands. We will analyze the
9092 -- rebuilt if expression with overflow checks off, since once we
9093 -- are in bignum mode, we are all done with overflow checks.
9095 if Bignum_Operands
then
9097 Make_If_Expression
(Loc
,
9098 Expressions
=> New_List
(
9099 Remove_Head
(Expressions
(N
)),
9100 Convert_To_Bignum
(Then_DE
),
9101 Convert_To_Bignum
(Else_DE
)),
9102 Is_Elsif
=> Is_Elsif
(N
)));
9104 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
9106 -- If we have no Long_Long_Integer operands, then we are in result
9107 -- range, since it means that none of our operands felt the need
9108 -- to worry about overflow (otherwise it would have already been
9109 -- converted to long long integer or bignum). We reexpand to
9110 -- complete the expansion of the if expression (but we do not
9111 -- need to reanalyze).
9113 elsif not Long_Long_Integer_Operands
then
9114 Set_Do_Overflow_Check
(N
, False);
9117 -- Otherwise convert us to long long integer mode. Note that we
9118 -- don't need any further overflow checking at this level.
9121 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
9122 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
9123 Set_Etype
(N
, LLIB
);
9125 -- Now reanalyze with overflow checks off
9127 Set_Do_Overflow_Check
(N
, False);
9128 Reanalyze
(LLIB
, Suppress
=> True);
9134 -- Here for case expression
9136 elsif Nkind
(N
) = N_Case_Expression
then
9137 Bignum_Operands
:= False;
9138 Long_Long_Integer_Operands
:= False;
9144 -- Loop through expressions applying recursive call
9146 Alt
:= First
(Alternatives
(N
));
9147 while Present
(Alt
) loop
9149 Aexp
: constant Node_Id
:= Expression
(Alt
);
9152 Minimize_Eliminate_Overflows
9153 (Aexp
, Lo
, Hi
, Top_Level
=> False);
9156 Bignum_Operands
:= True;
9157 elsif Etype
(Aexp
) = LLIB
then
9158 Long_Long_Integer_Operands
:= True;
9165 -- If we have no bignum or long long integer operands, it means
9166 -- that none of our dependent expressions could raise overflow.
9167 -- In this case, we simply return with no changes except for
9168 -- resetting the overflow flag, since we are done with overflow
9169 -- checks for this node. We will reexpand to get the needed
9170 -- expansion for the case expression, but we do not need to
9171 -- reanalyze, since nothing has changed.
9173 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
9174 Set_Do_Overflow_Check
(N
, False);
9175 Reexpand
(Suppress
=> True);
9177 -- Otherwise we are going to rebuild the case expression using
9178 -- either bignum or long long integer operands throughout.
9182 Rtype
: Entity_Id
:= Empty
;
9187 New_Alts
:= New_List
;
9188 Alt
:= First
(Alternatives
(N
));
9189 while Present
(Alt
) loop
9190 if Bignum_Operands
then
9191 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
9192 Rtype
:= RTE
(RE_Bignum
);
9194 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
9198 Append_To
(New_Alts
,
9199 Make_Case_Expression_Alternative
(Sloc
(Alt
),
9200 Discrete_Choices
=> Discrete_Choices
(Alt
),
9201 Expression
=> New_Exp
));
9207 Make_Case_Expression
(Loc
,
9208 Expression
=> Expression
(N
),
9209 Alternatives
=> New_Alts
));
9211 pragma Assert
(Present
(Rtype
));
9212 Reanalyze
(Rtype
, Suppress
=> True);
9220 -- If we have an arithmetic operator we make recursive calls on the
9221 -- operands to get the ranges (and to properly process the subtree
9222 -- that lies below us).
9224 Minimize_Eliminate_Overflows
9225 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
9228 Minimize_Eliminate_Overflows
9229 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
9232 -- Record if we have Long_Long_Integer operands
9234 Long_Long_Integer_Operands
:=
9235 Etype
(Right_Opnd
(N
)) = LLIB
9236 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
9238 -- If either operand is a bignum, then result will be a bignum and we
9239 -- don't need to do any range analysis. As previously discussed we could
9240 -- do range analysis in such cases, but it could mean working with giant
9241 -- numbers at compile time for very little gain (the number of cases
9242 -- in which we could slip back from bignum mode is small).
9244 if No
(Rlo
) or else (Binary
and then No
(Llo
)) then
9247 Bignum_Operands
:= True;
9249 -- Otherwise compute result range
9252 Compute_Range_For_Arithmetic_Op
9253 (Nkind
(N
), Llo
, Lhi
, Rlo
, Rhi
, OK
, Lo
, Hi
);
9254 Bignum_Operands
:= False;
9257 -- Here for the case where we have not rewritten anything (no bignum
9258 -- operands or long long integer operands), and we know the result.
9259 -- If we know we are in the result range, and we do not have Bignum
9260 -- operands or Long_Long_Integer operands, we can just reexpand with
9261 -- overflow checks turned off (since we know we cannot have overflow).
9262 -- As always the reexpansion is required to complete expansion of the
9263 -- operator, but we do not need to reanalyze, and we prevent recursion
9264 -- by suppressing the check.
9266 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
9267 and then In_Result_Range
9269 Set_Do_Overflow_Check
(N
, False);
9270 Reexpand
(Suppress
=> True);
9273 -- Here we know that we are not in the result range, and in the general
9274 -- case we will move into either the Bignum or Long_Long_Integer domain
9275 -- to compute the result. However, there is one exception. If we are
9276 -- at the top level, and we do not have Bignum or Long_Long_Integer
9277 -- operands, we will have to immediately convert the result back to
9278 -- the result type, so there is no point in Bignum/Long_Long_Integer
9282 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
9284 -- One further refinement. If we are at the top level, but our parent
9285 -- is a type conversion, then go into bignum or long long integer node
9286 -- since the result will be converted to that type directly without
9287 -- going through the result type, and we may avoid an overflow. This
9288 -- is the case for example of Long_Long_Integer (A ** 4), where A is
9289 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
9290 -- but does not fit in Integer.
9292 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
9294 -- Here keep original types, but we need to complete analysis
9296 -- One subtlety. We can't just go ahead and do an analyze operation
9297 -- here because it will cause recursion into the whole MINIMIZED/
9298 -- ELIMINATED overflow processing which is not what we want. Here
9299 -- we are at the top level, and we need a check against the result
9300 -- mode (i.e. we want to use STRICT mode). So do exactly that.
9301 -- Also, we have not modified the node, so this is a case where
9302 -- we need to reexpand, but not reanalyze.
9307 -- Cases where we do the operation in Bignum mode. This happens either
9308 -- because one of our operands is in Bignum mode already, or because
9309 -- the computed bounds are outside the bounds of Long_Long_Integer,
9310 -- which in some cases can be indicated by Hi and Lo being No_Uint.
9312 -- Note: we could do better here and in some cases switch back from
9313 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
9314 -- 0 .. 1, but the cases are rare and it is not worth the effort.
9315 -- Failing to do this switching back is only an efficiency issue.
9317 elsif No
(Lo
) or else Lo
< LLLo
or else Hi
> LLHi
then
9319 -- OK, we are definitely outside the range of Long_Long_Integer. The
9320 -- question is whether to move to Bignum mode, or stay in the domain
9321 -- of Long_Long_Integer, signalling that an overflow check is needed.
9323 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
9324 -- the Bignum business. In ELIMINATED mode, we will normally move
9325 -- into Bignum mode, but there is an exception if neither of our
9326 -- operands is Bignum now, and we are at the top level (Top_Level
9327 -- set True). In this case, there is no point in moving into Bignum
9328 -- mode to prevent overflow if the caller will immediately convert
9329 -- the Bignum value back to LLI with an overflow check. It's more
9330 -- efficient to stay in LLI mode with an overflow check (if needed)
9332 if Check_Mode
= Minimized
9333 or else (Top_Level
and not Bignum_Operands
)
9335 if Do_Overflow_Check
(N
) then
9336 Enable_Overflow_Check
(N
);
9339 -- The result now has to be in Long_Long_Integer mode, so adjust
9340 -- the possible range to reflect this. Note these calls also
9341 -- change No_Uint values from the top level case to LLI bounds.
9346 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
9349 pragma Assert
(Check_Mode
= Eliminated
);
9358 Fent
:= RTE
(RE_Big_Abs
);
9361 Fent
:= RTE
(RE_Big_Add
);
9364 Fent
:= RTE
(RE_Big_Div
);
9367 Fent
:= RTE
(RE_Big_Exp
);
9370 Fent
:= RTE
(RE_Big_Neg
);
9373 Fent
:= RTE
(RE_Big_Mod
);
9375 when N_Op_Multiply
=>
9376 Fent
:= RTE
(RE_Big_Mul
);
9379 Fent
:= RTE
(RE_Big_Rem
);
9381 when N_Op_Subtract
=>
9382 Fent
:= RTE
(RE_Big_Sub
);
9384 -- Anything else is an internal error, this includes the
9385 -- N_Op_Plus case, since how can plus cause the result
9386 -- to be out of range if the operand is in range?
9389 raise Program_Error
;
9392 -- Construct argument list for Bignum call, converting our
9393 -- operands to Bignum form if they are not already there.
9398 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
9401 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
9403 -- Now rewrite the arithmetic operator with a call to the
9404 -- corresponding bignum function.
9407 Make_Function_Call
(Loc
,
9408 Name
=> New_Occurrence_Of
(Fent
, Loc
),
9409 Parameter_Associations
=> Args
));
9410 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
9412 -- Indicate result is Bignum mode
9420 -- Otherwise we are in range of Long_Long_Integer, so no overflow
9421 -- check is required, at least not yet.
9424 Set_Do_Overflow_Check
(N
, False);
9427 -- Here we are not in Bignum territory, but we may have long long
9428 -- integer operands that need special handling. First a special check:
9429 -- If an exponentiation operator exponent is of type Long_Long_Integer,
9430 -- it means we converted it to prevent overflow, but exponentiation
9431 -- requires a Natural right operand, so convert it back to Natural.
9432 -- This conversion may raise an exception which is fine.
9434 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
9435 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
9438 -- Here we will do the operation in Long_Long_Integer. We do this even
9439 -- if we know an overflow check is required, better to do this in long
9440 -- long integer mode, since we are less likely to overflow.
9442 -- Convert right or only operand to Long_Long_Integer, except that
9443 -- we do not touch the exponentiation right operand.
9445 if Nkind
(N
) /= N_Op_Expon
then
9446 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
9449 -- Convert left operand to Long_Long_Integer for binary case
9452 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
9455 -- Reset node to unanalyzed
9457 Set_Analyzed
(N
, False);
9458 Set_Etype
(N
, Empty
);
9459 Set_Entity
(N
, Empty
);
9461 -- Now analyze this new node. This reanalysis will complete processing
9462 -- for the node. In particular we will complete the expansion of an
9463 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
9464 -- we will complete any division checks (since we have not changed the
9465 -- setting of the Do_Division_Check flag).
9467 -- We do this reanalysis in STRICT mode to avoid recursion into the
9468 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
9471 SG
: constant Overflow_Mode_Type
:=
9472 Scope_Suppress
.Overflow_Mode_General
;
9473 SA
: constant Overflow_Mode_Type
:=
9474 Scope_Suppress
.Overflow_Mode_Assertions
;
9477 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9478 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9480 if not Do_Overflow_Check
(N
) then
9481 Reanalyze
(LLIB
, Suppress
=> True);
9486 Scope_Suppress
.Overflow_Mode_General
:= SG
;
9487 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
9489 end Minimize_Eliminate_Overflows
;
9491 -------------------------
9492 -- Overflow_Check_Mode --
9493 -------------------------
9495 function Overflow_Check_Mode
return Overflow_Mode_Type
is
9497 if In_Assertion_Expr
= 0 then
9498 return Scope_Suppress
.Overflow_Mode_General
;
9500 return Scope_Suppress
.Overflow_Mode_Assertions
;
9502 end Overflow_Check_Mode
;
9504 --------------------------------
9505 -- Overflow_Checks_Suppressed --
9506 --------------------------------
9508 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9510 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9511 return Is_Check_Suppressed
(E
, Overflow_Check
);
9513 return Scope_Suppress
.Suppress
(Overflow_Check
);
9515 end Overflow_Checks_Suppressed
;
9517 ---------------------------------
9518 -- Predicate_Checks_Suppressed --
9519 ---------------------------------
9521 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9523 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9524 return Is_Check_Suppressed
(E
, Predicate_Check
);
9526 return Scope_Suppress
.Suppress
(Predicate_Check
);
9528 end Predicate_Checks_Suppressed
;
9530 -----------------------------
9531 -- Range_Checks_Suppressed --
9532 -----------------------------
9534 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9537 if Kill_Range_Checks
(E
) then
9540 elsif Checks_May_Be_Suppressed
(E
) then
9541 return Is_Check_Suppressed
(E
, Range_Check
);
9545 return Scope_Suppress
.Suppress
(Range_Check
);
9546 end Range_Checks_Suppressed
;
9548 -----------------------------------------
9549 -- Range_Or_Validity_Checks_Suppressed --
9550 -----------------------------------------
9552 -- Note: the coding would be simpler here if we simply made appropriate
9553 -- calls to Range/Validity_Checks_Suppressed, but that would result in
9554 -- duplicated checks which we prefer to avoid.
9556 function Range_Or_Validity_Checks_Suppressed
9557 (Expr
: Node_Id
) return Boolean
9560 -- Immediate return if scope checks suppressed for either check
9562 if Scope_Suppress
.Suppress
(Range_Check
)
9564 Scope_Suppress
.Suppress
(Validity_Check
)
9569 -- If no expression, that's odd, decide that checks are suppressed,
9570 -- since we don't want anyone trying to do checks in this case, which
9571 -- is most likely the result of some other error.
9577 -- Expression is present, so perform suppress checks on type
9580 Typ
: constant Entity_Id
:= Etype
(Expr
);
9582 if Checks_May_Be_Suppressed
(Typ
)
9583 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
9585 Is_Check_Suppressed
(Typ
, Validity_Check
))
9591 -- If expression is an entity name, perform checks on this entity
9593 if Is_Entity_Name
(Expr
) then
9595 Ent
: constant Entity_Id
:= Entity
(Expr
);
9597 if Checks_May_Be_Suppressed
(Ent
) then
9598 return Is_Check_Suppressed
(Ent
, Range_Check
)
9599 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
9604 -- If we fall through, no checks suppressed
9607 end Range_Or_Validity_Checks_Suppressed
;
9613 procedure Remove_Checks
(Expr
: Node_Id
) is
9614 function Process
(N
: Node_Id
) return Traverse_Result
;
9615 -- Process a single node during the traversal
9617 procedure Traverse
is new Traverse_Proc
(Process
);
9618 -- The traversal procedure itself
9624 function Process
(N
: Node_Id
) return Traverse_Result
is
9626 if Nkind
(N
) not in N_Subexpr
then
9630 Set_Do_Range_Check
(N
, False);
9634 Traverse
(Left_Opnd
(N
));
9637 when N_Attribute_Reference
=>
9638 Set_Do_Overflow_Check
(N
, False);
9641 Set_Do_Overflow_Check
(N
, False);
9645 Set_Do_Division_Check
(N
, False);
9648 Set_Do_Length_Check
(N
, False);
9651 Set_Do_Division_Check
(N
, False);
9654 Set_Do_Length_Check
(N
, False);
9657 Set_Do_Division_Check
(N
, False);
9660 Set_Do_Length_Check
(N
, False);
9667 Traverse
(Left_Opnd
(N
));
9670 when N_Selected_Component
=>
9671 Set_Do_Discriminant_Check
(N
, False);
9673 when N_Type_Conversion
=>
9674 Set_Do_Length_Check
(N
, False);
9675 Set_Do_Overflow_Check
(N
, False);
9684 -- Start of processing for Remove_Checks
9690 ----------------------------
9691 -- Selected_Length_Checks --
9692 ----------------------------
9694 function Selected_Length_Checks
9696 Target_Typ
: Entity_Id
;
9697 Source_Typ
: Entity_Id
;
9698 Warn_Node
: Node_Id
) return Check_Result
9700 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
9703 Expr_Actual
: Node_Id
;
9705 Cond
: Node_Id
:= Empty
;
9706 Do_Access
: Boolean := False;
9707 Wnode
: Node_Id
:= Warn_Node
;
9708 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9709 Num_Checks
: Natural := 0;
9711 procedure Add_Check
(N
: Node_Id
);
9712 -- Adds the action given to Ret_Result if N is non-Empty
9714 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
9715 -- Return E'Length (Indx)
9717 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9718 -- Return N'Length (Indx)
9720 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
9721 -- True for equal literals and for nodes that denote the same constant
9722 -- entity, even if its value is not a static constant. This includes the
9723 -- case of a discriminal reference within an init proc. Removes some
9724 -- obviously superfluous checks.
9726 function Length_E_Cond
9727 (Exptyp
: Entity_Id
;
9729 Indx
: Nat
) return Node_Id
;
9730 -- Returns expression to compute:
9731 -- Typ'Length /= Exptyp'Length
9733 function Length_N_Cond
9736 Indx
: Nat
) return Node_Id
;
9737 -- Returns expression to compute:
9738 -- Typ'Length /= Exp'Length
9740 function Length_Mismatch_Info_Message
9741 (Left_Element_Count
: Unat
;
9742 Right_Element_Count
: Unat
) return String;
9743 -- Returns a message indicating how many elements were expected
9744 -- (Left_Element_Count) and how many were found (Right_Element_Count).
9750 procedure Add_Check
(N
: Node_Id
) is
9754 -- We do not support inserting more than 2 checks on the same
9755 -- node. If this happens it means we have already added an
9756 -- unconditional raise, so we can skip the other checks safely
9757 -- since N will always raise an exception.
9759 if Num_Checks
= 2 then
9763 pragma Assert
(Num_Checks
<= 1);
9764 Num_Checks
:= Num_Checks
+ 1;
9765 Ret_Result
(Num_Checks
) := N
;
9773 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
9774 SE
: constant Entity_Id
:= Scope
(E
);
9776 E1
: Entity_Id
:= E
;
9779 if Ekind
(Scope
(E
)) = E_Record_Type
9780 and then Has_Discriminants
(Scope
(E
))
9782 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
9785 Insert_Action
(Expr
, N
);
9786 E1
:= Defining_Identifier
(N
);
9790 if Ekind
(E1
) = E_String_Literal_Subtype
then
9792 Make_Integer_Literal
(Loc
,
9793 Intval
=> String_Literal_Length
(E1
));
9795 elsif SE
/= Standard_Standard
9796 and then Ekind
(Scope
(SE
)) = E_Protected_Type
9797 and then Has_Discriminants
(Scope
(SE
))
9798 and then Has_Completion
(Scope
(SE
))
9799 and then not Inside_Init_Proc
9801 -- If the type whose length is needed is a private component
9802 -- constrained by a discriminant, we must expand the 'Length
9803 -- attribute into an explicit computation, using the discriminal
9804 -- of the current protected operation. This is because the actual
9805 -- type of the prival is constructed after the protected opera-
9806 -- tion has been fully expanded.
9809 Indx_Type
: Node_Id
;
9810 Bounds
: Range_Nodes
;
9811 Do_Expand
: Boolean := False;
9814 Indx_Type
:= First_Index
(E
);
9816 for J
in 1 .. Indx
- 1 loop
9817 Next_Index
(Indx_Type
);
9820 Bounds
:= Get_Index_Bounds
(Indx_Type
);
9822 if Nkind
(Bounds
.First
) = N_Identifier
9823 and then Ekind
(Entity
(Bounds
.First
)) = E_In_Parameter
9825 Bounds
.First
:= Get_Discriminal
(E
, Bounds
.First
);
9829 if Nkind
(Bounds
.Last
) = N_Identifier
9830 and then Ekind
(Entity
(Bounds
.Last
)) = E_In_Parameter
9832 Bounds
.Last
:= Get_Discriminal
(E
, Bounds
.Last
);
9837 if not Is_Entity_Name
(Bounds
.First
) then
9839 Duplicate_Subexpr_No_Checks
(Bounds
.First
);
9842 if not Is_Entity_Name
(Bounds
.Last
) then
9843 Bounds
.First
:= Duplicate_Subexpr_No_Checks
(Bounds
.Last
);
9849 Make_Op_Subtract
(Loc
,
9850 Left_Opnd
=> Bounds
.Last
,
9851 Right_Opnd
=> Bounds
.First
),
9853 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
9858 Make_Attribute_Reference
(Loc
,
9859 Attribute_Name
=> Name_Length
,
9861 New_Occurrence_Of
(E1
, Loc
));
9864 Set_Expressions
(N
, New_List
(
9865 Make_Integer_Literal
(Loc
, Indx
)));
9874 Make_Attribute_Reference
(Loc
,
9875 Attribute_Name
=> Name_Length
,
9877 New_Occurrence_Of
(E1
, Loc
));
9880 Set_Expressions
(N
, New_List
(
9881 Make_Integer_Literal
(Loc
, Indx
)));
9892 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9895 Make_Attribute_Reference
(Loc
,
9896 Attribute_Name
=> Name_Length
,
9898 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9899 Expressions
=> New_List
(
9900 Make_Integer_Literal
(Loc
, Indx
)));
9907 function Length_E_Cond
9908 (Exptyp
: Entity_Id
;
9910 Indx
: Nat
) return Node_Id
9915 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9916 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
9923 function Length_N_Cond
9926 Indx
: Nat
) return Node_Id
9931 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9932 Right_Opnd
=> Get_N_Length
(Exp
, Indx
));
9935 ----------------------------------
9936 -- Length_Mismatch_Info_Message --
9937 ----------------------------------
9939 function Length_Mismatch_Info_Message
9940 (Left_Element_Count
: Unat
;
9941 Right_Element_Count
: Unat
) return String
9944 function Plural_Vs_Singular_Ending
(Count
: Unat
) return String;
9945 -- Returns an empty string if Count is 1; otherwise returns "s"
9947 function Plural_Vs_Singular_Ending
(Count
: Unat
) return String is
9954 end Plural_Vs_Singular_Ending
;
9958 & UI_Image
(Left_Element_Count
, Format
=> Decimal
)
9960 & Plural_Vs_Singular_Ending
(Left_Element_Count
)
9962 & UI_Image
(Right_Element_Count
, Format
=> Decimal
)
9964 & Plural_Vs_Singular_Ending
(Right_Element_Count
);
9965 -- "Format => Decimal" above is needed because otherwise UI_Image
9966 -- can sometimes return a hexadecimal number 16#...#, but "#" means
9967 -- something special to Errout. A previous version used the default
9968 -- Auto, which was essentially the same bug as documented here:
9969 -- https://xkcd.com/327/ .
9970 end Length_Mismatch_Info_Message
;
9976 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
9979 (Nkind
(L
) = N_Integer_Literal
9980 and then Nkind
(R
) = N_Integer_Literal
9981 and then Intval
(L
) = Intval
(R
))
9985 and then Ekind
(Entity
(L
)) = E_Constant
9986 and then ((Is_Entity_Name
(R
)
9987 and then Entity
(L
) = Entity
(R
))
9989 (Nkind
(R
) = N_Type_Conversion
9990 and then Is_Entity_Name
(Expression
(R
))
9991 and then Entity
(L
) = Entity
(Expression
(R
)))))
9995 and then Ekind
(Entity
(R
)) = E_Constant
9996 and then Nkind
(L
) = N_Type_Conversion
9997 and then Is_Entity_Name
(Expression
(L
))
9998 and then Entity
(R
) = Entity
(Expression
(L
)))
10001 (Is_Entity_Name
(L
)
10002 and then Is_Entity_Name
(R
)
10003 and then Entity
(L
) = Entity
(R
)
10004 and then Ekind
(Entity
(L
)) = E_In_Parameter
10005 and then Inside_Init_Proc
);
10008 -- Start of processing for Selected_Length_Checks
10011 -- Checks will be applied only when generating code
10013 if not Expander_Active
then
10017 if Target_Typ
= Any_Type
10018 or else Target_Typ
= Any_Composite
10019 or else Raises_Constraint_Error
(Expr
)
10028 T_Typ
:= Target_Typ
;
10030 if No
(Source_Typ
) then
10031 S_Typ
:= Etype
(Expr
);
10033 S_Typ
:= Source_Typ
;
10036 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
10040 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
10041 S_Typ
:= Designated_Type
(S_Typ
);
10042 T_Typ
:= Designated_Type
(T_Typ
);
10045 -- A simple optimization for the null case
10047 if Known_Null
(Expr
) then
10052 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
10053 if Is_Constrained
(T_Typ
) then
10055 -- The checking code to be generated will freeze the corresponding
10056 -- array type. However, we must freeze the type now, so that the
10057 -- freeze node does not appear within the generated if expression,
10058 -- but ahead of it.
10060 Freeze_Before
(Expr
, T_Typ
);
10062 Expr_Actual
:= Get_Referenced_Object
(Expr
);
10063 Exptyp
:= Get_Actual_Subtype
(Expr
);
10065 if Is_Access_Type
(Exptyp
) then
10066 Exptyp
:= Designated_Type
(Exptyp
);
10069 -- String_Literal case. This needs to be handled specially be-
10070 -- cause no index types are available for string literals. The
10071 -- condition is simply:
10073 -- T_Typ'Length = string-literal-length
10075 if Nkind
(Expr_Actual
) = N_String_Literal
10076 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
10080 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
10082 Make_Integer_Literal
(Loc
,
10084 String_Literal_Length
(Etype
(Expr_Actual
))));
10086 -- General array case. Here we have a usable actual subtype for
10087 -- the expression, and the condition is built from the two types
10090 -- T_Typ'Length /= Exptyp'Length or else
10091 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
10092 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
10095 elsif Is_Constrained
(Exptyp
) then
10097 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
10101 L_Bounds
: Range_Nodes
;
10102 R_Bounds
: Range_Nodes
;
10105 Ref_Node
: Node_Id
;
10108 -- At the library level, we need to ensure that the type of
10109 -- the object is elaborated before the check itself is
10110 -- emitted. This is only done if the object is in the
10111 -- current compilation unit, otherwise the type is frozen
10112 -- and elaborated in its unit.
10114 if Is_Itype
(Exptyp
)
10116 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
10118 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
10119 and then In_Open_Scopes
(Scope
(Exptyp
))
10121 Ref_Node
:= Make_Itype_Reference
(Sloc
(Expr
));
10122 Set_Itype
(Ref_Node
, Exptyp
);
10123 Insert_Action
(Expr
, Ref_Node
);
10126 L_Index
:= First_Index
(T_Typ
);
10127 R_Index
:= First_Index
(Exptyp
);
10129 for Indx
in 1 .. Ndims
loop
10130 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
10132 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
10134 L_Bounds
:= Get_Index_Bounds
(L_Index
);
10135 R_Bounds
:= Get_Index_Bounds
(R_Index
);
10137 -- Deal with compile time length check. Note that we
10138 -- skip this in the access case, because the access
10139 -- value may be null, so we cannot know statically.
10142 and then Compile_Time_Known_Value
(L_Bounds
.First
)
10143 and then Compile_Time_Known_Value
(L_Bounds
.Last
)
10144 and then Compile_Time_Known_Value
(R_Bounds
.First
)
10145 and then Compile_Time_Known_Value
(R_Bounds
.Last
)
10147 if Expr_Value
(L_Bounds
.Last
) >=
10148 Expr_Value
(L_Bounds
.First
)
10150 L_Length
:= Expr_Value
(L_Bounds
.Last
) -
10151 Expr_Value
(L_Bounds
.First
) + 1;
10153 L_Length
:= UI_From_Int
(0);
10156 if Expr_Value
(R_Bounds
.Last
) >=
10157 Expr_Value
(R_Bounds
.First
)
10159 R_Length
:= Expr_Value
(R_Bounds
.Last
) -
10160 Expr_Value
(R_Bounds
.First
) + 1;
10162 R_Length
:= UI_From_Int
(0);
10165 if L_Length
> R_Length
then
10167 (Compile_Time_Constraint_Error
10168 (Wnode
, "too few elements for}!!??", T_Typ
,
10169 Extra_Msg
=> Length_Mismatch_Info_Message
10170 (L_Length
, R_Length
)));
10172 elsif L_Length
< R_Length
then
10174 (Compile_Time_Constraint_Error
10175 (Wnode
, "too many elements for}!!??", T_Typ
,
10176 Extra_Msg
=> Length_Mismatch_Info_Message
10177 (L_Length
, R_Length
)));
10180 -- The comparison for an individual index subtype
10181 -- is omitted if the corresponding index subtypes
10182 -- statically match, since the result is known to
10183 -- be true. Note that this test is worth while even
10184 -- though we do static evaluation, because non-static
10185 -- subtypes can statically match.
10188 Subtypes_Statically_Match
10189 (Etype
(L_Index
), Etype
(R_Index
))
10192 (Same_Bounds
(L_Bounds
.First
, R_Bounds
.First
)
10194 Same_Bounds
(L_Bounds
.Last
, R_Bounds
.Last
))
10197 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
10206 -- Handle cases where we do not get a usable actual subtype that
10207 -- is constrained. This happens for example in the function call
10208 -- and explicit dereference cases. In these cases, we have to get
10209 -- the length or range from the expression itself, making sure we
10210 -- do not evaluate it more than once.
10212 -- Here Expr is the original expression, or more properly the
10213 -- result of applying Duplicate_Expr to the original tree, forcing
10214 -- the result to be a name.
10218 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
10221 -- Build the condition for the explicit dereference case
10223 for Indx
in 1 .. Ndims
loop
10225 (Cond
, Length_N_Cond
(Expr
, T_Typ
, Indx
));
10232 -- Construct the test and insert into the tree
10234 if Present
(Cond
) then
10236 Cond
:= Guard_Access
(Cond
, Loc
, Expr
);
10240 (Make_Raise_Constraint_Error
(Loc
,
10242 Reason
=> CE_Length_Check_Failed
));
10246 end Selected_Length_Checks
;
10248 ---------------------------
10249 -- Selected_Range_Checks --
10250 ---------------------------
10252 function Selected_Range_Checks
10254 Target_Typ
: Entity_Id
;
10255 Source_Typ
: Entity_Id
;
10256 Warn_Node
: Node_Id
) return Check_Result
10258 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
10261 Expr_Actual
: Node_Id
;
10262 Exptyp
: Entity_Id
;
10263 Cond
: Node_Id
:= Empty
;
10264 Do_Access
: Boolean := False;
10265 Wnode
: Node_Id
:= Warn_Node
;
10266 Ret_Result
: Check_Result
:= (Empty
, Empty
);
10267 Num_Checks
: Natural := 0;
10269 procedure Add_Check
(N
: Node_Id
);
10270 -- Adds the action given to Ret_Result if N is non-Empty
10272 function Discrete_Range_Cond
10274 Typ
: Entity_Id
) return Node_Id
;
10275 -- Returns expression to compute:
10276 -- Low_Bound (Exp) < Typ'First
10278 -- High_Bound (Exp) > Typ'Last
10280 function Discrete_Expr_Cond
10282 Typ
: Entity_Id
) return Node_Id
;
10283 -- Returns expression to compute:
10288 function Get_E_First_Or_Last
10292 Nam
: Name_Id
) return Node_Id
;
10293 -- Returns an attribute reference
10294 -- E'First or E'Last
10295 -- with a source location of Loc.
10297 -- Nam is Name_First or Name_Last, according to which attribute is
10298 -- desired. If Indx is non-zero, it is passed as a literal in the
10299 -- Expressions of the attribute reference (identifying the desired
10300 -- array dimension).
10302 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
10303 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
10304 -- Returns expression to compute:
10305 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
10307 function Is_Cond_Expr_Ge
(N
: Node_Id
; V
: Node_Id
) return Boolean;
10308 function Is_Cond_Expr_Le
(N
: Node_Id
; V
: Node_Id
) return Boolean;
10309 -- Return True if N is a conditional expression whose dependent
10310 -- expressions are all known and greater/lower than or equal to V.
10312 function Range_E_Cond
10313 (Exptyp
: Entity_Id
;
10317 -- Returns expression to compute:
10318 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
10320 function Range_Equal_E_Cond
10321 (Exptyp
: Entity_Id
;
10323 Indx
: Nat
) return Node_Id
;
10324 -- Returns expression to compute:
10325 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
10327 function Range_N_Cond
10330 Indx
: Nat
) return Node_Id
;
10331 -- Return expression to compute:
10332 -- Exp'First < Typ'First or else Exp'Last > Typ'Last
10334 function "<" (Left
, Right
: Node_Id
) return Boolean
10335 is (if Is_Floating_Point_Type
(S_Typ
)
10336 then Expr_Value_R
(Left
) < Expr_Value_R
(Right
)
10337 else Expr_Value
(Left
) < Expr_Value
(Right
));
10338 function "<=" (Left
, Right
: Node_Id
) return Boolean
10339 is (if Is_Floating_Point_Type
(S_Typ
)
10340 then Expr_Value_R
(Left
) <= Expr_Value_R
(Right
)
10341 else Expr_Value
(Left
) <= Expr_Value
(Right
));
10342 -- Convenience comparison functions of integer or floating point values
10348 procedure Add_Check
(N
: Node_Id
) is
10350 if Present
(N
) then
10352 -- We do not support inserting more than 2 checks on the same
10353 -- node. If this happens it means we have already added an
10354 -- unconditional raise, so we can skip the other checks safely
10355 -- since N will always raise an exception.
10357 if Num_Checks
= 2 then
10361 pragma Assert
(Num_Checks
<= 1);
10362 Num_Checks
:= Num_Checks
+ 1;
10363 Ret_Result
(Num_Checks
) := N
;
10367 -------------------------
10368 -- Discrete_Expr_Cond --
10369 -------------------------
10371 function Discrete_Expr_Cond
10373 Typ
: Entity_Id
) return Node_Id
10381 Convert_To
(Base_Type
(Typ
),
10382 Duplicate_Subexpr_No_Checks
(Exp
)),
10384 Convert_To
(Base_Type
(Typ
),
10385 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
10390 Convert_To
(Base_Type
(Typ
),
10391 Duplicate_Subexpr_No_Checks
(Exp
)),
10395 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
10396 end Discrete_Expr_Cond
;
10398 -------------------------
10399 -- Discrete_Range_Cond --
10400 -------------------------
10402 function Discrete_Range_Cond
10404 Typ
: Entity_Id
) return Node_Id
10406 LB
: Node_Id
:= Low_Bound
(Exp
);
10407 HB
: Node_Id
:= High_Bound
(Exp
);
10409 Left_Opnd
: Node_Id
;
10410 Right_Opnd
: Node_Id
;
10413 if Nkind
(LB
) = N_Identifier
10414 and then Ekind
(Entity
(LB
)) = E_Discriminant
10416 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10419 -- If the index type has a fixed lower bound, then we require an
10420 -- exact match of the range's lower bound against that fixed lower
10423 if Is_Fixed_Lower_Bound_Index_Subtype
(Typ
) then
10428 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
10433 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
10435 -- Otherwise we do the expected less-than comparison
10442 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
10447 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
10450 if Nkind
(HB
) = N_Identifier
10451 and then Ekind
(Entity
(HB
)) = E_Discriminant
10453 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10460 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
10465 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
10467 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
10468 end Discrete_Range_Cond
;
10470 -------------------------
10471 -- Get_E_First_Or_Last --
10472 -------------------------
10474 function Get_E_First_Or_Last
10478 Nam
: Name_Id
) return Node_Id
10483 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
10488 return Make_Attribute_Reference
(Loc
,
10489 Prefix
=> New_Occurrence_Of
(E
, Loc
),
10490 Attribute_Name
=> Nam
,
10491 Expressions
=> Exprs
);
10492 end Get_E_First_Or_Last
;
10498 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10501 Make_Attribute_Reference
(Loc
,
10502 Attribute_Name
=> Name_First
,
10504 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10505 Expressions
=> New_List
(
10506 Make_Integer_Literal
(Loc
, Indx
)));
10513 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10516 Make_Attribute_Reference
(Loc
,
10517 Attribute_Name
=> Name_Last
,
10519 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10520 Expressions
=> New_List
(
10521 Make_Integer_Literal
(Loc
, Indx
)));
10524 ---------------------
10525 -- Is_Cond_Expr_Ge --
10526 ---------------------
10528 function Is_Cond_Expr_Ge
(N
: Node_Id
; V
: Node_Id
) return Boolean is
10530 -- Only if expressions are relevant for the time being
10532 if Nkind
(N
) = N_If_Expression
then
10534 Cond
: constant Node_Id
:= First
(Expressions
(N
));
10535 Thenx
: constant Node_Id
:= Next
(Cond
);
10536 Elsex
: constant Node_Id
:= Next
(Thenx
);
10539 return Compile_Time_Known_Value
(Thenx
)
10540 and then V
<= Thenx
10542 ((Compile_Time_Known_Value
(Elsex
) and then V
<= Elsex
)
10543 or else Is_Cond_Expr_Ge
(Elsex
, V
));
10549 end Is_Cond_Expr_Ge
;
10551 ---------------------
10552 -- Is_Cond_Expr_Le --
10553 ---------------------
10555 function Is_Cond_Expr_Le
(N
: Node_Id
; V
: Node_Id
) return Boolean is
10557 -- Only if expressions are relevant for the time being
10559 if Nkind
(N
) = N_If_Expression
then
10561 Cond
: constant Node_Id
:= First
(Expressions
(N
));
10562 Thenx
: constant Node_Id
:= Next
(Cond
);
10563 Elsex
: constant Node_Id
:= Next
(Thenx
);
10566 return Compile_Time_Known_Value
(Thenx
)
10567 and then Thenx
<= V
10569 ((Compile_Time_Known_Value
(Elsex
) and then Elsex
<= V
)
10570 or else Is_Cond_Expr_Le
(Elsex
, V
));
10576 end Is_Cond_Expr_Le
;
10582 function Range_E_Cond
10583 (Exptyp
: Entity_Id
;
10585 Indx
: Nat
) return Node_Id
10593 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10595 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10600 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10602 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10605 ------------------------
10606 -- Range_Equal_E_Cond --
10607 ------------------------
10609 function Range_Equal_E_Cond
10610 (Exptyp
: Entity_Id
;
10612 Indx
: Nat
) return Node_Id
10620 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10622 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10627 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10629 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10630 end Range_Equal_E_Cond
;
10636 function Range_N_Cond
10639 Indx
: Nat
) return Node_Id
10647 Get_N_First
(Exp
, Indx
),
10649 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10654 Get_N_Last
(Exp
, Indx
),
10656 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10659 -- Start of processing for Selected_Range_Checks
10662 -- Checks will be applied only when generating code. In GNATprove mode,
10663 -- we do not apply the checks, but we still call Selected_Range_Checks
10664 -- outside of generics to possibly issue errors on SPARK code when a
10665 -- run-time error can be detected at compile time.
10667 if Inside_A_Generic
or (not GNATprove_Mode
and not Expander_Active
) then
10671 if Target_Typ
= Any_Type
10672 or else Target_Typ
= Any_Composite
10673 or else Raises_Constraint_Error
(Expr
)
10682 T_Typ
:= Target_Typ
;
10684 if No
(Source_Typ
) then
10685 S_Typ
:= Etype
(Expr
);
10687 S_Typ
:= Source_Typ
;
10690 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
10694 -- The order of evaluating T_Typ before S_Typ seems to be critical
10695 -- because S_Typ can be derived from Etype (Expr), if it's not passed
10696 -- in, and since Node can be an N_Range node, it might be invalid.
10697 -- Should there be an assert check somewhere for taking the Etype of
10698 -- an N_Range node ???
10700 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
10701 S_Typ
:= Designated_Type
(S_Typ
);
10702 T_Typ
:= Designated_Type
(T_Typ
);
10705 -- A simple optimization for the null case
10707 if Known_Null
(Expr
) then
10712 -- For an N_Range Node, check for a null range and then if not
10713 -- null generate a range check action.
10715 if Nkind
(Expr
) = N_Range
then
10717 -- There's no point in checking a range against itself
10719 if Expr
= Scalar_Range
(T_Typ
) then
10724 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
10725 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
10726 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
10727 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
10729 LB
: Node_Id
:= Low_Bound
(Expr
);
10730 HB
: Node_Id
:= High_Bound
(Expr
);
10731 Known_LB
: Boolean := False;
10732 Known_HB
: Boolean := False;
10733 Check_Added
: Boolean := False;
10735 Out_Of_Range_L
: Boolean := False;
10736 Out_Of_Range_H
: Boolean := False;
10739 -- Compute what is known at compile time
10741 if Known_T_LB
and Known_T_HB
then
10742 if Compile_Time_Known_Value
(LB
) then
10745 -- There's no point in checking that a bound is within its
10746 -- own range so pretend that it is known in this case. First
10747 -- deal with low bound.
10749 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
10750 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
10755 -- Similarly; deal with the case where the low bound is a
10756 -- conditional expression whose result is greater than or
10757 -- equal to the target low bound.
10759 elsif Is_Cond_Expr_Ge
(LB
, T_LB
) then
10764 -- Likewise for the high bound
10766 if Compile_Time_Known_Value
(HB
) then
10769 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
10770 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
10775 elsif Is_Cond_Expr_Le
(HB
, T_HB
) then
10781 -- Check for the simple cases where we can do the check at
10782 -- compile time. This is skipped if we have an access type, since
10783 -- the access value may be null.
10785 if not Do_Access
and then Not_Null_Range
(LB
, HB
) then
10788 Out_Of_Range_L
:= LB
< T_LB
;
10791 if Known_T_HB
and not Out_Of_Range_L
then
10792 Out_Of_Range_L
:= T_HB
< LB
;
10795 if Out_Of_Range_L
then
10796 if No
(Warn_Node
) then
10798 (Compile_Time_Constraint_Error
10800 "static value out of range of}??", T_Typ
));
10801 Check_Added
:= True;
10805 (Compile_Time_Constraint_Error
10807 "static range out of bounds of}??", T_Typ
));
10808 Check_Added
:= True;
10813 -- Flag the case of a fixed-lower-bound index where the static
10814 -- bounds are not equal.
10817 and then Is_Fixed_Lower_Bound_Index_Subtype
(T_Typ
)
10818 and then Expr_Value
(LB
) /= Expr_Value
(T_LB
)
10821 (Compile_Time_Constraint_Error
10822 ((if Present
(Warn_Node
)
10823 then Warn_Node
else Low_Bound
(Expr
)),
10824 "static value does not equal lower bound of}??",
10826 Check_Added
:= True;
10831 Out_Of_Range_H
:= T_HB
< HB
;
10834 if Known_T_LB
and not Out_Of_Range_H
then
10835 Out_Of_Range_H
:= HB
< T_LB
;
10838 if Out_Of_Range_H
then
10839 if No
(Warn_Node
) then
10841 (Compile_Time_Constraint_Error
10842 (High_Bound
(Expr
),
10843 "static value out of range of}??", T_Typ
));
10844 Check_Added
:= True;
10848 (Compile_Time_Constraint_Error
10850 "static range out of bounds of}??", T_Typ
));
10851 Check_Added
:= True;
10857 -- Check for the case where not everything is static
10862 or else not Known_T_LB
10863 or else not Known_LB
10864 or else not Known_T_HB
10865 or else not Known_HB
)
10868 LB
: Node_Id
:= Low_Bound
(Expr
);
10869 HB
: Node_Id
:= High_Bound
(Expr
);
10872 -- If either bound is a discriminant and we are within the
10873 -- record declaration, it is a use of the discriminant in a
10874 -- constraint of a component, and nothing can be checked
10875 -- here. The check will be emitted within the init proc.
10876 -- Before then, the discriminal has no real meaning.
10877 -- Similarly, if the entity is a discriminal, there is no
10878 -- check to perform yet.
10880 -- The same holds within a discriminated synchronized type,
10881 -- where the discriminant may constrain a component or an
10884 if Nkind
(LB
) = N_Identifier
10885 and then Denotes_Discriminant
(LB
, True)
10887 if Current_Scope
= Scope
(Entity
(LB
))
10888 or else Is_Concurrent_Type
(Current_Scope
)
10889 or else Ekind
(Entity
(LB
)) /= E_Discriminant
10894 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10898 if Nkind
(HB
) = N_Identifier
10899 and then Denotes_Discriminant
(HB
, True)
10901 if Current_Scope
= Scope
(Entity
(HB
))
10902 or else Is_Concurrent_Type
(Current_Scope
)
10903 or else Ekind
(Entity
(HB
)) /= E_Discriminant
10908 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10912 Cond
:= Discrete_Range_Cond
(Expr
, T_Typ
);
10913 Set_Paren_Count
(Cond
, 1);
10916 Make_And_Then
(Loc
,
10920 Convert_To
(Base_Type
(Etype
(HB
)),
10921 Duplicate_Subexpr_No_Checks
(HB
)),
10923 Convert_To
(Base_Type
(Etype
(LB
)),
10924 Duplicate_Subexpr_No_Checks
(LB
))),
10925 Right_Opnd
=> Cond
);
10930 elsif Is_Scalar_Type
(S_Typ
) then
10932 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
10933 -- except the above simply sets a flag in the node and lets the
10934 -- check be generated based on the Etype of the expression.
10935 -- Sometimes, however we want to do a dynamic check against an
10936 -- arbitrary target type, so we do that here.
10938 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
10939 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
10941 -- For literals, we can tell if the constraint error will be
10942 -- raised at compile time, so we never need a dynamic check, but
10943 -- if the exception will be raised, then post the usual warning,
10944 -- and replace the literal with a raise constraint error
10945 -- expression. As usual, skip this for access types
10947 elsif Compile_Time_Known_Value
(Expr
) and then not Do_Access
then
10948 if Is_Out_Of_Range
(Expr
, T_Typ
) then
10950 -- Bounds of the type are static and the literal is out of
10951 -- range so output a warning message.
10953 if No
(Warn_Node
) then
10955 (Compile_Time_Constraint_Error
10956 (Expr
, "static value out of range of}??", T_Typ
));
10960 (Compile_Time_Constraint_Error
10961 (Wnode
, "static value out of range of}??", T_Typ
));
10964 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
10967 -- Here for the case of a non-static expression, we need a runtime
10968 -- check unless the source type range is guaranteed to be in the
10969 -- range of the target type.
10972 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
10973 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
10978 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
10979 if Is_Constrained
(T_Typ
) then
10980 Expr_Actual
:= Get_Referenced_Object
(Expr
);
10981 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
10983 if Is_Access_Type
(Exptyp
) then
10984 Exptyp
:= Designated_Type
(Exptyp
);
10987 -- String_Literal case. This needs to be handled specially be-
10988 -- cause no index types are available for string literals. The
10989 -- condition is simply:
10991 -- T_Typ'Length = string-literal-length
10993 if Nkind
(Expr_Actual
) = N_String_Literal
then
10996 -- General array case. Here we have a usable actual subtype for
10997 -- the expression, and the condition is built from the two types
10999 -- T_Typ'First < Exptyp'First or else
11000 -- T_Typ'Last > Exptyp'Last or else
11001 -- T_Typ'First(1) < Exptyp'First(1) or else
11002 -- T_Typ'Last(1) > Exptyp'Last(1) or else
11005 elsif Is_Constrained
(Exptyp
) then
11007 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11013 L_Index
:= First_Index
(T_Typ
);
11014 R_Index
:= First_Index
(Exptyp
);
11016 for Indx
in 1 .. Ndims
loop
11017 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
11019 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
11021 -- Deal with compile time length check. Note that we
11022 -- skip this in the access case, because the access
11023 -- value may be null, so we cannot know statically.
11026 Subtypes_Statically_Match
11027 (Etype
(L_Index
), Etype
(R_Index
))
11029 -- If the target type is constrained then we
11030 -- have to check for exact equality of bounds
11031 -- (required for qualified expressions).
11033 if Is_Constrained
(T_Typ
) then
11036 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
11039 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
11049 -- Handle cases where we do not get a usable actual subtype that
11050 -- is constrained. This happens for example in the function call
11051 -- and explicit dereference cases. In these cases, we have to get
11052 -- the length or range from the expression itself, making sure we
11053 -- do not evaluate it more than once.
11055 -- Here Expr is the original expression, or more properly the
11056 -- result of applying Duplicate_Expr to the original tree,
11057 -- forcing the result to be a name.
11061 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11064 -- Build the condition for the explicit dereference case
11066 for Indx
in 1 .. Ndims
loop
11068 (Cond
, Range_N_Cond
(Expr
, T_Typ
, Indx
));
11073 -- If the context is a qualified_expression where the subtype is
11074 -- an unconstrained array subtype with fixed-lower-bound indexes,
11075 -- then consistency checks must be done between the lower bounds
11076 -- of any such indexes and the corresponding lower bounds of the
11077 -- qualified array object.
11079 elsif Is_Fixed_Lower_Bound_Array_Subtype
(T_Typ
)
11080 and then Nkind
(Parent
(Expr
)) = N_Qualified_Expression
11081 and then not Do_Access
11084 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11086 Qual_Index
: Node_Id
;
11087 Expr_Index
: Node_Id
;
11090 Expr_Actual
:= Get_Referenced_Object
(Expr
);
11091 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
11093 Qual_Index
:= First_Index
(T_Typ
);
11094 Expr_Index
:= First_Index
(Exptyp
);
11096 for Indx
in 1 .. Ndims
loop
11097 if Nkind
(Expr_Index
) /= N_Raise_Constraint_Error
then
11099 -- If this index of the qualifying array subtype has
11100 -- a fixed lower bound, then apply a check that the
11101 -- corresponding lower bound of the array expression
11104 if Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Qual_Index
))
11110 Get_E_First_Or_Last
11111 (Loc
, Exptyp
, Indx
, Name_First
),
11114 (Type_Low_Bound
(Etype
(Qual_Index
)))));
11124 -- For a conversion to an unconstrained array type, generate an
11125 -- Action to check that the bounds of the source value are within
11126 -- the constraints imposed by the target type (RM 4.6(38)). No
11127 -- check is needed for a conversion to an access to unconstrained
11128 -- array type, as 4.6(24.15/2) requires the designated subtypes
11129 -- of the two access types to statically match.
11131 if Nkind
(Parent
(Expr
)) = N_Type_Conversion
11132 and then not Do_Access
11135 Opnd_Index
: Node_Id
;
11136 Targ_Index
: Node_Id
;
11137 Opnd_Range
: Node_Id
;
11140 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Expr
));
11141 Targ_Index
:= First_Index
(T_Typ
);
11142 while Present
(Opnd_Index
) loop
11144 -- If the index is a range, use its bounds. If it is an
11145 -- entity (as will be the case if it is a named subtype
11146 -- or an itype created for a slice) retrieve its range.
11148 if Is_Entity_Name
(Opnd_Index
)
11149 and then Is_Type
(Entity
(Opnd_Index
))
11151 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
11153 Opnd_Range
:= Opnd_Index
;
11156 if Nkind
(Opnd_Range
) = N_Range
then
11158 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11159 Assume_Valid
=> True)
11162 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11163 Assume_Valid
=> True)
11167 -- If null range, no check needed
11170 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
11172 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
11174 Expr_Value
(High_Bound
(Opnd_Range
)) <
11175 Expr_Value
(Low_Bound
(Opnd_Range
))
11179 elsif Is_Out_Of_Range
11180 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11181 Assume_Valid
=> True)
11184 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11185 Assume_Valid
=> True)
11188 (Compile_Time_Constraint_Error
11189 (Wnode
, "value out of range of}??", T_Typ
));
11194 Discrete_Range_Cond
11195 (Opnd_Range
, Etype
(Targ_Index
)));
11199 Next_Index
(Opnd_Index
);
11200 Next_Index
(Targ_Index
);
11207 -- Construct the test and insert into the tree
11209 if Present
(Cond
) then
11211 Cond
:= Guard_Access
(Cond
, Loc
, Expr
);
11215 (Make_Raise_Constraint_Error
(Loc
,
11217 Reason
=> CE_Range_Check_Failed
));
11221 end Selected_Range_Checks
;
11223 -------------------------------
11224 -- Storage_Checks_Suppressed --
11225 -------------------------------
11227 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
11229 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
11230 return Is_Check_Suppressed
(E
, Storage_Check
);
11232 return Scope_Suppress
.Suppress
(Storage_Check
);
11234 end Storage_Checks_Suppressed
;
11236 ---------------------------
11237 -- Tag_Checks_Suppressed --
11238 ---------------------------
11240 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
11243 and then Checks_May_Be_Suppressed
(E
)
11245 return Is_Check_Suppressed
(E
, Tag_Check
);
11247 return Scope_Suppress
.Suppress
(Tag_Check
);
11249 end Tag_Checks_Suppressed
;
11251 ---------------------------------------
11252 -- Validate_Alignment_Check_Warnings --
11253 ---------------------------------------
11255 procedure Validate_Alignment_Check_Warnings
is
11257 for J
in Alignment_Warnings
.First
.. Alignment_Warnings
.Last
loop
11259 AWR
: Alignment_Warnings_Record
11260 renames Alignment_Warnings
.Table
(J
);
11262 if Known_Alignment
(AWR
.E
)
11263 and then ((Present
(AWR
.A
)
11264 and then AWR
.A
mod Alignment
(AWR
.E
) = 0)
11265 or else (Present
(AWR
.P
)
11266 and then Has_Compatible_Alignment
11267 (AWR
.E
, AWR
.P
, True) =
11270 Delete_Warning_And_Continuations
(AWR
.W
);
11274 end Validate_Alignment_Check_Warnings
;
11276 --------------------------
11277 -- Validity_Check_Range --
11278 --------------------------
11280 procedure Validity_Check_Range
11282 Related_Id
: Entity_Id
:= Empty
) is
11284 if Validity_Checks_On
and Validity_Check_Operands
then
11285 if Nkind
(N
) = N_Range
then
11287 (Expr
=> Low_Bound
(N
),
11288 Related_Id
=> Related_Id
,
11289 Is_Low_Bound
=> True);
11292 (Expr
=> High_Bound
(N
),
11293 Related_Id
=> Related_Id
,
11294 Is_High_Bound
=> True);
11297 end Validity_Check_Range
;