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 Deref
: Boolean := False;
2726 Fun
: Entity_Id
:= Empty
)
2728 Loc
: constant Source_Ptr
:= Sloc
(N
);
2729 Check_Disabled
: constant Boolean :=
2730 not Predicate_Enabled
(Typ
)
2731 or else not Predicate_Check_In_Scope
(N
);
2739 while Present
(S
) and then not Is_Subprogram
(S
) loop
2743 -- If the check appears within the predicate function itself, it means
2744 -- that the user specified a check whose formal is the predicated
2745 -- subtype itself, rather than some covering type. This is likely to be
2746 -- a common error, and thus deserves a warning. We want to emit this
2747 -- warning even if predicate checking is disabled (in which case the
2748 -- warning is still useful even if it is not strictly accurate).
2750 if Present
(S
) and then S
= Predicate_Function
(Typ
) then
2752 ("predicate check includes a call to& that requires a "
2753 & "predicate check??", Parent
(N
), Fun
);
2755 ("\this will result in infinite recursion??", Parent
(N
));
2757 if Is_First_Subtype
(Typ
) then
2759 ("\use an explicit subtype of& to carry the predicate",
2763 if not Check_Disabled
then
2765 Make_Raise_Storage_Error
(Loc
,
2766 Reason
=> SE_Infinite_Recursion
));
2771 if Check_Disabled
then
2775 -- Normal case of predicate active
2777 -- If the expression is an IN parameter, the predicate will have
2778 -- been applied at the point of call. An additional check would
2779 -- be redundant, or will lead to out-of-scope references if the
2780 -- call appears within an aspect specification for a precondition.
2782 -- However, if the reference is within the body of the subprogram
2783 -- that declares the formal, the predicate can safely be applied,
2784 -- which may be necessary for a nested call whose formal has a
2785 -- different predicate.
2787 if Is_Entity_Name
(N
)
2788 and then Ekind
(Entity
(N
)) = E_In_Parameter
2791 In_Body
: Boolean := False;
2792 P
: Node_Id
:= Parent
(N
);
2795 while Present
(P
) loop
2796 if Nkind
(P
) = N_Subprogram_Body
2798 ((Present
(Corresponding_Spec
(P
))
2800 Corresponding_Spec
(P
) = Scope
(Entity
(N
)))
2802 Defining_Unit_Name
(Specification
(P
)) =
2818 -- If the type has a static predicate and the expression is known
2819 -- at compile time, see if the expression satisfies the predicate.
2821 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2823 if not Expander_Active
then
2828 if Nkind
(Par
) = N_Qualified_Expression
then
2829 Par
:= Parent
(Par
);
2832 -- Try to avoid creating a temporary if the expression is an aggregate
2834 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
2836 -- If the expression is an aggregate in an assignment, apply the
2837 -- check to the LHS after the assignment, rather than create a
2838 -- redundant temporary. This is only necessary in rare cases
2839 -- of array types (including strings) initialized with an
2840 -- aggregate with an "others" clause, either coming from source
2841 -- or generated by an Initialize_Scalars pragma.
2843 if Nkind
(Par
) = N_Assignment_Statement
then
2844 Insert_Action_After
(Par
,
2845 Make_Predicate_Check
2846 (Typ
, Duplicate_Subexpr
(Name
(Par
))));
2849 -- Similarly, if the expression is an aggregate in an object
2850 -- declaration, apply it to the object after the declaration.
2852 -- This is only necessary in cases of tagged extensions
2853 -- initialized with an aggregate with an "others => <>" clause,
2854 -- when the subtypes of LHS and RHS do not statically match or
2855 -- when we know the object's type will be rewritten later.
2856 -- The condition for the later is copied from the
2857 -- Analyze_Object_Declaration procedure when it actually builds the
2860 elsif Nkind
(Par
) = N_Object_Declaration
then
2861 if Subtypes_Statically_Match
2862 (Etype
(Defining_Identifier
(Par
)), Typ
)
2863 and then (Nkind
(N
) = N_Extension_Aggregate
2864 or else (Is_Definite_Subtype
(Typ
)
2865 and then Build_Default_Subtype_OK
(Typ
)))
2867 Insert_Action_After
(Par
,
2868 Make_Predicate_Check
(Typ
,
2869 New_Occurrence_Of
(Defining_Identifier
(Par
), Loc
)));
2876 -- For an entity of the type, generate a call to the predicate
2877 -- function, unless its type is an actual subtype, which is not
2878 -- visible outside of the enclosing subprogram.
2880 if Is_Entity_Name
(N
) and then not Is_Actual_Subtype
(Typ
) then
2881 Expr
:= New_Occurrence_Of
(Entity
(N
), Loc
);
2883 -- If the expression is not an entity, it may have side effects
2886 Expr
:= Duplicate_Subexpr
(N
);
2889 -- Make the dereference if requested
2892 Expr
:= Make_Explicit_Dereference
(Loc
, Prefix
=> Expr
);
2895 -- Disable checks to prevent an infinite recursion
2898 (N
, Make_Predicate_Check
(Typ
, Expr
), Suppress
=> All_Checks
);
2899 end Apply_Predicate_Check
;
2901 -----------------------
2902 -- Apply_Range_Check --
2903 -----------------------
2905 procedure Apply_Range_Check
2907 Target_Typ
: Entity_Id
;
2908 Source_Typ
: Entity_Id
:= Empty
;
2909 Insert_Node
: Node_Id
:= Empty
)
2911 Checks_On
: constant Boolean :=
2912 not Index_Checks_Suppressed
(Target_Typ
)
2914 not Range_Checks_Suppressed
(Target_Typ
);
2916 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2920 R_Result
: Check_Result
;
2923 -- Only apply checks when generating code. In GNATprove mode, we do not
2924 -- apply the checks, but we still call Selected_Range_Checks to possibly
2925 -- issue errors on SPARK code when a run-time error can be detected at
2928 if not GNATprove_Mode
then
2929 if not Expander_Active
or not Checks_On
then
2935 Selected_Range_Checks
(Expr
, Target_Typ
, Source_Typ
, Insert_Node
);
2937 if GNATprove_Mode
then
2941 for J
in 1 .. 2 loop
2942 R_Cno
:= R_Result
(J
);
2943 exit when No
(R_Cno
);
2945 -- The range check requires runtime evaluation. Depending on what its
2946 -- triggering condition is, the check may be converted into a compile
2947 -- time constraint check.
2949 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2950 and then Present
(Condition
(R_Cno
))
2952 Cond
:= Condition
(R_Cno
);
2954 -- Insert the range check before the related context. Note that
2955 -- this action analyses the triggering condition.
2957 if Present
(Insert_Node
) then
2958 Insert_Action
(Insert_Node
, R_Cno
);
2960 Insert_Action
(Expr
, R_Cno
);
2963 -- The triggering condition evaluates to True, the range check
2964 -- can be converted into a compile time constraint check.
2966 if Is_Entity_Name
(Cond
)
2967 and then Entity
(Cond
) = Standard_True
2969 -- Since an N_Range is technically not an expression, we have
2970 -- to set one of the bounds to C_E and then just flag the
2971 -- N_Range. The warning message will point to the lower bound
2972 -- and complain about a range, which seems OK.
2974 if Nkind
(Expr
) = N_Range
then
2975 Apply_Compile_Time_Constraint_Error
2977 "static range out of bounds of}??",
2978 CE_Range_Check_Failed
,
2982 Set_Raises_Constraint_Error
(Expr
);
2985 Apply_Compile_Time_Constraint_Error
2987 "static value out of range of}??",
2988 CE_Range_Check_Failed
,
2994 -- The range check raises Constraint_Error explicitly
2996 elsif Present
(Insert_Node
) then
2998 Make_Raise_Constraint_Error
(Sloc
(Insert_Node
),
2999 Reason
=> CE_Range_Check_Failed
);
3001 Insert_Action
(Insert_Node
, R_Cno
);
3004 Install_Static_Check
(R_Cno
, Loc
);
3007 end Apply_Range_Check
;
3009 ------------------------------
3010 -- Apply_Scalar_Range_Check --
3011 ------------------------------
3013 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
3014 -- off if it is already set on.
3016 procedure Apply_Scalar_Range_Check
3018 Target_Typ
: Entity_Id
;
3019 Source_Typ
: Entity_Id
:= Empty
;
3020 Fixed_Int
: Boolean := False)
3022 Parnt
: constant Node_Id
:= Parent
(Expr
);
3024 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
3025 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
3027 Is_Subscr_Ref
: Boolean;
3028 -- Set true if Expr is a subscript
3030 Is_Unconstrained_Subscr_Ref
: Boolean;
3031 -- Set true if Expr is a subscript of an unconstrained array. In this
3032 -- case we do not attempt to do an analysis of the value against the
3033 -- range of the subscript, since we don't know the actual subtype.
3036 -- Set to True if Expr should be regarded as a real value even though
3037 -- the type of Expr might be discrete.
3039 procedure Bad_Value
(Warn
: Boolean := False);
3040 -- Procedure called if value is determined to be out of range. Warn is
3041 -- True to force a warning instead of an error, even when SPARK_Mode is
3048 procedure Bad_Value
(Warn
: Boolean := False) is
3050 Apply_Compile_Time_Constraint_Error
3051 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
3057 -- Start of processing for Apply_Scalar_Range_Check
3060 -- Return if check obviously not needed
3063 -- Not needed inside generic
3067 -- Not needed if previous error
3069 or else Target_Typ
= Any_Type
3070 or else Nkind
(Expr
) = N_Error
3072 -- Not needed for non-scalar type
3074 or else not Is_Scalar_Type
(Target_Typ
)
3076 -- Not needed if we know node raises CE already
3078 or else Raises_Constraint_Error
(Expr
)
3083 -- Now, see if checks are suppressed
3086 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
3088 if Is_Subscr_Ref
then
3089 Arr
:= Prefix
(Parnt
);
3090 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
3092 if Is_Access_Type
(Arr_Typ
) then
3093 Arr_Typ
:= Designated_Type
(Arr_Typ
);
3097 if not Do_Range_Check
(Expr
) then
3099 -- Subscript reference. Check for Index_Checks suppressed
3101 if Is_Subscr_Ref
then
3103 -- Check array type and its base type
3105 if Index_Checks_Suppressed
(Arr_Typ
)
3106 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
3110 -- Check array itself if it is an entity name
3112 elsif Is_Entity_Name
(Arr
)
3113 and then Index_Checks_Suppressed
(Entity
(Arr
))
3117 -- Check expression itself if it is an entity name
3119 elsif Is_Entity_Name
(Expr
)
3120 and then Index_Checks_Suppressed
(Entity
(Expr
))
3125 -- All other cases, check for Range_Checks suppressed
3128 -- Check target type and its base type
3130 if Range_Checks_Suppressed
(Target_Typ
)
3131 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
3135 -- Check expression itself if it is an entity name
3137 elsif Is_Entity_Name
(Expr
)
3138 and then Range_Checks_Suppressed
(Entity
(Expr
))
3142 -- If Expr is part of an assignment statement, then check left
3143 -- side of assignment if it is an entity name.
3145 elsif Nkind
(Parnt
) = N_Assignment_Statement
3146 and then Is_Entity_Name
(Name
(Parnt
))
3147 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
3154 -- Do not set range checks if they are killed
3156 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
3157 and then Kill_Range_Check
(Expr
)
3162 -- Do not set range checks for any values from System.Scalar_Values
3163 -- since the whole idea of such values is to avoid checking them.
3165 if Is_Entity_Name
(Expr
)
3166 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
3171 -- Now see if we need a check
3173 if No
(Source_Typ
) then
3174 S_Typ
:= Etype
(Expr
);
3176 S_Typ
:= Source_Typ
;
3179 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
3183 Is_Unconstrained_Subscr_Ref
:=
3184 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
3186 -- Special checks for floating-point type
3188 if Is_Floating_Point_Type
(S_Typ
) then
3190 -- Always do a range check if the source type includes infinities and
3191 -- the target type does not include infinities. We do not do this if
3192 -- range checks are killed.
3193 -- If the expression is a literal and the bounds of the type are
3194 -- static constants it may be possible to optimize the check.
3196 if Has_Infinities
(S_Typ
)
3197 and then not Has_Infinities
(Target_Typ
)
3199 -- If the expression is a literal and the bounds of the type are
3200 -- static constants it may be possible to optimize the check.
3202 if Nkind
(Expr
) = N_Real_Literal
then
3204 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
3205 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
3208 if Compile_Time_Known_Value
(Tlo
)
3209 and then Compile_Time_Known_Value
(Thi
)
3210 and then Expr_Value_R
(Expr
) >= Expr_Value_R
(Tlo
)
3211 and then Expr_Value_R
(Expr
) <= Expr_Value_R
(Thi
)
3215 Enable_Range_Check
(Expr
);
3220 Enable_Range_Check
(Expr
);
3225 -- Return if we know expression is definitely in the range of the target
3226 -- type as determined by Determine_Range_To_Discrete. Right now we only
3227 -- do this for discrete target types, i.e. neither for fixed-point nor
3228 -- for floating-point types. But the additional less precise tests below
3229 -- catch these cases.
3231 -- Note: skip this if we are given a source_typ, since the point of
3232 -- supplying a Source_Typ is to stop us looking at the expression.
3233 -- We could sharpen this test to be out parameters only ???
3235 if Is_Discrete_Type
(Target_Typ
)
3236 and then not Is_Unconstrained_Subscr_Ref
3237 and then No
(Source_Typ
)
3240 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
3241 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
3244 if Compile_Time_Known_Value
(Tlo
)
3245 and then Compile_Time_Known_Value
(Thi
)
3248 OK
: Boolean := False; -- initialize to prevent warning
3249 Hiv
: constant Uint
:= Expr_Value
(Thi
);
3250 Lov
: constant Uint
:= Expr_Value
(Tlo
);
3251 Hi
: Uint
:= No_Uint
;
3252 Lo
: Uint
:= No_Uint
;
3255 -- If range is null, we for sure have a constraint error (we
3256 -- don't even need to look at the value involved, since all
3257 -- possible values will raise CE).
3261 -- When SPARK_Mode is On, force a warning instead of
3262 -- an error in that case, as this likely corresponds
3263 -- to deactivated code.
3265 Bad_Value
(Warn
=> SPARK_Mode
= On
);
3270 -- Otherwise determine range of value
3272 Determine_Range_To_Discrete
3273 (Expr
, OK
, Lo
, Hi
, Fixed_Int
, Assume_Valid
=> True);
3277 -- If definitely in range, all OK
3279 if Lo
>= Lov
and then Hi
<= Hiv
then
3282 -- If definitely not in range, warn
3284 elsif Lov
> Hi
or else Hiv
< Lo
then
3286 -- Ignore out of range values for System.Priority in
3287 -- CodePeer mode since the actual target compiler may
3288 -- provide a wider range.
3290 if not CodePeer_Mode
3291 or else not Is_RTE
(Target_Typ
, RE_Priority
)
3298 -- Otherwise we don't know
3310 Is_Floating_Point_Type
(S_Typ
)
3311 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
3313 -- Check if we can determine at compile time whether Expr is in the
3314 -- range of the target type. Note that if S_Typ is within the bounds
3315 -- of Target_Typ then this must be the case. This check is meaningful
3316 -- only if this is not a conversion between integer and real types,
3317 -- unless for a fixed-point type if Fixed_Int is set.
3319 if not Is_Unconstrained_Subscr_Ref
3320 and then (Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
3321 or else (Fixed_Int
and then Is_Discrete_Type
(Target_Typ
)))
3323 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
3325 -- Also check if the expression itself is in the range of the
3326 -- target type if it is a known at compile time value. We skip
3327 -- this test if S_Typ is set since for OUT and IN OUT parameters
3328 -- the Expr itself is not relevant to the checking.
3332 and then Is_In_Range
(Expr
, Target_Typ
,
3333 Assume_Valid
=> True,
3334 Fixed_Int
=> Fixed_Int
,
3335 Int_Real
=> Int_Real
)))
3339 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
3340 Assume_Valid
=> True,
3341 Fixed_Int
=> Fixed_Int
,
3342 Int_Real
=> Int_Real
)
3347 -- Floating-point case
3348 -- In the floating-point case, we only do range checks if the type is
3349 -- constrained. We definitely do NOT want range checks for unconstrained
3350 -- types, since we want to have infinities, except when
3351 -- Check_Float_Overflow is set.
3353 elsif Is_Floating_Point_Type
(S_Typ
) then
3354 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
3355 Enable_Range_Check
(Expr
);
3358 -- For all other cases we enable a range check unconditionally
3361 Enable_Range_Check
(Expr
);
3364 end Apply_Scalar_Range_Check
;
3366 ----------------------------------
3367 -- Apply_Selected_Length_Checks --
3368 ----------------------------------
3370 procedure Apply_Selected_Length_Checks
3372 Target_Typ
: Entity_Id
;
3373 Source_Typ
: Entity_Id
;
3374 Do_Static
: Boolean)
3376 Checks_On
: constant Boolean :=
3377 not Index_Checks_Suppressed
(Target_Typ
)
3379 not Length_Checks_Suppressed
(Target_Typ
);
3381 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
3385 R_Result
: Check_Result
;
3388 -- Only apply checks when generating code
3390 -- Note: this means that we lose some useful warnings if the expander
3393 if not Expander_Active
then
3398 Selected_Length_Checks
(Expr
, Target_Typ
, Source_Typ
, Empty
);
3400 for J
in 1 .. 2 loop
3401 R_Cno
:= R_Result
(J
);
3402 exit when No
(R_Cno
);
3404 -- A length check may mention an Itype which is attached to a
3405 -- subsequent node. At the top level in a package this can cause
3406 -- an order-of-elaboration problem, so we make sure that the itype
3407 -- is referenced now.
3409 if Ekind
(Current_Scope
) = E_Package
3410 and then Is_Compilation_Unit
(Current_Scope
)
3412 Ensure_Defined
(Target_Typ
, Expr
);
3414 if Present
(Source_Typ
) then
3415 Ensure_Defined
(Source_Typ
, Expr
);
3417 elsif Is_Itype
(Etype
(Expr
)) then
3418 Ensure_Defined
(Etype
(Expr
), Expr
);
3422 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3423 and then Present
(Condition
(R_Cno
))
3425 Cond
:= Condition
(R_Cno
);
3427 -- Case where node does not now have a dynamic check
3429 if not Has_Dynamic_Length_Check
(Expr
) then
3431 -- If checks are on, just insert the check
3434 Insert_Action
(Expr
, R_Cno
);
3436 if not Do_Static
then
3437 Set_Has_Dynamic_Length_Check
(Expr
);
3440 -- If checks are off, then analyze the length check after
3441 -- temporarily attaching it to the tree in case the relevant
3442 -- condition can be evaluated at compile time. We still want a
3443 -- compile time warning in this case.
3446 Set_Parent
(R_Cno
, Expr
);
3451 -- Output a warning if the condition is known to be True
3453 if Is_Entity_Name
(Cond
)
3454 and then Entity
(Cond
) = Standard_True
3456 Apply_Compile_Time_Constraint_Error
3457 (Expr
, "wrong length for array of}??",
3458 CE_Length_Check_Failed
,
3462 -- If we were only doing a static check, or if checks are not
3463 -- on, then we want to delete the check, since it is not needed.
3464 -- We do this by replacing the if statement by a null statement
3466 elsif Do_Static
or else not Checks_On
then
3467 Remove_Warning_Messages
(R_Cno
);
3468 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3472 Install_Static_Check
(R_Cno
, Loc
);
3475 end Apply_Selected_Length_Checks
;
3477 -------------------------------
3478 -- Apply_Static_Length_Check --
3479 -------------------------------
3481 procedure Apply_Static_Length_Check
3483 Target_Typ
: Entity_Id
;
3484 Source_Typ
: Entity_Id
:= Empty
)
3487 Apply_Selected_Length_Checks
3488 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3489 end Apply_Static_Length_Check
;
3491 -------------------------------------
3492 -- Apply_Subscript_Validity_Checks --
3493 -------------------------------------
3495 procedure Apply_Subscript_Validity_Checks
3497 No_Check_Needed
: Dimension_Set
:= Empty_Dimension_Set
) is
3500 Dimension
: Pos
:= 1;
3502 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3504 -- Loop through subscripts
3506 Sub
:= First
(Expressions
(Expr
));
3507 while Present
(Sub
) loop
3509 -- Check one subscript. Note that we do not worry about enumeration
3510 -- type with holes, since we will convert the value to a Pos value
3511 -- for the subscript, and that convert will do the necessary validity
3514 if No_Check_Needed
= Empty_Dimension_Set
3515 or else not No_Check_Needed
.Elements
(Dimension
)
3517 Ensure_Valid
(Sub
, Holes_OK
=> True);
3520 -- Move to next subscript
3523 Dimension
:= Dimension
+ 1;
3525 end Apply_Subscript_Validity_Checks
;
3527 ----------------------------------
3528 -- Apply_Type_Conversion_Checks --
3529 ----------------------------------
3531 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3532 Target_Type
: constant Entity_Id
:= Etype
(N
);
3533 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3534 Expr
: constant Node_Id
:= Expression
(N
);
3536 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3537 -- Note: if Etype (Expr) is a private type without discriminants, its
3538 -- full view might have discriminants with defaults, so we need the
3539 -- full view here to retrieve the constraints.
3541 procedure Make_Discriminant_Constraint_Check
3542 (Target_Type
: Entity_Id
;
3543 Expr_Type
: Entity_Id
);
3544 -- Generate a discriminant check based on the target type and expression
3547 ----------------------------------------
3548 -- Make_Discriminant_Constraint_Check --
3549 ----------------------------------------
3551 procedure Make_Discriminant_Constraint_Check
3552 (Target_Type
: Entity_Id
;
3553 Expr_Type
: Entity_Id
)
3555 Loc
: constant Source_Ptr
:= Sloc
(N
);
3557 Constraint
: Elmt_Id
;
3558 Discr_Value
: Node_Id
;
3561 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3562 Old_Constraints
: constant Elist_Id
:=
3563 Discriminant_Constraint
(Expr_Type
);
3566 -- Build an actual discriminant constraint list using the stored
3567 -- constraint, to verify that the expression of the parent type
3568 -- satisfies the constraints imposed by the (unconstrained) derived
3569 -- type. This applies to value conversions, not to view conversions
3572 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3573 while Present
(Constraint
) loop
3574 Discr_Value
:= Node
(Constraint
);
3576 if Is_Entity_Name
(Discr_Value
)
3577 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3579 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3582 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3584 -- Parent is constrained by new discriminant. Obtain
3585 -- Value of original discriminant in expression. If the
3586 -- new discriminant has been used to constrain more than
3587 -- one of the stored discriminants, this will provide the
3588 -- required consistency check.
3591 (Make_Selected_Component
(Loc
,
3593 Duplicate_Subexpr_No_Checks
3594 (Expr
, Name_Req
=> True),
3596 Make_Identifier
(Loc
, Chars
(Discr
))),
3600 -- Discriminant of more remote ancestor ???
3605 -- Derived type definition has an explicit value for this
3606 -- stored discriminant.
3610 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3614 Next_Elmt
(Constraint
);
3617 -- Use the unconstrained expression type to retrieve the
3618 -- discriminants of the parent, and apply momentarily the
3619 -- discriminant constraint synthesized above.
3621 -- Note: We use Expr_Type instead of Target_Type since the number of
3622 -- actual discriminants may be different due to the presence of
3623 -- stored discriminants and cause Build_Discriminant_Checks to fail.
3625 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3626 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3627 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3629 -- Conversion between access types requires that we check for null
3630 -- before checking discriminants.
3632 if Is_Access_Type
(Etype
(Expr
)) then
3633 Cond
:= Make_And_Then
(Loc
,
3637 Duplicate_Subexpr_No_Checks
3638 (Expr
, Name_Req
=> True),
3639 Right_Opnd
=> Make_Null
(Loc
)),
3640 Right_Opnd
=> Cond
);
3644 Make_Raise_Constraint_Error
(Loc
,
3646 Reason
=> CE_Discriminant_Check_Failed
));
3647 end Make_Discriminant_Constraint_Check
;
3649 -- Start of processing for Apply_Type_Conversion_Checks
3652 if Inside_A_Generic
then
3655 -- Skip these checks if serious errors detected, there are some nasty
3656 -- situations of incomplete trees that blow things up.
3658 elsif Serious_Errors_Detected
> 0 then
3661 -- Never generate discriminant checks for Unchecked_Union types
3663 elsif Present
(Expr_Type
)
3664 and then Is_Unchecked_Union
(Expr_Type
)
3668 -- Scalar type conversions of the form Target_Type (Expr) require a
3669 -- range check if we cannot be sure that Expr is in the base type of
3670 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3671 -- are not quite the same condition from an implementation point of
3672 -- view, but clearly the second includes the first.
3674 elsif Is_Scalar_Type
(Target_Type
) then
3676 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3677 -- If the Conversion_OK flag on the type conversion is set and no
3678 -- floating-point type is involved in the type conversion then
3679 -- fixed-point values must be read as integral values.
3681 Float_To_Int
: constant Boolean :=
3682 Is_Floating_Point_Type
(Expr_Type
)
3683 and then Is_Integer_Type
(Target_Type
);
3686 if not Overflow_Checks_Suppressed
(Target_Base
)
3687 and then not Overflow_Checks_Suppressed
(Target_Type
)
3689 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3690 and then not Float_To_Int
3692 -- A small optimization: the attribute 'Pos applied to an
3693 -- enumeration type has a known range, even though its type is
3694 -- Universal_Integer. So in numeric conversions it is usually
3695 -- within range of the target integer type. Use the static
3696 -- bounds of the base types to check. Disable this optimization
3697 -- in case of a descendant of a generic formal discrete type,
3698 -- because we don't necessarily know the upper bound yet.
3700 if Nkind
(Expr
) = N_Attribute_Reference
3701 and then Attribute_Name
(Expr
) = Name_Pos
3702 and then Is_Enumeration_Type
(Etype
(Prefix
(Expr
)))
3704 not Is_Generic_Type
(Root_Type
(Etype
(Prefix
(Expr
))))
3705 and then Is_Integer_Type
(Target_Type
)
3708 Enum_T
: constant Entity_Id
:=
3709 Root_Type
(Etype
(Prefix
(Expr
)));
3710 Int_T
: constant Entity_Id
:= Base_Type
(Target_Type
);
3711 Last_I
: constant Uint
:=
3712 Intval
(High_Bound
(Scalar_Range
(Int_T
)));
3716 -- Character types have no explicit literals, so we use
3717 -- the known number of characters in the type.
3719 if Root_Type
(Enum_T
) = Standard_Character
then
3720 Last_E
:= UI_From_Int
(255);
3722 elsif Enum_T
= Standard_Wide_Character
3723 or else Enum_T
= Standard_Wide_Wide_Character
3725 Last_E
:= UI_From_Int
(65535);
3730 (Entity
(High_Bound
(Scalar_Range
(Enum_T
))));
3733 if Last_E
> Last_I
then
3734 Activate_Overflow_Check
(N
);
3738 Activate_Overflow_Check
(N
);
3742 if not Range_Checks_Suppressed
(Target_Type
)
3743 and then not Range_Checks_Suppressed
(Expr_Type
)
3746 and then not GNATprove_Mode
3748 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3750 -- Raw conversions involving fixed-point types are expanded
3751 -- separately and do not need a Range_Check flag yet, except
3752 -- in GNATprove_Mode where this expansion is not performed.
3753 -- This does not apply to conversion where fixed-point types
3754 -- are treated as integers, which are precisely generated by
3759 or else (not Is_Fixed_Point_Type
(Expr_Type
)
3760 and then not Is_Fixed_Point_Type
(Target_Type
))
3762 Apply_Scalar_Range_Check
3763 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3766 Set_Do_Range_Check
(Expr
, False);
3769 -- If the target type has predicates, we need to indicate
3770 -- the need for a check, even if Determine_Range finds that
3771 -- the value is within bounds. This may be the case e.g for
3772 -- a division with a constant denominator.
3774 if Has_Predicates
(Target_Type
) then
3775 Enable_Range_Check
(Expr
);
3781 -- Generate discriminant constraint checks for access types on the
3782 -- designated target type's stored constraints.
3784 -- Do we need to generate subtype predicate checks here as well ???
3786 elsif Comes_From_Source
(N
)
3787 and then Ekind
(Target_Type
) = E_General_Access_Type
3789 -- Check that both of the designated types have known discriminants,
3790 -- and that such checks on the target type are not suppressed.
3792 and then Has_Discriminants
(Directly_Designated_Type
(Target_Type
))
3793 and then Has_Discriminants
(Directly_Designated_Type
(Expr_Type
))
3794 and then not Discriminant_Checks_Suppressed
3795 (Directly_Designated_Type
(Target_Type
))
3797 -- Verify the designated type of the target has stored constraints
3800 (Stored_Constraint
(Directly_Designated_Type
(Target_Type
)))
3802 Make_Discriminant_Constraint_Check
3803 (Target_Type
=> Directly_Designated_Type
(Target_Type
),
3804 Expr_Type
=> Directly_Designated_Type
(Expr_Type
));
3806 -- Create discriminant checks for the Target_Type's stored constraints
3808 elsif Comes_From_Source
(N
)
3809 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3810 and then Is_Record_Type
(Target_Type
)
3811 and then Is_Derived_Type
(Target_Type
)
3812 and then not Is_Tagged_Type
(Target_Type
)
3813 and then not Is_Constrained
(Target_Type
)
3814 and then Present
(Stored_Constraint
(Target_Type
))
3816 Make_Discriminant_Constraint_Check
(Target_Type
, Expr_Type
);
3818 -- For arrays, checks are set now, but conversions are applied during
3819 -- expansion, to take into accounts changes of representation. The
3820 -- checks become range checks on the base type or length checks on the
3821 -- subtype, depending on whether the target type is unconstrained or
3822 -- constrained. Note that the range check is put on the expression of a
3823 -- type conversion, while the length check is put on the type conversion
3826 elsif Is_Array_Type
(Target_Type
) then
3827 if Is_Constrained
(Target_Type
) then
3828 Set_Do_Length_Check
(N
);
3830 Set_Do_Range_Check
(Expr
);
3833 end Apply_Type_Conversion_Checks
;
3835 ----------------------------------------------
3836 -- Apply_Universal_Integer_Attribute_Checks --
3837 ----------------------------------------------
3839 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3840 Loc
: constant Source_Ptr
:= Sloc
(N
);
3841 Typ
: constant Entity_Id
:= Etype
(N
);
3844 if Inside_A_Generic
then
3847 -- Nothing to do if the result type is universal integer
3849 elsif Typ
= Universal_Integer
then
3852 -- Nothing to do if checks are suppressed
3854 elsif Range_Checks_Suppressed
(Typ
)
3855 and then Overflow_Checks_Suppressed
(Typ
)
3859 -- Nothing to do if the attribute does not come from source. The
3860 -- internal attributes we generate of this type do not need checks,
3861 -- and furthermore the attempt to check them causes some circular
3862 -- elaboration orders when dealing with packed types.
3864 elsif not Comes_From_Source
(N
) then
3867 -- If the prefix is a selected component that depends on a discriminant
3868 -- the check may improperly expose a discriminant instead of using
3869 -- the bounds of the object itself. Set the type of the attribute to
3870 -- the base type of the context, so that a check will be imposed when
3871 -- needed (e.g. if the node appears as an index).
3873 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3874 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3875 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3877 Set_Etype
(N
, Base_Type
(Typ
));
3879 -- Otherwise, replace the attribute node with a type conversion node
3880 -- whose expression is the attribute, retyped to universal integer, and
3881 -- whose subtype mark is the target type. The call to analyze this
3882 -- conversion will set range and overflow checks as required for proper
3883 -- detection of an out of range value.
3886 Set_Etype
(N
, Universal_Integer
);
3887 Set_Analyzed
(N
, True);
3890 Make_Type_Conversion
(Loc
,
3891 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3892 Expression
=> Relocate_Node
(N
)));
3894 Analyze_And_Resolve
(N
, Typ
);
3897 end Apply_Universal_Integer_Attribute_Checks
;
3899 -------------------------------------
3900 -- Atomic_Synchronization_Disabled --
3901 -------------------------------------
3903 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3904 -- using a bogus check called Atomic_Synchronization. This is to make it
3905 -- more convenient to get exactly the same semantics as [Un]Suppress.
3907 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3909 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3910 -- looks enabled, since it is never disabled.
3912 if Debug_Flag_Dot_E
then
3915 -- If debug flag d.d is set then always return True, i.e. all atomic
3916 -- sync looks disabled, since it always tests True.
3918 elsif Debug_Flag_Dot_D
then
3921 -- If entity present, then check result for that entity
3923 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3924 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3926 -- Otherwise result depends on current scope setting
3929 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3931 end Atomic_Synchronization_Disabled
;
3933 -------------------------------
3934 -- Build_Discriminant_Checks --
3935 -------------------------------
3937 function Build_Discriminant_Checks
3939 T_Typ
: Entity_Id
) return Node_Id
3941 Loc
: constant Source_Ptr
:= Sloc
(N
);
3944 Disc_Ent
: Entity_Id
;
3948 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3950 function Replace_Current_Instance
3951 (N
: Node_Id
) return Traverse_Result
;
3952 -- Replace a reference to the current instance of the type with the
3953 -- corresponding _init formal of the initialization procedure. Note:
3954 -- this function relies on us currently being within the initialization
3957 --------------------------------
3958 -- Aggregate_Discriminant_Val --
3959 --------------------------------
3961 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3965 -- The aggregate has been normalized with named associations. We use
3966 -- the Chars field to locate the discriminant to take into account
3967 -- discriminants in derived types, which carry the same name as those
3970 Assoc
:= First
(Component_Associations
(N
));
3971 while Present
(Assoc
) loop
3972 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3973 return Expression
(Assoc
);
3979 -- Discriminant must have been found in the loop above
3981 raise Program_Error
;
3982 end Aggregate_Discriminant_Val
;
3984 ------------------------------
3985 -- Replace_Current_Instance --
3986 ------------------------------
3988 function Replace_Current_Instance
3989 (N
: Node_Id
) return Traverse_Result
is
3991 if Is_Entity_Name
(N
)
3992 and then Etype
(N
) = Entity
(N
)
3995 New_Occurrence_Of
(First_Formal
(Current_Subprogram
), Loc
));
3999 end Replace_Current_Instance
;
4001 procedure Search_And_Replace_Current_Instance
is new
4002 Traverse_Proc
(Replace_Current_Instance
);
4004 -- Start of processing for Build_Discriminant_Checks
4007 -- Loop through discriminants evolving the condition
4010 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
4012 -- For a fully private type, use the discriminants of the parent type
4014 if Is_Private_Type
(T_Typ
)
4015 and then No
(Full_View
(T_Typ
))
4017 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
4019 Disc_Ent
:= First_Discriminant
(T_Typ
);
4022 while Present
(Disc
) loop
4023 Dval
:= Node
(Disc
);
4025 if Nkind
(Dval
) = N_Identifier
4026 and then Ekind
(Entity
(Dval
)) = E_Discriminant
4028 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
4030 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
4033 -- Replace references to the current instance of the type with the
4034 -- corresponding _init formal of the initialization procedure.
4036 if Within_Init_Proc
then
4037 Search_And_Replace_Current_Instance
(Dval
);
4040 -- If we have an Unchecked_Union node, we can infer the discriminants
4043 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
4045 Get_Discriminant_Value
(
4046 First_Discriminant
(T_Typ
),
4048 Stored_Constraint
(T_Typ
)));
4050 elsif Nkind
(N
) = N_Aggregate
then
4052 Duplicate_Subexpr_No_Checks
4053 (Aggregate_Discriminant_Val
(Disc_Ent
));
4055 elsif Is_Access_Type
(Etype
(N
)) then
4057 Make_Selected_Component
(Loc
,
4059 Make_Explicit_Dereference
(Loc
,
4060 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True)),
4061 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
4063 Set_Is_In_Discriminant_Check
(Dref
);
4066 Make_Selected_Component
(Loc
,
4068 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
4069 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
4071 Set_Is_In_Discriminant_Check
(Dref
);
4074 Evolve_Or_Else
(Cond
,
4077 Right_Opnd
=> Dval
));
4080 Next_Discriminant
(Disc_Ent
);
4084 end Build_Discriminant_Checks
;
4090 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
4097 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
4098 -- Return the relevant expression from the left operand of the given
4099 -- short circuit form: this is LO itself, except if LO is a qualified
4100 -- expression, a type conversion, or an expression with actions, in
4101 -- which case this is Left_Expression (Expression (LO)).
4103 ---------------------
4104 -- Left_Expression --
4105 ---------------------
4107 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
4108 LE
: Node_Id
:= Left_Opnd
(Op
);
4110 while Nkind
(LE
) in N_Qualified_Expression
4112 | N_Expression_With_Actions
4114 LE
:= Expression
(LE
);
4118 end Left_Expression
;
4120 -- Start of processing for Check_Needed
4123 -- Always check if not simple entity
4125 if Nkind
(Nod
) not in N_Has_Entity
4126 or else not Comes_From_Source
(Nod
)
4131 -- Look up tree for short circuit
4138 -- Done if out of subexpression (note that we allow generated stuff
4139 -- such as itype declarations in this context, to keep the loop going
4140 -- since we may well have generated such stuff in complex situations.
4141 -- Also done if no parent (probably an error condition, but no point
4142 -- in behaving nasty if we find it).
4145 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
4149 -- Or/Or Else case, where test is part of the right operand, or is
4150 -- part of one of the actions associated with the right operand, and
4151 -- the left operand is an equality test.
4153 elsif K
= N_Op_Or
then
4154 exit when N
= Right_Opnd
(P
)
4155 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
4157 elsif K
= N_Or_Else
then
4158 exit when (N
= Right_Opnd
(P
)
4161 and then List_Containing
(N
) = Actions
(P
)))
4162 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
4164 -- Similar test for the And/And then case, where the left operand
4165 -- is an inequality test.
4167 elsif K
= N_Op_And
then
4168 exit when N
= Right_Opnd
(P
)
4169 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
4171 elsif K
= N_And_Then
then
4172 exit when (N
= Right_Opnd
(P
)
4175 and then List_Containing
(N
) = Actions
(P
)))
4176 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
4182 -- If we fall through the loop, then we have a conditional with an
4183 -- appropriate test as its left operand, so look further.
4185 L
:= Left_Expression
(P
);
4187 -- L is an "=" or "/=" operator: extract its operands
4189 R
:= Right_Opnd
(L
);
4192 -- Left operand of test must match original variable
4194 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
4198 -- Right operand of test must be key value (zero or null)
4201 when Access_Check
=>
4202 if not Known_Null
(R
) then
4206 when Division_Check
=>
4207 if not Compile_Time_Known_Value
(R
)
4208 or else Expr_Value
(R
) /= Uint_0
4214 raise Program_Error
;
4217 -- Here we have the optimizable case, warn if not short-circuited
4219 if K
= N_Op_And
or else K
= N_Op_Or
then
4220 Error_Msg_Warn
:= SPARK_Mode
/= On
;
4223 when Access_Check
=>
4224 if GNATprove_Mode
then
4226 ("Constraint_Error might have been raised (access check)",
4230 ("Constraint_Error may be raised (access check)??",
4234 when Division_Check
=>
4235 if GNATprove_Mode
then
4237 ("Constraint_Error might have been raised (zero divide)",
4241 ("Constraint_Error may be raised (zero divide)??",
4246 raise Program_Error
;
4249 if K
= N_Op_And
then
4250 Error_Msg_N
-- CODEFIX
4251 ("use `AND THEN` instead of AND??", P
);
4253 Error_Msg_N
-- CODEFIX
4254 ("use `OR ELSE` instead of OR??", P
);
4257 -- If not short-circuited, we need the check
4261 -- If short-circuited, we can omit the check
4268 -----------------------------------
4269 -- Check_Valid_Lvalue_Subscripts --
4270 -----------------------------------
4272 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
4274 -- Skip this if range checks are suppressed
4276 if Range_Checks_Suppressed
(Etype
(Expr
)) then
4279 -- Only do this check for expressions that come from source. We assume
4280 -- that expander generated assignments explicitly include any necessary
4281 -- checks. Note that this is not just an optimization, it avoids
4282 -- infinite recursions.
4284 elsif not Comes_From_Source
(Expr
) then
4287 -- For a selected component, check the prefix
4289 elsif Nkind
(Expr
) = N_Selected_Component
then
4290 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4293 -- Case of indexed component
4295 elsif Nkind
(Expr
) = N_Indexed_Component
then
4296 Apply_Subscript_Validity_Checks
(Expr
);
4298 -- Prefix may itself be or contain an indexed component, and these
4299 -- subscripts need checking as well.
4301 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4303 end Check_Valid_Lvalue_Subscripts
;
4305 ----------------------------------
4306 -- Null_Exclusion_Static_Checks --
4307 ----------------------------------
4309 procedure Null_Exclusion_Static_Checks
4311 Comp
: Node_Id
:= Empty
;
4312 Array_Comp
: Boolean := False)
4314 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
4315 Kind
: constant Node_Kind
:= Nkind
(N
);
4316 Error_Nod
: Node_Id
;
4322 (Kind
in N_Component_Declaration
4323 | N_Discriminant_Specification
4324 | N_Function_Specification
4325 | N_Object_Declaration
4326 | N_Parameter_Specification
);
4328 if Kind
= N_Function_Specification
then
4329 Typ
:= Etype
(Defining_Entity
(N
));
4331 Typ
:= Etype
(Defining_Identifier
(N
));
4335 when N_Component_Declaration
=>
4336 if Present
(Access_Definition
(Component_Definition
(N
))) then
4337 Error_Nod
:= Component_Definition
(N
);
4339 Error_Nod
:= Subtype_Indication
(Component_Definition
(N
));
4342 when N_Discriminant_Specification
=>
4343 Error_Nod
:= Discriminant_Type
(N
);
4345 when N_Function_Specification
=>
4346 Error_Nod
:= Result_Definition
(N
);
4348 when N_Object_Declaration
=>
4349 Error_Nod
:= Object_Definition
(N
);
4351 when N_Parameter_Specification
=>
4352 Error_Nod
:= Parameter_Type
(N
);
4355 raise Program_Error
;
4360 -- Enforce legality rule 3.10 (13): A null exclusion can only be
4361 -- applied to an access [sub]type.
4363 if not Is_Access_Type
(Typ
) then
4365 ("`NOT NULL` allowed only for an access type", Error_Nod
);
4367 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4368 -- be applied to a [sub]type that does not exclude null already.
4370 elsif Can_Never_Be_Null
(Typ
) and then Comes_From_Source
(Typ
) then
4372 ("`NOT NULL` not allowed (& already excludes null)",
4377 -- Check that null-excluding objects are always initialized, except for
4378 -- deferred constants, for which the expression will appear in the full
4381 if Kind
= N_Object_Declaration
4382 and then No
(Expression
(N
))
4383 and then not Constant_Present
(N
)
4384 and then not No_Initialization
(N
)
4386 if Present
(Comp
) then
4388 -- Specialize the warning message to indicate that we are dealing
4389 -- with an uninitialized composite object that has a defaulted
4390 -- null-excluding component.
4392 Error_Msg_Name_1
:= Chars
(Defining_Identifier
(Comp
));
4393 Error_Msg_Name_2
:= Chars
(Defining_Identifier
(N
));
4396 (Compile_Time_Constraint_Error
4399 "(Ada 2005) null-excluding component % of object % must "
4400 & "be initialized??",
4401 Ent
=> Defining_Identifier
(Comp
)));
4403 -- This is a case of an array with null-excluding components, so
4404 -- indicate that in the warning.
4406 elsif Array_Comp
then
4408 (Compile_Time_Constraint_Error
4411 "(Ada 2005) null-excluding array components must "
4412 & "be initialized??",
4413 Ent
=> Defining_Identifier
(N
)));
4415 -- Normal case of object of a null-excluding access type
4418 -- Add an expression that assigns null. This node is needed by
4419 -- Apply_Compile_Time_Constraint_Error, which will replace this
4420 -- with a Constraint_Error node.
4422 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
4423 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
4425 Apply_Compile_Time_Constraint_Error
4426 (N
=> Expression
(N
),
4428 "(Ada 2005) null-excluding objects must be initialized??",
4429 Reason
=> CE_Null_Not_Allowed
);
4433 -- Check that a null-excluding component, formal or object is not being
4434 -- assigned a null value. Otherwise generate a warning message and
4435 -- replace Expression (N) by an N_Constraint_Error node.
4437 if Kind
/= N_Function_Specification
then
4438 Expr
:= Expression
(N
);
4440 if Present
(Expr
) and then Known_Null
(Expr
) then
4442 when N_Component_Declaration
4443 | N_Discriminant_Specification
4445 Apply_Compile_Time_Constraint_Error
4448 "(Ada 2005) NULL not allowed in null-excluding "
4450 Reason
=> CE_Null_Not_Allowed
);
4452 when N_Object_Declaration
=>
4453 Apply_Compile_Time_Constraint_Error
4456 "(Ada 2005) NULL not allowed in null-excluding "
4458 Reason
=> CE_Null_Not_Allowed
);
4460 when N_Parameter_Specification
=>
4461 Apply_Compile_Time_Constraint_Error
4464 "(Ada 2005) NULL not allowed in null-excluding "
4466 Reason
=> CE_Null_Not_Allowed
);
4473 end Null_Exclusion_Static_Checks
;
4475 -------------------------------------
4476 -- Compute_Range_For_Arithmetic_Op --
4477 -------------------------------------
4479 procedure Compute_Range_For_Arithmetic_Op
4489 -- Use local variables for possible adjustments
4491 Llo
: Uint
renames Lo_Left
;
4492 Lhi
: Uint
renames Hi_Left
;
4493 Rlo
: Uint
:= Lo_Right
;
4494 Rhi
: Uint
:= Hi_Right
;
4497 -- We will compute a range for the result in almost all cases
4507 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
4519 -- If the right operand can only be zero, set 0..0
4521 if Rlo
= 0 and then Rhi
= 0 then
4525 -- Possible bounds of division must come from dividing end
4526 -- values of the input ranges (four possibilities), provided
4527 -- zero is not included in the possible values of the right
4530 -- Otherwise, we just consider two intervals of values for
4531 -- the right operand: the interval of negative values (up to
4532 -- -1) and the interval of positive values (starting at 1).
4533 -- Since division by 1 is the identity, and division by -1
4534 -- is negation, we get all possible bounds of division in that
4535 -- case by considering:
4536 -- - all values from the division of end values of input
4538 -- - the end values of the left operand;
4539 -- - the negation of the end values of the left operand.
4543 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
4544 -- Mark so we can release the RR and Ev values
4552 -- Discard extreme values of zero for the divisor, since
4553 -- they will simply result in an exception in any case.
4561 -- Compute possible bounds coming from dividing end
4562 -- values of the input ranges.
4569 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
4570 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
4572 -- If the right operand can be both negative or positive,
4573 -- include the end values of the left operand in the
4574 -- extreme values, as well as their negation.
4576 if Rlo
< 0 and then Rhi
> 0 then
4583 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
4585 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
4588 -- Release the RR and Ev values
4590 Release_And_Save
(Mrk
, Lo
, Hi
);
4598 -- Discard negative values for the exponent, since they will
4599 -- simply result in an exception in any case.
4607 -- Estimate number of bits in result before we go computing
4608 -- giant useless bounds. Basically the number of bits in the
4609 -- result is the number of bits in the base multiplied by the
4610 -- value of the exponent. If this is big enough that the result
4611 -- definitely won't fit in Long_Long_Integer, return immediately
4612 -- and avoid computing giant bounds.
4614 -- The comparison here is approximate, but conservative, it
4615 -- only clicks on cases that are sure to exceed the bounds.
4617 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
4623 -- If right operand is zero then result is 1
4630 -- High bound comes either from exponentiation of largest
4631 -- positive value to largest exponent value, or from
4632 -- the exponentiation of most negative value to an
4646 if Rhi
mod 2 = 0 then
4649 Hi2
:= Llo
** (Rhi
- 1);
4655 Hi
:= UI_Max
(Hi1
, Hi2
);
4658 -- Result can only be negative if base can be negative
4661 if Rhi
mod 2 = 0 then
4662 Lo
:= Llo
** (Rhi
- 1);
4667 -- Otherwise low bound is minimum ** minimum
4684 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
4685 -- This is the maximum absolute value of the result
4691 -- The result depends only on the sign and magnitude of
4692 -- the right operand, it does not depend on the sign or
4693 -- magnitude of the left operand.
4706 when N_Op_Multiply
=>
4708 -- Possible bounds of multiplication must come from multiplying
4709 -- end values of the input ranges (four possibilities).
4712 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
4713 -- Mark so we can release the Ev values
4715 Ev1
: constant Uint
:= Llo
* Rlo
;
4716 Ev2
: constant Uint
:= Llo
* Rhi
;
4717 Ev3
: constant Uint
:= Lhi
* Rlo
;
4718 Ev4
: constant Uint
:= Lhi
* Rhi
;
4721 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
4722 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
4724 -- Release the Ev values
4726 Release_And_Save
(Mrk
, Lo
, Hi
);
4729 -- Plus operator (affirmation)
4739 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
4740 -- This is the maximum absolute value of the result. Note
4741 -- that the result range does not depend on the sign of the
4748 -- Case of left operand negative, which results in a range
4749 -- of -Maxabs .. 0 for those negative values. If there are
4750 -- no negative values then Lo value of result is always 0.
4756 -- Case of left operand positive
4765 when N_Op_Subtract
=>
4769 -- Nothing else should be possible
4772 raise Program_Error
;
4774 end Compute_Range_For_Arithmetic_Op
;
4776 ----------------------------------
4777 -- Conditional_Statements_Begin --
4778 ----------------------------------
4780 procedure Conditional_Statements_Begin
is
4782 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
4784 -- If stack overflows, kill all checks, that way we know to simply reset
4785 -- the number of saved checks to zero on return. This should never occur
4788 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4791 -- In the normal case, we just make a new stack entry saving the current
4792 -- number of saved checks for a later restore.
4795 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
4797 if Debug_Flag_CC
then
4798 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
4802 end Conditional_Statements_Begin
;
4804 --------------------------------
4805 -- Conditional_Statements_End --
4806 --------------------------------
4808 procedure Conditional_Statements_End
is
4810 pragma Assert
(Saved_Checks_TOS
> 0);
4812 -- If the saved checks stack overflowed, then we killed all checks, so
4813 -- setting the number of saved checks back to zero is correct. This
4814 -- should never occur in practice.
4816 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4817 Num_Saved_Checks
:= 0;
4819 -- In the normal case, restore the number of saved checks from the top
4823 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
4825 if Debug_Flag_CC
then
4826 w
("Conditional_Statements_End: Num_Saved_Checks = ",
4831 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
4832 end Conditional_Statements_End
;
4834 -------------------------
4835 -- Convert_From_Bignum --
4836 -------------------------
4838 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
4839 Loc
: constant Source_Ptr
:= Sloc
(N
);
4842 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4844 -- Construct call From Bignum
4847 Make_Function_Call
(Loc
,
4849 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4850 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4851 end Convert_From_Bignum
;
4853 -----------------------
4854 -- Convert_To_Bignum --
4855 -----------------------
4857 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4858 Loc
: constant Source_Ptr
:= Sloc
(N
);
4861 -- Nothing to do if Bignum already except call Relocate_Node
4863 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4864 return Relocate_Node
(N
);
4866 -- Otherwise construct call to To_Bignum, converting the operand to the
4867 -- required Long_Long_Integer form.
4870 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4872 Make_Function_Call
(Loc
,
4874 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4875 Parameter_Associations
=> New_List
(
4876 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4878 end Convert_To_Bignum
;
4880 ---------------------
4881 -- Determine_Range --
4882 ---------------------
4884 Cache_Size
: constant := 2 ** 10;
4885 type Cache_Index
is range 0 .. Cache_Size
- 1;
4886 -- Determine size of below cache (power of 2 is more efficient)
4888 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4889 Determine_Range_Cache_O
: array (Cache_Index
) of Node_Id
;
4890 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4891 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4892 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4893 Determine_Range_Cache_Lo_R
: array (Cache_Index
) of Ureal
;
4894 Determine_Range_Cache_Hi_R
: array (Cache_Index
) of Ureal
;
4895 -- The above arrays are used to implement a small direct cache for
4896 -- Determine_Range and Determine_Range_R calls. Because of the way these
4897 -- subprograms recursively traces subexpressions, and because overflow
4898 -- checking calls the routine on the way up the tree, a quadratic behavior
4899 -- can otherwise be encountered in large expressions. The cache entry for
4900 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4901 -- by checking the actual node value stored there. The Range_Cache_O array
4902 -- records the setting of Original_Node (N) so that the cache entry does
4903 -- not become stale when the node N is rewritten. The Range_Cache_V array
4904 -- records the setting of Assume_Valid for the cache entry.
4906 procedure Determine_Range
4911 Assume_Valid
: Boolean := False)
4913 Kind
: constant Node_Kind
:= Nkind
(N
);
4916 function Half_Address_Space
return Uint
;
4917 -- The size of half the total addressable memory space in storage units
4918 -- (minus one, so that the size fits in a signed integer whose size is
4919 -- System_Address_Size, which helps in various cases).
4921 ------------------------
4922 -- Half_Address_Space --
4923 ------------------------
4925 function Half_Address_Space
return Uint
is
4927 return Uint_2
** (System_Address_Size
- 1) - 1;
4928 end Half_Address_Space
;
4932 Typ
: Entity_Id
:= Etype
(N
);
4933 -- Type to use, may get reset to base type for possibly invalid entity
4935 Lo_Left
: Uint
:= No_Uint
;
4936 Hi_Left
: Uint
:= No_Uint
;
4937 -- Lo and Hi bounds of left operand
4939 Lo_Right
: Uint
:= No_Uint
;
4940 Hi_Right
: Uint
:= No_Uint
;
4941 -- Lo and Hi bounds of right (or only) operand
4944 -- Temp variable used to hold a bound node
4947 -- High bound of base type of expression
4951 -- Refined values for low and high bounds, after tightening
4954 -- Used in lower level calls to indicate if call succeeded
4956 Cindex
: Cache_Index
;
4957 -- Used to search cache
4962 -- Start of processing for Determine_Range
4965 -- Prevent junk warnings by initializing range variables
4972 -- For temporary constants internally generated to remove side effects
4973 -- we must use the corresponding expression to determine the range of
4974 -- the expression. But note that the expander can also generate
4975 -- constants in other cases, including deferred constants.
4977 if Is_Entity_Name
(N
)
4978 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4979 and then Ekind
(Entity
(N
)) = E_Constant
4980 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4982 if Present
(Expression
(Parent
(Entity
(N
)))) then
4984 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4986 elsif Present
(Full_View
(Entity
(N
))) then
4988 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4989 OK
, Lo
, Hi
, Assume_Valid
);
4997 -- If type is not defined, we can't determine its range
5001 -- We don't deal with anything except discrete types
5003 or else not Is_Discrete_Type
(Typ
)
5005 -- Don't deal with enumerated types with non-standard representation
5007 or else (Is_Enumeration_Type
(Typ
)
5008 and then Present
(Enum_Pos_To_Rep
5009 (Implementation_Base_Type
(Typ
))))
5011 -- Ignore type for which an error has been posted, since range in
5012 -- this case may well be a bogosity deriving from the error. Also
5013 -- ignore if error posted on the reference node.
5015 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
5021 -- For all other cases, we can determine the range
5025 -- If value is compile time known, then the possible range is the one
5026 -- value that we know this expression definitely has.
5028 if Compile_Time_Known_Value
(N
) then
5029 Lo
:= Expr_Value
(N
);
5034 -- Return if already in the cache
5036 Cindex
:= Cache_Index
(N
mod Cache_Size
);
5038 if Determine_Range_Cache_N
(Cindex
) = N
5040 Determine_Range_Cache_O
(Cindex
) = Original_Node
(N
)
5042 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
5044 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
5045 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
5049 -- Otherwise, start by finding the bounds of the type of the expression,
5050 -- the value cannot be outside this range (if it is, then we have an
5051 -- overflow situation, which is a separate check, we are talking here
5052 -- only about the expression value).
5054 -- First a check, never try to find the bounds of a generic type, since
5055 -- these bounds are always junk values, and it is only valid to look at
5056 -- the bounds in an instance.
5058 if Is_Generic_Type
(Typ
) then
5063 -- First step, change to use base type unless we know the value is valid
5065 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
5066 or else Assume_No_Invalid_Values
5067 or else Assume_Valid
5069 -- If this is a known valid constant with a nonstatic value, it may
5070 -- have inherited a narrower subtype from its initial value; use this
5071 -- saved subtype (see sem_ch3.adb).
5073 if Is_Entity_Name
(N
)
5074 and then Ekind
(Entity
(N
)) = E_Constant
5075 and then Present
(Actual_Subtype
(Entity
(N
)))
5077 Typ
:= Actual_Subtype
(Entity
(N
));
5081 Typ
:= Underlying_Type
(Base_Type
(Typ
));
5084 -- Retrieve the base type. Handle the case where the base type is a
5085 -- private enumeration type.
5087 Btyp
:= Base_Type
(Typ
);
5089 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5090 Btyp
:= Full_View
(Btyp
);
5093 -- We use the actual bound unless it is dynamic, in which case use the
5094 -- corresponding base type bound if possible. If we can't get a bound
5095 -- then we figure we can't determine the range (a peculiar case, that
5096 -- perhaps cannot happen, but there is no point in bombing in this
5097 -- optimization circuit).
5099 -- First the low bound
5101 Bound
:= Type_Low_Bound
(Typ
);
5103 if Compile_Time_Known_Value
(Bound
) then
5104 Lo
:= Expr_Value
(Bound
);
5106 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
5107 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
5114 -- Now the high bound
5116 Bound
:= Type_High_Bound
(Typ
);
5118 -- We need the high bound of the base type later on, and this should
5119 -- always be compile time known. Again, it is not clear that this
5120 -- can ever be false, but no point in bombing.
5122 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
5123 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
5131 -- If we have a static subtype, then that may have a tighter bound so
5132 -- use the upper bound of the subtype instead in this case.
5134 if Compile_Time_Known_Value
(Bound
) then
5135 Hi
:= Expr_Value
(Bound
);
5138 -- We may be able to refine this value in certain situations. If any
5139 -- refinement is possible, then Lor and Hir are set to possibly tighter
5140 -- bounds, and OK1 is set to True.
5144 -- Unary operation case
5151 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5154 Compute_Range_For_Arithmetic_Op
5155 (Kind
, Lo_Left
, Hi_Left
, Lo_Right
, Hi_Right
, OK1
, Lor
, Hir
);
5158 -- Binary operation case
5169 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5173 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5177 Compute_Range_For_Arithmetic_Op
5178 (Kind
, Lo_Left
, Hi_Left
, Lo_Right
, Hi_Right
, OK1
, Lor
, Hir
);
5181 -- Attribute reference cases
5183 when N_Attribute_Reference
=>
5184 case Get_Attribute_Id
(Attribute_Name
(N
)) is
5186 -- For Min/Max attributes, we can refine the range using the
5187 -- possible range of values of the attribute expressions.
5193 (First
(Expressions
(N
)),
5194 OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5198 (Next
(First
(Expressions
(N
))),
5199 OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5203 Lor
:= UI_Min
(Lo_Left
, Lo_Right
);
5204 Hir
:= UI_Max
(Hi_Left
, Hi_Right
);
5207 -- For Pos/Val attributes, we can refine the range using the
5208 -- possible range of values of the attribute expression.
5214 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
5216 -- For Length and Range_Length attributes, use the bounds of
5217 -- the (corresponding index) type to refine the range.
5219 when Attribute_Length
5220 | Attribute_Range_Length
5230 Ptyp
:= Etype
(Prefix
(N
));
5231 if Is_Access_Type
(Ptyp
) then
5232 Ptyp
:= Designated_Type
(Ptyp
);
5235 -- For string literal, we know exact value
5237 if Ekind
(Ptyp
) = E_String_Literal_Subtype
then
5239 Lo
:= String_Literal_Length
(Ptyp
);
5240 Hi
:= String_Literal_Length
(Ptyp
);
5244 if Is_Array_Type
(Ptyp
) then
5245 Ityp
:= Get_Index_Subtype
(N
);
5250 -- If the (index) type is a formal type or derived from
5251 -- one, the bounds are not static.
5253 if Is_Generic_Type
(Root_Type
(Ityp
)) then
5259 (Type_Low_Bound
(Ityp
), OK1
, LL
, LU
, Assume_Valid
);
5263 (Type_High_Bound
(Ityp
), OK1
, UL
, UU
, Assume_Valid
);
5266 -- The maximum value for Length is the biggest
5267 -- possible gap between the values of the bounds.
5268 -- But of course, this value cannot be negative.
5270 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
5272 -- For a constrained array, the minimum value for
5273 -- Length is taken from the actual value of the
5274 -- bounds, since the index will be exactly of this
5277 if Is_Constrained
(Ptyp
) then
5278 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
5280 -- For an unconstrained array, the minimum value
5281 -- for length is always zero.
5289 -- Small optimization: the maximum size in storage units
5290 -- an object can have with GNAT is half of the address
5291 -- space, so we can bound the length of an array declared
5292 -- in Interfaces (or its children) because its component
5293 -- size is at least the storage unit and it is meant to
5294 -- be used to interface actual array objects.
5296 if Is_Array_Type
(Ptyp
) then
5298 S
: constant Entity_Id
:= Scope
(Base_Type
(Ptyp
));
5300 if Is_RTU
(S
, Interfaces
)
5301 or else (S
/= Standard_Standard
5302 and then Is_RTU
(Scope
(S
), Interfaces
))
5304 Hir
:= UI_Min
(Hir
, Half_Address_Space
);
5310 -- The maximum default alignment is quite low, but GNAT accepts
5311 -- alignment clauses that are fairly large, but not as large as
5312 -- the maximum size of objects, see below.
5314 when Attribute_Alignment
=>
5316 Hir
:= Half_Address_Space
;
5319 -- The attribute should have been folded if a component clause
5320 -- was specified, so we assume there is none.
5323 | Attribute_First_Bit
5326 Hir
:= UI_From_Int
(System_Storage_Unit
- 1);
5329 -- Likewise about the component clause. Note that Last_Bit
5330 -- yields -1 for a field of size 0 if First_Bit is 0.
5332 when Attribute_Last_Bit
=>
5333 Lor
:= Uint_Minus_1
;
5337 -- Likewise about the component clause for Position. The
5338 -- maximum size in storage units that an object can have
5339 -- with GNAT is half of the address space.
5341 when Attribute_Max_Size_In_Storage_Elements
5342 | Attribute_Position
5345 Hir
:= Half_Address_Space
;
5348 -- These attributes yield a nonnegative value (we do not set
5349 -- the maximum value because it is too large to be useful).
5351 when Attribute_Bit_Position
5352 | Attribute_Component_Size
5353 | Attribute_Object_Size
5355 | Attribute_Value_Size
5361 -- The maximum size is the sum of twice the size of the largest
5362 -- integer for every dimension, rounded up to the next multiple
5363 -- of the maximum alignment, but we add instead of rounding.
5365 when Attribute_Descriptor_Size
=>
5367 Max_Align
: constant Pos
:=
5368 Maximum_Alignment
* System_Storage_Unit
;
5369 Max_Size
: constant Uint
:=
5370 2 * Esize
(Universal_Integer
);
5371 Ndims
: constant Pos
:=
5372 Number_Dimensions
(Etype
(Prefix
(N
)));
5375 Hir
:= Max_Size
* Ndims
+ Max_Align
;
5379 -- No special handling for other attributes for now
5386 when N_Type_Conversion
=>
5387 -- For a type conversion, we can try to refine the range using the
5390 Determine_Range_To_Discrete
5391 (Expression
(N
), OK1
, Lor
, Hir
, Conversion_OK
(N
), Assume_Valid
);
5393 -- Nothing special to do for all other expression kinds
5401 -- At this stage, if OK1 is true, then we know that the actual result of
5402 -- the computed expression is in the range Lor .. Hir. We can use this
5403 -- to restrict the possible range of results.
5407 -- If the refined value of the low bound is greater than the type
5408 -- low bound, then reset it to the more restrictive value. However,
5409 -- we do NOT do this for the case of a modular type where the
5410 -- possible upper bound on the value is above the base type high
5411 -- bound, because that means the result could wrap.
5412 -- Same applies for the lower bound if it is negative.
5414 if Is_Modular_Integer_Type
(Typ
) then
5415 if Lor
> Lo
and then Hir
<= Hbound
then
5419 if Hir
< Hi
and then Lor
>= Uint_0
then
5424 if Lor
> Hi
or else Hir
< Lo
then
5426 -- If the ranges are disjoint, return the computed range.
5428 -- The current range-constraining logic would require returning
5429 -- the base type's bounds. However, this would miss an
5430 -- opportunity to warn about out-of-range values for some cases
5431 -- (e.g. when type's upper bound is equal to base type upper
5434 -- The alternative of always returning the computed values,
5435 -- even when ranges are intersecting, has unwanted effects
5436 -- (mainly useless constraint checks are inserted) in the
5437 -- Enable_Overflow_Check and Apply_Scalar_Range_Check as these
5438 -- bounds have a special interpretation.
5444 -- If the ranges Lor .. Hir and Lo .. Hi intersect, try to
5445 -- refine the returned range.
5458 -- Set cache entry for future call and we are all done
5460 Determine_Range_Cache_N
(Cindex
) := N
;
5461 Determine_Range_Cache_O
(Cindex
) := Original_Node
(N
);
5462 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5463 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
5464 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
5467 -- If any exception occurs, it means that we have some bug in the compiler,
5468 -- possibly triggered by a previous error, or by some unforeseen peculiar
5469 -- occurrence. However, this is only an optimization attempt, so there is
5470 -- really no point in crashing the compiler. Instead we just decide, too
5471 -- bad, we can't figure out a range in this case after all.
5476 -- Debug flag K disables this behavior (useful for debugging)
5478 if Debug_Flag_K
then
5486 end Determine_Range
;
5488 -----------------------
5489 -- Determine_Range_R --
5490 -----------------------
5492 procedure Determine_Range_R
5497 Assume_Valid
: Boolean := False)
5499 Typ
: Entity_Id
:= Etype
(N
);
5500 -- Type to use, may get reset to base type for possibly invalid entity
5504 -- Lo and Hi bounds of left operand
5506 Lo_Right
: Ureal
:= No_Ureal
;
5507 Hi_Right
: Ureal
:= No_Ureal
;
5508 -- Lo and Hi bounds of right (or only) operand
5511 -- Temp variable used to hold a bound node
5514 -- High bound of base type of expression
5518 -- Refined values for low and high bounds, after tightening
5521 -- Used in lower level calls to indicate if call succeeded
5523 Cindex
: Cache_Index
;
5524 -- Used to search cache
5529 function OK_Operands
return Boolean;
5530 -- Used for binary operators. Determines the ranges of the left and
5531 -- right operands, and if they are both OK, returns True, and puts
5532 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
5534 function Round_Machine
(B
: Ureal
) return Ureal
;
5535 -- B is a real bound. Round it to the nearest machine number.
5541 function OK_Operands
return Boolean is
5544 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5551 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5559 function Round_Machine
(B
: Ureal
) return Ureal
is
5561 return Machine_Number
(Typ
, B
, N
);
5564 -- Start of processing for Determine_Range_R
5567 -- Prevent junk warnings by initializing range variables
5574 -- For temporary constants internally generated to remove side effects
5575 -- we must use the corresponding expression to determine the range of
5576 -- the expression. But note that the expander can also generate
5577 -- constants in other cases, including deferred constants.
5579 if Is_Entity_Name
(N
)
5580 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
5581 and then Ekind
(Entity
(N
)) = E_Constant
5582 and then Is_Internal_Name
(Chars
(Entity
(N
)))
5584 if Present
(Expression
(Parent
(Entity
(N
)))) then
5586 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
5588 elsif Present
(Full_View
(Entity
(N
))) then
5590 (Expression
(Parent
(Full_View
(Entity
(N
)))),
5591 OK
, Lo
, Hi
, Assume_Valid
);
5600 -- If type is not defined, we can't determine its range
5602 pragma Warnings
(Off
, "condition can only be True if invalid");
5603 -- Otherwise the compiler warns on the check of Float_Rep below, because
5604 -- there is only one value (see types.ads).
5608 -- We don't deal with anything except IEEE floating-point types
5610 or else not Is_Floating_Point_Type
(Typ
)
5611 or else Float_Rep
(Typ
) /= IEEE_Binary
5613 -- Ignore type for which an error has been posted, since range in
5614 -- this case may well be a bogosity deriving from the error. Also
5615 -- ignore if error posted on the reference node.
5617 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
5619 pragma Warnings
(On
, "condition can only be True if invalid");
5624 -- For all other cases, we can determine the range
5628 -- If value is compile time known, then the possible range is the one
5629 -- value that we know this expression definitely has.
5631 if Compile_Time_Known_Value
(N
) then
5632 Lo
:= Expr_Value_R
(N
);
5637 -- Return if already in the cache
5639 Cindex
:= Cache_Index
(N
mod Cache_Size
);
5641 if Determine_Range_Cache_N
(Cindex
) = N
5643 Determine_Range_Cache_O
(Cindex
) = Original_Node
(N
)
5645 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
5647 Lo
:= Determine_Range_Cache_Lo_R
(Cindex
);
5648 Hi
:= Determine_Range_Cache_Hi_R
(Cindex
);
5652 -- Otherwise, start by finding the bounds of the type of the expression,
5653 -- the value cannot be outside this range (if it is, then we have an
5654 -- overflow situation, which is a separate check, we are talking here
5655 -- only about the expression value).
5657 -- First a check, never try to find the bounds of a generic type, since
5658 -- these bounds are always junk values, and it is only valid to look at
5659 -- the bounds in an instance.
5661 if Is_Generic_Type
(Typ
) then
5666 -- First step, change to use base type unless we know the value is valid
5668 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
5669 or else Assume_No_Invalid_Values
5670 or else Assume_Valid
5674 Typ
:= Underlying_Type
(Base_Type
(Typ
));
5677 -- Retrieve the base type. Handle the case where the base type is a
5680 Btyp
:= Base_Type
(Typ
);
5682 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5683 Btyp
:= Full_View
(Btyp
);
5686 -- We use the actual bound unless it is dynamic, in which case use the
5687 -- corresponding base type bound if possible. If we can't get a bound
5688 -- then we figure we can't determine the range (a peculiar case, that
5689 -- perhaps cannot happen, but there is no point in bombing in this
5690 -- optimization circuit).
5692 -- First the low bound
5694 Bound
:= Type_Low_Bound
(Typ
);
5696 if Compile_Time_Known_Value
(Bound
) then
5697 Lo
:= Expr_Value_R
(Bound
);
5699 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
5700 Lo
:= Expr_Value_R
(Type_Low_Bound
(Btyp
));
5707 -- Now the high bound
5709 Bound
:= Type_High_Bound
(Typ
);
5711 -- We need the high bound of the base type later on, and this should
5712 -- always be compile time known. Again, it is not clear that this
5713 -- can ever be false, but no point in bombing.
5715 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
5716 Hbound
:= Expr_Value_R
(Type_High_Bound
(Btyp
));
5724 -- If we have a static subtype, then that may have a tighter bound so
5725 -- use the upper bound of the subtype instead in this case.
5727 if Compile_Time_Known_Value
(Bound
) then
5728 Hi
:= Expr_Value_R
(Bound
);
5731 -- We may be able to refine this value in certain situations. If any
5732 -- refinement is possible, then Lor and Hir are set to possibly tighter
5733 -- bounds, and OK1 is set to True.
5737 -- For unary plus, result is limited by range of operand
5741 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5743 -- For unary minus, determine range of operand, and negate it
5747 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5754 -- For binary addition, get range of each operand and do the
5755 -- addition to get the result range.
5759 Lor
:= Round_Machine
(Lo_Left
+ Lo_Right
);
5760 Hir
:= Round_Machine
(Hi_Left
+ Hi_Right
);
5763 -- For binary subtraction, get range of each operand and do the worst
5764 -- case subtraction to get the result range.
5766 when N_Op_Subtract
=>
5768 Lor
:= Round_Machine
(Lo_Left
- Hi_Right
);
5769 Hir
:= Round_Machine
(Hi_Left
- Lo_Right
);
5772 -- For multiplication, get range of each operand and do the
5773 -- four multiplications to get the result range.
5775 when N_Op_Multiply
=>
5778 M1
: constant Ureal
:= Round_Machine
(Lo_Left
* Lo_Right
);
5779 M2
: constant Ureal
:= Round_Machine
(Lo_Left
* Hi_Right
);
5780 M3
: constant Ureal
:= Round_Machine
(Hi_Left
* Lo_Right
);
5781 M4
: constant Ureal
:= Round_Machine
(Hi_Left
* Hi_Right
);
5784 Lor
:= UR_Min
(UR_Min
(M1
, M2
), UR_Min
(M3
, M4
));
5785 Hir
:= UR_Max
(UR_Max
(M1
, M2
), UR_Max
(M3
, M4
));
5789 -- For division, consider separately the cases where the right
5790 -- operand is positive or negative. Otherwise, the right operand
5791 -- can be arbitrarily close to zero, so the result is likely to
5792 -- be unbounded in one direction, do not attempt to compute it.
5797 -- Right operand is positive
5799 if Lo_Right
> Ureal_0
then
5801 -- If the low bound of the left operand is negative, obtain
5802 -- the overall low bound by dividing it by the smallest
5803 -- value of the right operand, and otherwise by the largest
5804 -- value of the right operand.
5806 if Lo_Left
< Ureal_0
then
5807 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5809 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5812 -- If the high bound of the left operand is negative, obtain
5813 -- the overall high bound by dividing it by the largest
5814 -- value of the right operand, and otherwise by the
5815 -- smallest value of the right operand.
5817 if Hi_Left
< Ureal_0
then
5818 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5820 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5823 -- Right operand is negative
5825 elsif Hi_Right
< Ureal_0
then
5827 -- If the low bound of the left operand is negative, obtain
5828 -- the overall low bound by dividing it by the largest
5829 -- value of the right operand, and otherwise by the smallest
5830 -- value of the right operand.
5832 if Lo_Left
< Ureal_0
then
5833 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5835 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5838 -- If the high bound of the left operand is negative, obtain
5839 -- the overall high bound by dividing it by the smallest
5840 -- value of the right operand, and otherwise by the
5841 -- largest value of the right operand.
5843 if Hi_Left
< Ureal_0
then
5844 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5846 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5854 when N_Type_Conversion
=>
5856 -- For type conversion from one floating-point type to another, we
5857 -- can refine the range using the converted value.
5859 if Is_Floating_Point_Type
(Etype
(Expression
(N
))) then
5860 Determine_Range_R
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5862 -- When converting an integer to a floating-point type, determine
5863 -- the range in integer first, and then convert the bounds.
5865 elsif Is_Discrete_Type
(Etype
(Expression
(N
))) then
5872 (Expression
(N
), OK1
, Lor_Int
, Hir_Int
, Assume_Valid
);
5875 Lor
:= Round_Machine
(UR_From_Uint
(Lor_Int
));
5876 Hir
:= Round_Machine
(UR_From_Uint
(Hir_Int
));
5884 -- Nothing special to do for all other expression kinds
5892 -- At this stage, if OK1 is true, then we know that the actual result of
5893 -- the computed expression is in the range Lor .. Hir. We can use this
5894 -- to restrict the possible range of results.
5898 -- If the refined value of the low bound is greater than the type
5899 -- low bound, then reset it to the more restrictive value.
5905 -- Similarly, if the refined value of the high bound is less than the
5906 -- value so far, then reset it to the more restrictive value.
5913 -- Set cache entry for future call and we are all done
5915 Determine_Range_Cache_N
(Cindex
) := N
;
5916 Determine_Range_Cache_O
(Cindex
) := Original_Node
(N
);
5917 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5918 Determine_Range_Cache_Lo_R
(Cindex
) := Lo
;
5919 Determine_Range_Cache_Hi_R
(Cindex
) := Hi
;
5922 -- If any exception occurs, it means that we have some bug in the compiler,
5923 -- possibly triggered by a previous error, or by some unforeseen peculiar
5924 -- occurrence. However, this is only an optimization attempt, so there is
5925 -- really no point in crashing the compiler. Instead we just decide, too
5926 -- bad, we can't figure out a range in this case after all.
5931 -- Debug flag K disables this behavior (useful for debugging)
5933 if Debug_Flag_K
then
5941 end Determine_Range_R
;
5943 ---------------------------------
5944 -- Determine_Range_To_Discrete --
5945 ---------------------------------
5947 procedure Determine_Range_To_Discrete
5952 Fixed_Int
: Boolean := False;
5953 Assume_Valid
: Boolean := False)
5955 Typ
: constant Entity_Id
:= Etype
(N
);
5958 -- For a discrete type, simply defer to Determine_Range
5960 if Is_Discrete_Type
(Typ
) then
5961 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
);
5963 -- For a fixed point type treated as an integer, we can determine the
5964 -- range using the Corresponding_Integer_Value of the bounds of the
5965 -- type or base type. This is done by the calls to Expr_Value below.
5967 elsif Is_Fixed_Point_Type
(Typ
) and then Fixed_Int
then
5969 Btyp
, Ftyp
: Entity_Id
;
5973 if Assume_Valid
then
5976 Ftyp
:= Underlying_Type
(Base_Type
(Typ
));
5979 Btyp
:= Base_Type
(Ftyp
);
5981 -- First the low bound
5983 Bound
:= Type_Low_Bound
(Ftyp
);
5985 if Compile_Time_Known_Value
(Bound
) then
5986 Lo
:= Expr_Value
(Bound
);
5988 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
5991 -- Then the high bound
5993 Bound
:= Type_High_Bound
(Ftyp
);
5995 if Compile_Time_Known_Value
(Bound
) then
5996 Hi
:= Expr_Value
(Bound
);
5998 Hi
:= Expr_Value
(Type_High_Bound
(Btyp
));
6004 -- For a floating-point type, we can determine the range in real first,
6005 -- and then convert the bounds using UR_To_Uint, which correctly rounds
6006 -- away from zero when half way between two integers, as required by
6007 -- normal Ada 95 rounding semantics. But this is only possible because
6008 -- GNATprove's analysis rules out the possibility of a NaN or infinite.
6010 elsif GNATprove_Mode
and then Is_Floating_Point_Type
(Typ
) then
6012 Lo_Real
, Hi_Real
: Ureal
;
6015 Determine_Range_R
(N
, OK
, Lo_Real
, Hi_Real
, Assume_Valid
);
6018 Lo
:= UR_To_Uint
(Lo_Real
);
6019 Hi
:= UR_To_Uint
(Hi_Real
);
6031 end Determine_Range_To_Discrete
;
6033 ------------------------------------
6034 -- Discriminant_Checks_Suppressed --
6035 ------------------------------------
6037 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6040 if Is_Unchecked_Union
(E
) then
6042 elsif Checks_May_Be_Suppressed
(E
) then
6043 return Is_Check_Suppressed
(E
, Discriminant_Check
);
6047 return Scope_Suppress
.Suppress
(Discriminant_Check
);
6048 end Discriminant_Checks_Suppressed
;
6050 --------------------------------
6051 -- Division_Checks_Suppressed --
6052 --------------------------------
6054 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6056 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6057 return Is_Check_Suppressed
(E
, Division_Check
);
6059 return Scope_Suppress
.Suppress
(Division_Check
);
6061 end Division_Checks_Suppressed
;
6063 --------------------------------------
6064 -- Duplicated_Tag_Checks_Suppressed --
6065 --------------------------------------
6067 function Duplicated_Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6069 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6070 return Is_Check_Suppressed
(E
, Duplicated_Tag_Check
);
6072 return Scope_Suppress
.Suppress
(Duplicated_Tag_Check
);
6074 end Duplicated_Tag_Checks_Suppressed
;
6076 -----------------------------------
6077 -- Elaboration_Checks_Suppressed --
6078 -----------------------------------
6080 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6082 -- The complication in this routine is that if we are in the dynamic
6083 -- model of elaboration, we also check All_Checks, since All_Checks
6084 -- does not set Elaboration_Check explicitly.
6087 if Kill_Elaboration_Checks
(E
) then
6090 elsif Checks_May_Be_Suppressed
(E
) then
6091 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
6094 elsif Dynamic_Elaboration_Checks
then
6095 return Is_Check_Suppressed
(E
, All_Checks
);
6103 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
6106 elsif Dynamic_Elaboration_Checks
then
6107 return Scope_Suppress
.Suppress
(All_Checks
);
6112 end Elaboration_Checks_Suppressed
;
6114 ---------------------------
6115 -- Enable_Overflow_Check --
6116 ---------------------------
6118 procedure Enable_Overflow_Check
(N
: Node_Id
) is
6119 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6120 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6128 Do_Ovflow_Check
: Boolean;
6131 if Debug_Flag_CC
then
6132 w
("Enable_Overflow_Check for node ", Int
(N
));
6133 Write_Str
(" Source location = ");
6138 -- No check if overflow checks suppressed for type of node
6140 if Overflow_Checks_Suppressed
(Etype
(N
)) then
6143 -- Nothing to do for unsigned integer types, which do not overflow
6145 elsif Is_Modular_Integer_Type
(Typ
) then
6149 -- This is the point at which processing for STRICT mode diverges
6150 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
6151 -- probably more extreme that it needs to be, but what is going on here
6152 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
6153 -- to leave the processing for STRICT mode untouched. There were
6154 -- two reasons for this. First it avoided any incompatible change of
6155 -- behavior. Second, it guaranteed that STRICT mode continued to be
6158 -- The big difference is that in STRICT mode there is a fair amount of
6159 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
6160 -- know that no check is needed. We skip all that in the two new modes,
6161 -- since really overflow checking happens over a whole subtree, and we
6162 -- do the corresponding optimizations later on when applying the checks.
6164 if Mode
in Minimized_Or_Eliminated
then
6165 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
6166 and then not (Is_Entity_Name
(N
)
6167 and then Overflow_Checks_Suppressed
(Entity
(N
)))
6169 Activate_Overflow_Check
(N
);
6172 if Debug_Flag_CC
then
6173 w
("Minimized/Eliminated mode");
6179 -- Remainder of processing is for STRICT case, and is unchanged from
6180 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
6182 -- Nothing to do if the range of the result is known OK. We skip this
6183 -- for conversions, since the caller already did the check, and in any
6184 -- case the condition for deleting the check for a type conversion is
6187 if Nkind
(N
) /= N_Type_Conversion
then
6188 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
6190 -- Note in the test below that we assume that the range is not OK
6191 -- if a bound of the range is equal to that of the type. That's not
6192 -- quite accurate but we do this for the following reasons:
6194 -- a) The way that Determine_Range works, it will typically report
6195 -- the bounds of the value as being equal to the bounds of the
6196 -- type, because it either can't tell anything more precise, or
6197 -- does not think it is worth the effort to be more precise.
6199 -- b) It is very unusual to have a situation in which this would
6200 -- generate an unnecessary overflow check (an example would be
6201 -- a subtype with a range 0 .. Integer'Last - 1 to which the
6202 -- literal value one is added).
6204 -- c) The alternative is a lot of special casing in this routine
6205 -- which would partially duplicate Determine_Range processing.
6208 Do_Ovflow_Check
:= True;
6210 -- Note that the following checks are quite deliberately > and <
6211 -- rather than >= and <= as explained above.
6213 if Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
6215 Hi
< Expr_Value
(Type_High_Bound
(Typ
))
6217 Do_Ovflow_Check
:= False;
6219 -- Despite the comments above, it is worth dealing specially with
6220 -- division. The only case where integer division can overflow is
6221 -- (largest negative number) / (-1). So we will do an extra range
6222 -- analysis to see if this is possible.
6224 elsif Nkind
(N
) = N_Op_Divide
then
6226 (Left_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6228 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
6229 Do_Ovflow_Check
:= False;
6233 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6235 if OK
and then (Lo
> Uint_Minus_1
6239 Do_Ovflow_Check
:= False;
6243 -- Likewise for Abs/Minus, the only case where the operation can
6244 -- overflow is when the operand is the largest negative number.
6246 elsif Nkind
(N
) in N_Op_Abs | N_Op_Minus
then
6248 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
6250 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
6251 Do_Ovflow_Check
:= False;
6255 -- If no overflow check required, we are done
6257 if not Do_Ovflow_Check
then
6258 if Debug_Flag_CC
then
6259 w
("No overflow check required");
6267 -- If not in optimizing mode, set flag and we are done. We are also done
6268 -- (and just set the flag) if the type is not a discrete type, since it
6269 -- is not worth the effort to eliminate checks for other than discrete
6270 -- types. In addition, we take this same path if we have stored the
6271 -- maximum number of checks possible already (a very unlikely situation,
6272 -- but we do not want to blow up).
6274 if Optimization_Level
= 0
6275 or else not Is_Discrete_Type
(Etype
(N
))
6276 or else Num_Saved_Checks
= Saved_Checks
'Last
6278 Activate_Overflow_Check
(N
);
6280 if Debug_Flag_CC
then
6281 w
("Optimization off");
6287 -- Otherwise evaluate and check the expression
6292 Target_Type
=> Empty
,
6298 if Debug_Flag_CC
then
6299 w
("Called Find_Check");
6303 w
(" Check_Num = ", Chk
);
6304 w
(" Ent = ", Int
(Ent
));
6305 Write_Str
(" Ofs = ");
6310 -- If check is not of form to optimize, then set flag and we are done
6313 Activate_Overflow_Check
(N
);
6317 -- If check is already performed, then return without setting flag
6320 if Debug_Flag_CC
then
6321 w
("Check suppressed!");
6327 -- Here we will make a new entry for the new check
6329 Activate_Overflow_Check
(N
);
6330 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
6331 Saved_Checks
(Num_Saved_Checks
) :=
6336 Target_Type
=> Empty
);
6338 if Debug_Flag_CC
then
6339 w
("Make new entry, check number = ", Num_Saved_Checks
);
6340 w
(" Entity = ", Int
(Ent
));
6341 Write_Str
(" Offset = ");
6343 w
(" Check_Type = O");
6344 w
(" Target_Type = Empty");
6347 -- If we get an exception, then something went wrong, probably because of
6348 -- an error in the structure of the tree due to an incorrect program. Or
6349 -- it may be a bug in the optimization circuit. In either case the safest
6350 -- thing is simply to set the check flag unconditionally.
6354 Activate_Overflow_Check
(N
);
6356 if Debug_Flag_CC
then
6357 w
(" exception occurred, overflow flag set");
6361 end Enable_Overflow_Check
;
6363 ------------------------
6364 -- Enable_Range_Check --
6365 ------------------------
6367 procedure Enable_Range_Check
(N
: Node_Id
) is
6376 -- Return if unchecked type conversion with range check killed. In this
6377 -- case we never set the flag (that's what Kill_Range_Check is about).
6379 if Nkind
(N
) = N_Unchecked_Type_Conversion
6380 and then Kill_Range_Check
(N
)
6385 -- Do not set range check flag if parent is assignment statement or
6386 -- object declaration with Suppress_Assignment_Checks flag set.
6388 if Nkind
(Parent
(N
)) in N_Assignment_Statement | N_Object_Declaration
6389 and then Suppress_Assignment_Checks
(Parent
(N
))
6394 -- Check for various cases where we should suppress the range check
6396 -- No check if range checks suppressed for type of node
6398 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
6401 -- No check if node is an entity name, and range checks are suppressed
6402 -- for this entity, or for the type of this entity.
6404 elsif Is_Entity_Name
(N
)
6405 and then (Range_Checks_Suppressed
(Entity
(N
))
6406 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
6410 -- No checks if index of array, and index checks are suppressed for
6411 -- the array object or the type of the array.
6413 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
6415 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
6417 if Is_Entity_Name
(Pref
)
6418 and then Index_Checks_Suppressed
(Entity
(Pref
))
6421 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
6427 -- Debug trace output
6429 if Debug_Flag_CC
then
6430 w
("Enable_Range_Check for node ", Int
(N
));
6431 Write_Str
(" Source location = ");
6436 -- If not in optimizing mode, set flag and we are done. We are also done
6437 -- (and just set the flag) if the type is not a discrete type, since it
6438 -- is not worth the effort to eliminate checks for other than discrete
6439 -- types. In addition, we take this same path if we have stored the
6440 -- maximum number of checks possible already (a very unlikely situation,
6441 -- but we do not want to blow up).
6443 if Optimization_Level
= 0
6444 or else No
(Etype
(N
))
6445 or else not Is_Discrete_Type
(Etype
(N
))
6446 or else Num_Saved_Checks
= Saved_Checks
'Last
6448 Activate_Range_Check
(N
);
6450 if Debug_Flag_CC
then
6451 w
("Optimization off");
6457 -- Otherwise find out the target type
6461 -- For assignment, use left side subtype
6463 if Nkind
(P
) = N_Assignment_Statement
6464 and then Expression
(P
) = N
6466 Ttyp
:= Etype
(Name
(P
));
6468 -- For indexed component, use subscript subtype
6470 elsif Nkind
(P
) = N_Indexed_Component
then
6477 Atyp
:= Etype
(Prefix
(P
));
6479 if Is_Access_Type
(Atyp
) then
6480 Atyp
:= Designated_Type
(Atyp
);
6482 -- If the prefix is an access to an unconstrained array,
6483 -- perform check unconditionally: it depends on the bounds of
6484 -- an object and we cannot currently recognize whether the test
6485 -- may be redundant.
6487 if not Is_Constrained
(Atyp
) then
6488 Activate_Range_Check
(N
);
6492 -- Ditto if prefix is simply an unconstrained array. We used
6493 -- to think this case was OK, if the prefix was not an explicit
6494 -- dereference, but we have now seen a case where this is not
6495 -- true, so it is safer to just suppress the optimization in this
6496 -- case. The back end is getting better at eliminating redundant
6497 -- checks in any case, so the loss won't be important.
6499 elsif Is_Array_Type
(Atyp
)
6500 and then not Is_Constrained
(Atyp
)
6502 Activate_Range_Check
(N
);
6506 Indx
:= First_Index
(Atyp
);
6507 Subs
:= First
(Expressions
(P
));
6510 Ttyp
:= Etype
(Indx
);
6519 -- For now, ignore all other cases, they are not so interesting
6522 if Debug_Flag_CC
then
6523 w
(" target type not found, flag set");
6526 Activate_Range_Check
(N
);
6530 -- Evaluate and check the expression
6535 Target_Type
=> Ttyp
,
6541 if Debug_Flag_CC
then
6542 w
("Called Find_Check");
6543 w
("Target_Typ = ", Int
(Ttyp
));
6547 w
(" Check_Num = ", Chk
);
6548 w
(" Ent = ", Int
(Ent
));
6549 Write_Str
(" Ofs = ");
6554 -- If check is not of form to optimize, then set flag and we are done
6557 if Debug_Flag_CC
then
6558 w
(" expression not of optimizable type, flag set");
6561 Activate_Range_Check
(N
);
6565 -- If check is already performed, then return without setting flag
6568 if Debug_Flag_CC
then
6569 w
("Check suppressed!");
6575 -- Here we will make a new entry for the new check
6577 Activate_Range_Check
(N
);
6578 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
6579 Saved_Checks
(Num_Saved_Checks
) :=
6584 Target_Type
=> Ttyp
);
6586 if Debug_Flag_CC
then
6587 w
("Make new entry, check number = ", Num_Saved_Checks
);
6588 w
(" Entity = ", Int
(Ent
));
6589 Write_Str
(" Offset = ");
6591 w
(" Check_Type = R");
6592 w
(" Target_Type = ", Int
(Ttyp
));
6593 pg
(Union_Id
(Ttyp
));
6596 -- If we get an exception, then something went wrong, probably because of
6597 -- an error in the structure of the tree due to an incorrect program. Or
6598 -- it may be a bug in the optimization circuit. In either case the safest
6599 -- thing is simply to set the check flag unconditionally.
6603 Activate_Range_Check
(N
);
6605 if Debug_Flag_CC
then
6606 w
(" exception occurred, range flag set");
6610 end Enable_Range_Check
;
6616 procedure Ensure_Valid
6618 Holes_OK
: Boolean := False;
6619 Related_Id
: Entity_Id
:= Empty
;
6620 Is_Low_Bound
: Boolean := False;
6621 Is_High_Bound
: Boolean := False)
6623 Typ
: constant Entity_Id
:= Etype
(Expr
);
6626 -- Ignore call if we are not doing any validity checking
6628 if not Validity_Checks_On
then
6631 -- Ignore call if range or validity checks suppressed on entity or type
6633 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
6636 -- No check required if expression is from the expander, we assume the
6637 -- expander will generate whatever checks are needed. Note that this is
6638 -- not just an optimization, it avoids infinite recursions.
6640 -- Unchecked conversions must be checked, unless they are initialized
6641 -- scalar values, as in a component assignment in an init proc.
6643 -- In addition, we force a check if Force_Validity_Checks is set
6645 elsif not Comes_From_Source
(Expr
)
6647 (Nkind
(Expr
) = N_Identifier
6648 and then Present
(Renamed_Entity_Or_Object
(Entity
(Expr
)))
6650 Comes_From_Source
(Renamed_Entity_Or_Object
(Entity
(Expr
))))
6651 and then not Force_Validity_Checks
6652 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
6653 or else Kill_Range_Check
(Expr
))
6657 -- No check required if expression is known to have valid value
6659 elsif Expr_Known_Valid
(Expr
) then
6662 -- No check needed within a generated predicate function. Validity
6663 -- of input value will have been checked earlier.
6665 elsif Ekind
(Current_Scope
) = E_Function
6666 and then Is_Predicate_Function
(Current_Scope
)
6670 -- Ignore case of enumeration with holes where the flag is set not to
6671 -- worry about holes, since no special validity check is needed
6673 elsif Is_Enumeration_Type
(Typ
)
6674 and then Has_Non_Standard_Rep
(Typ
)
6679 -- No check required on the left-hand side of an assignment
6681 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
6682 and then Expr
= Name
(Parent
(Expr
))
6686 -- No check on a universal real constant. The context will eventually
6687 -- convert it to a machine number for some target type, or report an
6690 elsif Nkind
(Expr
) = N_Real_Literal
6691 and then Etype
(Expr
) = Universal_Real
6695 -- If the expression denotes a component of a packed boolean array,
6696 -- no possible check applies. We ignore the old ACATS chestnuts that
6697 -- involve Boolean range True..True.
6699 -- Note: validity checks are generated for expressions that yield a
6700 -- scalar type, when it is possible to create a value that is outside of
6701 -- the type. If this is a one-bit boolean no such value exists. This is
6702 -- an optimization, and it also prevents compiler blowing up during the
6703 -- elaboration of improperly expanded packed array references.
6705 elsif Nkind
(Expr
) = N_Indexed_Component
6706 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
6707 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
6711 -- For an expression with actions, we want to insert the validity check
6712 -- on the final Expression.
6714 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
6715 Ensure_Valid
(Expression
(Expr
));
6718 -- An annoying special case. If this is an out parameter of a scalar
6719 -- type, then the value is not going to be accessed, therefore it is
6720 -- inappropriate to do any validity check at the call site. Likewise
6721 -- if the parameter is passed by reference.
6724 -- Only need to worry about scalar types
6726 if Is_Scalar_Type
(Typ
) then
6736 -- Find actual argument (which may be a parameter association)
6737 -- and the parent of the actual argument (the call statement)
6742 if Nkind
(P
) = N_Parameter_Association
then
6747 -- If this is an indirect or dispatching call, get signature
6748 -- from the subprogram type.
6750 if Nkind
(P
) in N_Entry_Call_Statement
6752 | N_Procedure_Call_Statement
6754 E
:= Get_Called_Entity
(P
);
6755 L
:= Parameter_Associations
(P
);
6757 -- Only need to worry if there are indeed actuals, and if
6758 -- this could be a subprogram call, otherwise we cannot get
6759 -- a match (either we are not an argument, or the mode of
6760 -- the formal is not OUT). This test also filters out the
6763 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
6765 -- This is the loop through parameters, looking for an
6766 -- OUT parameter for which we are the argument.
6768 F
:= First_Formal
(E
);
6770 while Present
(F
) loop
6772 and then (Ekind
(F
) = E_Out_Parameter
6773 or else Mechanism
(F
) = By_Reference
)
6787 -- If this is a boolean expression, only its elementary operands need
6788 -- checking: if they are valid, a boolean or short-circuit operation
6789 -- with them will be valid as well.
6791 if Base_Type
(Typ
) = Standard_Boolean
6793 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
6798 -- If we fall through, a validity check is required
6800 Insert_Valid_Check
(Expr
, Related_Id
, Is_Low_Bound
, Is_High_Bound
);
6802 if Is_Entity_Name
(Expr
)
6803 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
6805 Set_Is_Known_Valid
(Entity
(Expr
));
6809 ----------------------
6810 -- Expr_Known_Valid --
6811 ----------------------
6813 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
6814 Typ
: constant Entity_Id
:= Etype
(Expr
);
6817 -- Non-scalar types are always considered valid, since they never give
6818 -- rise to the issues of erroneous or bounded error behavior that are
6819 -- the concern. In formal reference manual terms the notion of validity
6820 -- only applies to scalar types. Note that even when packed arrays are
6821 -- represented using modular types, they are still arrays semantically,
6822 -- so they are also always valid (in particular, the unused bits can be
6823 -- random rubbish without affecting the validity of the array value).
6825 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Impl_Type
(Typ
) then
6828 -- If no validity checking, then everything is considered valid
6830 elsif not Validity_Checks_On
then
6833 -- Floating-point types are considered valid unless floating-point
6834 -- validity checks have been specifically turned on.
6836 elsif Is_Floating_Point_Type
(Typ
)
6837 and then not Validity_Check_Floating_Point
6841 -- If the expression is the value of an object that is known to be
6842 -- valid, then clearly the expression value itself is valid.
6844 elsif Is_Entity_Name
(Expr
)
6845 and then Is_Known_Valid
(Entity
(Expr
))
6847 -- Exclude volatile variables
6849 and then not Treat_As_Volatile
(Entity
(Expr
))
6853 -- References to discriminants are always considered valid. The value
6854 -- of a discriminant gets checked when the object is built. Within the
6855 -- record, we consider it valid, and it is important to do so, since
6856 -- otherwise we can try to generate bogus validity checks which
6857 -- reference discriminants out of scope. Discriminants of concurrent
6858 -- types are excluded for the same reason.
6860 elsif Is_Entity_Name
(Expr
)
6861 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
6865 -- If the type is one for which all values are known valid, then we are
6866 -- sure that the value is valid except in the slightly odd case where
6867 -- the expression is a reference to a variable whose size has been
6868 -- explicitly set to a value greater than the object size.
6870 elsif Is_Known_Valid
(Typ
) then
6871 if Is_Entity_Name
(Expr
)
6872 and then Ekind
(Entity
(Expr
)) = E_Variable
6873 and then Known_Esize
(Entity
(Expr
))
6874 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
6881 -- Integer and character literals always have valid values, where
6882 -- appropriate these will be range checked in any case.
6884 elsif Nkind
(Expr
) in N_Integer_Literal | N_Character_Literal
then
6887 -- If we have a type conversion or a qualification of a known valid
6888 -- value, then the result will always be valid.
6890 elsif Nkind
(Expr
) in N_Type_Conversion | N_Qualified_Expression
then
6891 return Expr_Known_Valid
(Expression
(Expr
));
6893 -- Case of expression is a non-floating-point operator. In this case we
6894 -- can assume the result is valid the generated code for the operator
6895 -- will include whatever checks are needed (e.g. range checks) to ensure
6896 -- validity. This assumption does not hold for the floating-point case,
6897 -- since floating-point operators can generate Infinite or NaN results
6898 -- which are considered invalid.
6900 -- Historical note: in older versions, the exemption of floating-point
6901 -- types from this assumption was done only in cases where the parent
6902 -- was an assignment, function call or parameter association. Presumably
6903 -- the idea was that in other contexts, the result would be checked
6904 -- elsewhere, but this list of cases was missing tests (at least the
6905 -- N_Object_Declaration case, as shown by a reported missing validity
6906 -- check), and it is not clear why function calls but not procedure
6907 -- calls were tested for. It really seems more accurate and much
6908 -- safer to recognize that expressions which are the result of a
6909 -- floating-point operator can never be assumed to be valid.
6911 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
6914 -- The result of a membership test is always valid, since it is true or
6915 -- false, there are no other possibilities.
6917 elsif Nkind
(Expr
) in N_Membership_Test
then
6920 -- For all other cases, we do not know the expression is valid
6925 end Expr_Known_Valid
;
6931 procedure Find_Check
6933 Check_Type
: Character;
6934 Target_Type
: Entity_Id
;
6935 Entry_OK
: out Boolean;
6936 Check_Num
: out Nat
;
6937 Ent
: out Entity_Id
;
6940 function Within_Range_Of
6941 (Target_Type
: Entity_Id
;
6942 Check_Type
: Entity_Id
) return Boolean;
6943 -- Given a requirement for checking a range against Target_Type, and
6944 -- and a range Check_Type against which a check has already been made,
6945 -- determines if the check against check type is sufficient to ensure
6946 -- that no check against Target_Type is required.
6948 ---------------------
6949 -- Within_Range_Of --
6950 ---------------------
6952 function Within_Range_Of
6953 (Target_Type
: Entity_Id
;
6954 Check_Type
: Entity_Id
) return Boolean
6957 if Target_Type
= Check_Type
then
6962 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
6963 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
6964 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
6965 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
6969 or else (Compile_Time_Known_Value
(Tlo
)
6971 Compile_Time_Known_Value
(Clo
)
6973 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
6976 or else (Compile_Time_Known_Value
(Thi
)
6978 Compile_Time_Known_Value
(Chi
)
6980 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
6988 end Within_Range_Of
;
6990 -- Start of processing for Find_Check
6993 -- Establish default, in case no entry is found
6997 -- Case of expression is simple entity reference
6999 if Is_Entity_Name
(Expr
) then
7000 Ent
:= Entity
(Expr
);
7003 -- Case of expression is entity + known constant
7005 elsif Nkind
(Expr
) = N_Op_Add
7006 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
7007 and then Is_Entity_Name
(Left_Opnd
(Expr
))
7009 Ent
:= Entity
(Left_Opnd
(Expr
));
7010 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
7012 -- Case of expression is entity - known constant
7014 elsif Nkind
(Expr
) = N_Op_Subtract
7015 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
7016 and then Is_Entity_Name
(Left_Opnd
(Expr
))
7018 Ent
:= Entity
(Left_Opnd
(Expr
));
7019 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
7021 -- Any other expression is not of the right form
7030 -- Come here with expression of appropriate form, check if entity is an
7031 -- appropriate one for our purposes.
7033 if (Ekind
(Ent
) = E_Variable
7034 or else Is_Constant_Object
(Ent
))
7035 and then not Is_Library_Level_Entity
(Ent
)
7043 -- See if there is matching check already
7045 for J
in reverse 1 .. Num_Saved_Checks
loop
7047 SC
: Saved_Check
renames Saved_Checks
(J
);
7049 if SC
.Killed
= False
7050 and then SC
.Entity
= Ent
7051 and then SC
.Offset
= Ofs
7052 and then SC
.Check_Type
= Check_Type
7053 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
7061 -- If we fall through entry was not found
7066 ---------------------------------
7067 -- Generate_Discriminant_Check --
7068 ---------------------------------
7070 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
7071 Loc
: constant Source_Ptr
:= Sloc
(N
);
7072 Pref
: constant Node_Id
:= Prefix
(N
);
7073 Sel
: constant Node_Id
:= Selector_Name
(N
);
7075 Orig_Comp
: constant Entity_Id
:=
7076 Original_Record_Component
(Entity
(Sel
));
7077 -- The original component to be checked
7079 Discr_Fct
: constant Entity_Id
:=
7080 Discriminant_Checking_Func
(Orig_Comp
);
7081 -- The discriminant checking function
7084 -- One discriminant to be checked in the type
7086 Real_Discr
: Entity_Id
;
7087 -- Actual discriminant in the call
7089 Pref_Type
: Entity_Id
;
7090 -- Type of relevant prefix (ignoring private/access stuff)
7093 -- List of arguments for function call
7096 -- Keep track of the formal corresponding to the actual we build for
7097 -- each discriminant, in order to be able to perform the necessary type
7101 -- Selected component reference for checking function argument
7104 Pref_Type
:= Etype
(Pref
);
7106 -- Force evaluation of the prefix, so that it does not get evaluated
7107 -- twice (once for the check, once for the actual reference). Such a
7108 -- double evaluation is always a potential source of inefficiency, and
7109 -- is functionally incorrect in the volatile case, or when the prefix
7110 -- may have side effects. A nonvolatile entity or a component of a
7111 -- nonvolatile entity requires no evaluation.
7113 if Is_Entity_Name
(Pref
) then
7114 if Treat_As_Volatile
(Entity
(Pref
)) then
7115 Force_Evaluation
(Pref
, Name_Req
=> True);
7118 elsif Treat_As_Volatile
(Etype
(Pref
)) then
7119 Force_Evaluation
(Pref
, Name_Req
=> True);
7121 elsif Nkind
(Pref
) = N_Selected_Component
7122 and then Is_Entity_Name
(Prefix
(Pref
))
7127 Force_Evaluation
(Pref
, Name_Req
=> True);
7130 -- For a tagged type, use the scope of the original component to
7131 -- obtain the type, because ???
7133 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
7134 Pref_Type
:= Scope
(Orig_Comp
);
7136 -- For an untagged derived type, use the discriminants of the parent
7137 -- which have been renamed in the derivation, possibly by a one-to-many
7138 -- discriminant constraint. For untagged type, initially get the Etype
7142 if Is_Derived_Type
(Pref_Type
)
7143 and then Number_Discriminants
(Pref_Type
) /=
7144 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
7146 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
7150 -- We definitely should have a checking function, This routine should
7151 -- not be called if no discriminant checking function is present.
7153 pragma Assert
(Present
(Discr_Fct
));
7155 -- Create the list of the actual parameters for the call. This list
7156 -- is the list of the discriminant fields of the record expression to
7157 -- be discriminant checked.
7160 Formal
:= First_Formal
(Discr_Fct
);
7161 Discr
:= First_Discriminant
(Pref_Type
);
7162 while Present
(Discr
) loop
7164 -- If we have a corresponding discriminant field, and a parent
7165 -- subtype is present, then we want to use the corresponding
7166 -- discriminant since this is the one with the useful value.
7168 if Present
(Corresponding_Discriminant
(Discr
))
7169 and then Ekind
(Pref_Type
) = E_Record_Type
7170 and then Present
(Parent_Subtype
(Pref_Type
))
7172 Real_Discr
:= Corresponding_Discriminant
(Discr
);
7174 Real_Discr
:= Discr
;
7177 -- Construct the reference to the discriminant
7180 Make_Selected_Component
(Loc
,
7182 Unchecked_Convert_To
(Pref_Type
,
7183 Duplicate_Subexpr
(Pref
)),
7184 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
7186 -- Manually analyze and resolve this selected component. We really
7187 -- want it just as it appears above, and do not want the expander
7188 -- playing discriminal games etc with this reference. Then we append
7189 -- the argument to the list we are gathering.
7191 Set_Etype
(Scomp
, Etype
(Real_Discr
));
7192 Set_Analyzed
(Scomp
, True);
7193 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
7195 Next_Formal_With_Extras
(Formal
);
7196 Next_Discriminant
(Discr
);
7199 -- Now build and insert the call
7202 Make_Raise_Constraint_Error
(Loc
,
7204 Make_Function_Call
(Loc
,
7205 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
7206 Parameter_Associations
=> Args
),
7207 Reason
=> CE_Discriminant_Check_Failed
));
7208 end Generate_Discriminant_Check
;
7210 ---------------------------
7211 -- Generate_Index_Checks --
7212 ---------------------------
7214 procedure Generate_Index_Checks
7216 Checks_Generated
: out Dimension_Set
)
7219 function Entity_Of_Prefix
return Entity_Id
;
7220 -- Returns the entity of the prefix of N (or Empty if not found)
7222 ----------------------
7223 -- Entity_Of_Prefix --
7224 ----------------------
7226 function Entity_Of_Prefix
return Entity_Id
is
7231 while not Is_Entity_Name
(P
) loop
7232 if Nkind
(P
) not in N_Selected_Component | N_Indexed_Component
then
7240 end Entity_Of_Prefix
;
7244 Loc
: constant Source_Ptr
:= Sloc
(N
);
7245 A
: constant Node_Id
:= Prefix
(N
);
7246 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
7249 -- Start of processing for Generate_Index_Checks
7252 Checks_Generated
.Elements
:= (others => False);
7254 -- Ignore call if the prefix is not an array since we have a serious
7255 -- error in the sources. Ignore it also if index checks are suppressed
7256 -- for array object or type.
7258 if not Is_Array_Type
(Etype
(A
))
7259 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
7260 or else Index_Checks_Suppressed
(Etype
(A
))
7264 -- The indexed component we are dealing with contains 'Loop_Entry in its
7265 -- prefix. This case arises when analysis has determined that constructs
7268 -- Prefix'Loop_Entry (Expr)
7269 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
7271 -- require rewriting for error detection purposes. A side effect of this
7272 -- action is the generation of index checks that mention 'Loop_Entry.
7273 -- Delay the generation of the check until 'Loop_Entry has been properly
7274 -- expanded. This is done in Expand_Loop_Entry_Attributes.
7276 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
7277 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
7282 -- Generate a raise of constraint error with the appropriate reason and
7283 -- a condition of the form:
7285 -- Base_Type (Sub) not in Array'Range (Subscript)
7287 -- Note that the reason we generate the conversion to the base type here
7288 -- is that we definitely want the range check to take place, even if it
7289 -- looks like the subtype is OK. Optimization considerations that allow
7290 -- us to omit the check have already been taken into account in the
7291 -- setting of the Do_Range_Check flag earlier on.
7293 Sub
:= First
(Expressions
(N
));
7295 -- Handle string literals
7297 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
7298 if Do_Range_Check
(Sub
) then
7299 Set_Do_Range_Check
(Sub
, False);
7301 -- For string literals we obtain the bounds of the string from the
7302 -- associated subtype.
7305 Make_Raise_Constraint_Error
(Loc
,
7309 Convert_To
(Base_Type
(Etype
(Sub
)),
7310 Duplicate_Subexpr_Move_Checks
(Sub
)),
7312 Make_Attribute_Reference
(Loc
,
7313 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
7314 Attribute_Name
=> Name_Range
)),
7315 Reason
=> CE_Index_Check_Failed
));
7317 Checks_Generated
.Elements
(1) := True;
7331 A_Idx
:= First_Index
(Etype
(A
));
7333 while Present
(Sub
) loop
7334 if Do_Range_Check
(Sub
) then
7335 Set_Do_Range_Check
(Sub
, False);
7337 -- Force evaluation except for the case of a simple name of
7338 -- a nonvolatile entity.
7340 if not Is_Entity_Name
(Sub
)
7341 or else Treat_As_Volatile
(Entity
(Sub
))
7343 Force_Evaluation
(Sub
);
7346 if Nkind
(A_Idx
) = N_Range
then
7349 elsif Nkind
(A_Idx
) in N_Identifier | N_Expanded_Name
then
7350 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
7352 if Nkind
(A_Range
) = N_Subtype_Indication
then
7353 A_Range
:= Range_Expression
(Constraint
(A_Range
));
7356 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
7357 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
7360 -- For array objects with constant bounds we can generate
7361 -- the index check using the bounds of the type of the index
7364 and then Ekind
(A_Ent
) = E_Variable
7365 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
7366 and then Is_Constant_Bound
(High_Bound
(A_Range
))
7369 Make_Attribute_Reference
(Loc
,
7371 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
7372 Attribute_Name
=> Name_Range
);
7374 -- For arrays with non-constant bounds we cannot generate
7375 -- the index check using the bounds of the type of the index
7376 -- since it may reference discriminants of some enclosing
7377 -- type. We obtain the bounds directly from the prefix
7384 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
7388 Make_Attribute_Reference
(Loc
,
7390 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
7391 Attribute_Name
=> Name_Range
,
7392 Expressions
=> Num
);
7396 Make_Raise_Constraint_Error
(Loc
,
7400 Convert_To
(Base_Type
(Etype
(Sub
)),
7401 Duplicate_Subexpr_Move_Checks
(Sub
)),
7402 Right_Opnd
=> Range_N
),
7403 Reason
=> CE_Index_Check_Failed
));
7405 Checks_Generated
.Elements
(Ind
) := True;
7414 end Generate_Index_Checks
;
7416 --------------------------
7417 -- Generate_Range_Check --
7418 --------------------------
7420 procedure Generate_Range_Check
7422 Target_Type
: Entity_Id
;
7423 Reason
: RT_Exception_Code
)
7425 Loc
: constant Source_Ptr
:= Sloc
(N
);
7426 Source_Type
: constant Entity_Id
:= Etype
(N
);
7427 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
7428 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
7430 procedure Convert_And_Check_Range
(Suppress
: Check_Id
);
7431 -- Convert N to the target base type and save the result in a temporary.
7432 -- The action is analyzed using the default checks as modified by the
7433 -- given Suppress argument. Then check the converted value against the
7434 -- range of the target subtype.
7436 function Is_Single_Attribute_Reference
(N
: Node_Id
) return Boolean;
7437 -- Return True if N is an expression that contains a single attribute
7438 -- reference, possibly as operand among only integer literal operands.
7440 -----------------------------
7441 -- Convert_And_Check_Range --
7442 -----------------------------
7444 procedure Convert_And_Check_Range
(Suppress
: Check_Id
) is
7445 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7449 -- For enumeration types with non-standard representation this is a
7450 -- direct conversion from the enumeration type to the target integer
7451 -- type, which is treated by the back end as a normal integer type
7452 -- conversion, treating the enumeration type as an integer, which is
7453 -- exactly what we want. We set Conversion_OK to make sure that the
7454 -- analyzer does not complain about what otherwise might be an
7455 -- illegal conversion.
7457 if Is_Enumeration_Type
(Source_Base_Type
)
7458 and then Present
(Enum_Pos_To_Rep
(Source_Base_Type
))
7459 and then Is_Integer_Type
(Target_Base_Type
)
7461 Conv_N
:= OK_Convert_To
(Target_Base_Type
, Duplicate_Subexpr
(N
));
7463 Conv_N
:= Convert_To
(Target_Base_Type
, Duplicate_Subexpr
(N
));
7466 -- We make a temporary to hold the value of the conversion to the
7467 -- target base type, and then do the test against this temporary.
7468 -- N itself is replaced by an occurrence of Tnn and followed by
7469 -- the explicit range check.
7471 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
7472 -- [constraint_error when Tnn not in Target_Type]
7475 Insert_Actions
(N
, New_List
(
7476 Make_Object_Declaration
(Loc
,
7477 Defining_Identifier
=> Tnn
,
7478 Object_Definition
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
7479 Constant_Present
=> True,
7480 Expression
=> Conv_N
),
7482 Make_Raise_Constraint_Error
(Loc
,
7485 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
7486 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
7488 Suppress
=> Suppress
);
7490 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
7492 -- Set the type of N, because the declaration for Tnn might not
7493 -- be analyzed yet, as is the case if N appears within a record
7494 -- declaration, as a discriminant constraint or expression.
7496 Set_Etype
(N
, Target_Base_Type
);
7497 end Convert_And_Check_Range
;
7499 -------------------------------------
7500 -- Is_Single_Attribute_Reference --
7501 -------------------------------------
7503 function Is_Single_Attribute_Reference
(N
: Node_Id
) return Boolean is
7505 if Nkind
(N
) = N_Attribute_Reference
then
7508 elsif Nkind
(N
) in N_Binary_Op
then
7509 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
7510 return Is_Single_Attribute_Reference
(Left_Opnd
(N
));
7512 elsif Nkind
(Left_Opnd
(N
)) = N_Integer_Literal
then
7513 return Is_Single_Attribute_Reference
(Right_Opnd
(N
));
7522 end Is_Single_Attribute_Reference
;
7524 -- Start of processing for Generate_Range_Check
7527 -- First special case, if the source type is already within the range
7528 -- of the target type, then no check is needed (probably we should have
7529 -- stopped Do_Range_Check from being set in the first place, but better
7530 -- late than never in preventing junk code and junk flag settings).
7532 if In_Subrange_Of
(Source_Type
, Target_Type
)
7534 -- We do NOT apply this if the source node is a literal, since in this
7535 -- case the literal has already been labeled as having the subtype of
7540 N_Integer_Literal | N_Real_Literal | N_Character_Literal
7543 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
7545 Set_Do_Range_Check
(N
, False);
7549 -- Here a check is needed. If the expander is not active (which is also
7550 -- the case in GNATprove mode), then simply set the Do_Range_Check flag
7551 -- and we are done. We just want to see the range check flag set, we do
7552 -- not want to generate the explicit range check code.
7554 if not Expander_Active
then
7555 Set_Do_Range_Check
(N
);
7559 -- Here we will generate an explicit range check, so we don't want to
7560 -- set the Do_Range check flag, since the range check is taken care of
7561 -- by the code we will generate.
7563 Set_Do_Range_Check
(N
, False);
7565 -- Force evaluation of the node, so that it does not get evaluated twice
7566 -- (once for the check, once for the actual reference). Such a double
7567 -- evaluation is always a potential source of inefficiency, and is
7568 -- functionally incorrect in the volatile case.
7570 -- We skip the evaluation of attribute references because, after these
7571 -- runtime checks are generated, the expander may need to rewrite this
7572 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in
7573 -- Expand_N_Attribute_Reference) and, in many cases, their return type
7574 -- is universal integer, which is a very large type for a temporary.
7576 if not Is_Single_Attribute_Reference
(N
)
7577 and then (not Is_Entity_Name
(N
)
7578 or else Treat_As_Volatile
(Entity
(N
)))
7580 Force_Evaluation
(N
, Mode
=> Strict
);
7583 -- The easiest case is when Source_Base_Type and Target_Base_Type are
7584 -- the same since in this case we can simply do a direct check of the
7585 -- value of N against the bounds of Target_Type.
7587 -- [constraint_error when N not in Target_Type]
7589 -- Note: this is by far the most common case, for example all cases of
7590 -- checks on the RHS of assignments are in this category, but not all
7591 -- cases are like this. Notably conversions can involve two types.
7593 if Source_Base_Type
= Target_Base_Type
then
7595 -- Insert the explicit range check. Note that we suppress checks for
7596 -- this code, since we don't want a recursive range check popping up.
7599 Make_Raise_Constraint_Error
(Loc
,
7602 Left_Opnd
=> Duplicate_Subexpr
(N
),
7603 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
7605 Suppress
=> All_Checks
);
7607 -- Next test for the case where the target type is within the bounds
7608 -- of the base type of the source type, since in this case we can
7609 -- simply convert the bounds of the target type to this base type
7612 -- [constraint_error when N not in
7613 -- Source_Base_Type (Target_Type'First)
7615 -- Source_Base_Type(Target_Type'Last))]
7617 -- The conversions will always work and need no check
7619 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
7620 -- of converting from an enumeration value to an integer type, such as
7621 -- occurs for the case of generating a range check on Enum'Val(Exp)
7622 -- (which used to be handled by gigi). This is OK, since the conversion
7623 -- itself does not require a check.
7625 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
7627 -- Insert the explicit range check. Note that we suppress checks for
7628 -- this code, since we don't want a recursive range check popping up.
7630 if Is_Discrete_Type
(Source_Base_Type
)
7632 Is_Discrete_Type
(Target_Base_Type
)
7635 Make_Raise_Constraint_Error
(Loc
,
7638 Left_Opnd
=> Duplicate_Subexpr
(N
),
7643 Unchecked_Convert_To
(Source_Base_Type
,
7644 Make_Attribute_Reference
(Loc
,
7646 New_Occurrence_Of
(Target_Type
, Loc
),
7647 Attribute_Name
=> Name_First
)),
7650 Unchecked_Convert_To
(Source_Base_Type
,
7651 Make_Attribute_Reference
(Loc
,
7653 New_Occurrence_Of
(Target_Type
, Loc
),
7654 Attribute_Name
=> Name_Last
)))),
7656 Suppress
=> All_Checks
);
7658 -- For conversions involving at least one type that is not discrete,
7659 -- first convert to the target base type and then generate the range
7660 -- check. This avoids problems with values that are close to a bound
7661 -- of the target type that would fail a range check when done in a
7662 -- larger source type before converting but pass if converted with
7663 -- rounding and then checked (such as in float-to-float conversions).
7665 -- Note that overflow checks are not suppressed for this code because
7666 -- we do not know whether the source type is in range of the target
7667 -- base type (unlike in the next case below).
7670 Convert_And_Check_Range
(Suppress
=> Range_Check
);
7673 -- Note that at this stage we know that the Target_Base_Type is not in
7674 -- the range of the Source_Base_Type (since even the Target_Type itself
7675 -- is not in this range). It could still be the case that Source_Type is
7676 -- in range of the target base type since we have not checked that case.
7678 -- If that is the case, we can freely convert the source to the target,
7679 -- and then test the target result against the bounds. Note that checks
7680 -- are suppressed for this code, since we don't want a recursive range
7681 -- check popping up.
7683 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
7684 Convert_And_Check_Range
(Suppress
=> All_Checks
);
7686 -- At this stage, we know that we have two scalar types, which are
7687 -- directly convertible, and where neither scalar type has a base
7688 -- range that is in the range of the other scalar type.
7690 -- The only way this can happen is with a signed and unsigned type.
7691 -- So test for these two cases:
7694 -- Case of the source is unsigned and the target is signed
7696 if Is_Unsigned_Type
(Source_Base_Type
)
7697 and then not Is_Unsigned_Type
(Target_Base_Type
)
7699 -- If the source is unsigned and the target is signed, then we
7700 -- know that the source is not shorter than the target (otherwise
7701 -- the source base type would be in the target base type range).
7703 -- In other words, the unsigned type is either the same size as
7704 -- the target, or it is larger. It cannot be smaller.
7707 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
7709 -- We only need to check the low bound if the low bound of the
7710 -- target type is non-negative. If the low bound of the target
7711 -- type is negative, then we know that we will fit fine.
7713 -- If the high bound of the target type is negative, then we
7714 -- know we have a constraint error, since we can't possibly
7715 -- have a negative source.
7717 -- With these two checks out of the way, we can do the check
7718 -- using the source type safely
7720 -- This is definitely the most annoying case.
7722 -- [constraint_error
7723 -- when (Target_Type'First >= 0
7725 -- N < Source_Base_Type (Target_Type'First))
7726 -- or else Target_Type'Last < 0
7727 -- or else N > Source_Base_Type (Target_Type'Last)];
7729 -- We turn off all checks since we know that the conversions
7730 -- will work fine, given the guards for negative values.
7733 Make_Raise_Constraint_Error
(Loc
,
7739 Left_Opnd
=> Make_Op_Ge
(Loc
,
7741 Make_Attribute_Reference
(Loc
,
7743 New_Occurrence_Of
(Target_Type
, Loc
),
7744 Attribute_Name
=> Name_First
),
7745 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7749 Left_Opnd
=> Duplicate_Subexpr
(N
),
7751 Convert_To
(Source_Base_Type
,
7752 Make_Attribute_Reference
(Loc
,
7754 New_Occurrence_Of
(Target_Type
, Loc
),
7755 Attribute_Name
=> Name_First
)))),
7760 Make_Attribute_Reference
(Loc
,
7761 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7762 Attribute_Name
=> Name_Last
),
7763 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
7767 Left_Opnd
=> Duplicate_Subexpr
(N
),
7769 Convert_To
(Source_Base_Type
,
7770 Make_Attribute_Reference
(Loc
,
7771 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7772 Attribute_Name
=> Name_Last
)))),
7775 Suppress
=> All_Checks
);
7777 -- Only remaining possibility is that the source is signed and
7778 -- the target is unsigned.
7781 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
7782 and then Is_Unsigned_Type
(Target_Base_Type
));
7784 -- If the source is signed and the target is unsigned, then we
7785 -- know that the target is not shorter than the source (otherwise
7786 -- the target base type would be in the source base type range).
7788 -- In other words, the unsigned type is either the same size as
7789 -- the target, or it is larger. It cannot be smaller.
7791 -- Clearly we have an error if the source value is negative since
7792 -- no unsigned type can have negative values. If the source type
7793 -- is non-negative, then the check can be done using the target
7796 -- Tnn : constant Target_Base_Type (N) := Target_Type;
7798 -- [constraint_error
7799 -- when N < 0 or else Tnn not in Target_Type];
7801 -- We turn off all checks for the conversion of N to the target
7802 -- base type, since we generate the explicit check to ensure that
7803 -- the value is non-negative
7806 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7809 Insert_Actions
(N
, New_List
(
7810 Make_Object_Declaration
(Loc
,
7811 Defining_Identifier
=> Tnn
,
7812 Object_Definition
=>
7813 New_Occurrence_Of
(Target_Base_Type
, Loc
),
7814 Constant_Present
=> True,
7816 Unchecked_Convert_To
7817 (Target_Base_Type
, Duplicate_Subexpr
(N
))),
7819 Make_Raise_Constraint_Error
(Loc
,
7824 Left_Opnd
=> Duplicate_Subexpr
(N
),
7825 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7829 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
7831 New_Occurrence_Of
(Target_Type
, Loc
))),
7834 Suppress
=> All_Checks
);
7836 -- Set the Etype explicitly, because Insert_Actions may have
7837 -- placed the declaration in the freeze list for an enclosing
7838 -- construct, and thus it is not analyzed yet.
7840 Set_Etype
(Tnn
, Target_Base_Type
);
7841 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
7845 end Generate_Range_Check
;
7851 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
7853 -- For standard check name, we can do a direct computation
7855 if N
in First_Check_Name
.. Last_Check_Name
then
7856 return Check_Id
(N
- (First_Check_Name
- 1));
7858 -- For non-standard names added by pragma Check_Name, search table
7861 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
7862 if Check_Names
.Table
(J
) = N
then
7868 -- No matching name found
7873 ---------------------
7874 -- Get_Discriminal --
7875 ---------------------
7877 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
7878 Loc
: constant Source_Ptr
:= Sloc
(E
);
7883 -- The bound can be a bona fide parameter of a protected operation,
7884 -- rather than a prival encoded as an in-parameter.
7886 if No
(Discriminal_Link
(Entity
(Bound
))) then
7890 -- Climb the scope stack looking for an enclosing protected type. If
7891 -- we run out of scopes, return the bound itself.
7894 while Present
(Sc
) loop
7895 if Sc
= Standard_Standard
then
7897 elsif Ekind
(Sc
) = E_Protected_Type
then
7904 D
:= First_Discriminant
(Sc
);
7905 while Present
(D
) loop
7906 if Chars
(D
) = Chars
(Bound
) then
7907 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
7910 Next_Discriminant
(D
);
7914 end Get_Discriminal
;
7916 ----------------------
7917 -- Get_Range_Checks --
7918 ----------------------
7920 function Get_Range_Checks
7922 Target_Typ
: Entity_Id
;
7923 Source_Typ
: Entity_Id
:= Empty
;
7924 Warn_Node
: Node_Id
:= Empty
) return Check_Result
7928 Selected_Range_Checks
(Expr
, Target_Typ
, Source_Typ
, Warn_Node
);
7929 end Get_Range_Checks
;
7935 function Guard_Access
7938 Expr
: Node_Id
) return Node_Id
7941 if Nkind
(Cond
) = N_Or_Else
then
7942 Set_Paren_Count
(Cond
, 1);
7945 if Nkind
(Expr
) = N_Allocator
then
7953 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Expr
),
7954 Right_Opnd
=> Make_Null
(Loc
)),
7955 Right_Opnd
=> Cond
);
7959 -----------------------------
7960 -- Index_Checks_Suppressed --
7961 -----------------------------
7963 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7965 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7966 return Is_Check_Suppressed
(E
, Index_Check
);
7968 return Scope_Suppress
.Suppress
(Index_Check
);
7970 end Index_Checks_Suppressed
;
7976 procedure Initialize
is
7978 for J
in Determine_Range_Cache_N
'Range loop
7979 Determine_Range_Cache_N
(J
) := Empty
;
7984 for J
in Int
range 1 .. All_Checks
loop
7985 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
7989 -------------------------
7990 -- Insert_Range_Checks --
7991 -------------------------
7993 procedure Insert_Range_Checks
7994 (Checks
: Check_Result
;
7996 Suppress_Typ
: Entity_Id
;
7997 Static_Sloc
: Source_Ptr
;
7998 Do_Before
: Boolean := False)
8000 Checks_On
: constant Boolean :=
8001 not Index_Checks_Suppressed
(Suppress_Typ
)
8003 not Range_Checks_Suppressed
(Suppress_Typ
);
8005 Check_Node
: Node_Id
;
8008 -- For now we just return if Checks_On is false, however this should be
8009 -- enhanced to check for an always True value in the condition and to
8010 -- generate a compilation warning.
8012 if not Expander_Active
or not Checks_On
then
8016 for J
in 1 .. 2 loop
8017 exit when No
(Checks
(J
));
8019 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
8020 and then Present
(Condition
(Checks
(J
)))
8022 Check_Node
:= Checks
(J
);
8025 Make_Raise_Constraint_Error
(Static_Sloc
,
8026 Reason
=> CE_Range_Check_Failed
);
8029 Mark_Rewrite_Insertion
(Check_Node
);
8032 Insert_Before_And_Analyze
(Node
, Check_Node
);
8034 Insert_After_And_Analyze
(Node
, Check_Node
);
8037 end Insert_Range_Checks
;
8039 ------------------------
8040 -- Insert_Valid_Check --
8041 ------------------------
8043 procedure Insert_Valid_Check
8045 Related_Id
: Entity_Id
:= Empty
;
8046 Is_Low_Bound
: Boolean := False;
8047 Is_High_Bound
: Boolean := False)
8049 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
8050 Typ
: Entity_Id
:= Etype
(Expr
);
8054 -- Do not insert if checks off, or if not checking validity or if
8055 -- expression is known to be valid.
8057 if not Validity_Checks_On
8058 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
8059 or else Expr_Known_Valid
(Expr
)
8063 -- Do not insert checks within a predicate function. This will arise
8064 -- if the current unit and the predicate function are being compiled
8065 -- with validity checks enabled.
8067 elsif Present
(Predicate_Function
(Typ
))
8068 and then Current_Scope
= Predicate_Function
(Typ
)
8072 -- If the expression is a packed component of a modular type of the
8073 -- right size, the data is always valid.
8075 elsif Nkind
(Expr
) = N_Selected_Component
8076 and then Present
(Component_Clause
(Entity
(Selector_Name
(Expr
))))
8077 and then Is_Modular_Integer_Type
(Typ
)
8078 and then Modulus
(Typ
) = 2 ** Esize
(Entity
(Selector_Name
(Expr
)))
8082 -- Do not generate a validity check when inside a generic unit as this
8083 -- is an expansion activity.
8085 elsif Inside_A_Generic
then
8089 -- Entities declared in Lock_free protected types must be treated as
8090 -- volatile, and we must inhibit validity checks to prevent improper
8091 -- constant folding.
8093 if Is_Entity_Name
(Expr
)
8094 and then Is_Subprogram
(Scope
(Entity
(Expr
)))
8095 and then Present
(Protected_Subprogram
(Scope
(Entity
(Expr
))))
8096 and then Uses_Lock_Free
8097 (Scope
(Protected_Subprogram
(Scope
(Entity
(Expr
)))))
8102 -- If we have a checked conversion, then validity check applies to
8103 -- the expression inside the conversion, not the result, since if
8104 -- the expression inside is valid, then so is the conversion result.
8107 while Nkind
(Exp
) = N_Type_Conversion
loop
8108 Exp
:= Expression
(Exp
);
8112 -- Do not generate a check for a variable which already validates the
8113 -- value of an assignable object.
8115 if Is_Validation_Variable_Reference
(Exp
) then
8125 -- If the expression denotes an assignable object, capture its value
8126 -- in a variable and replace the original expression by the variable.
8127 -- This approach has several effects:
8129 -- 1) The evaluation of the object results in only one read in the
8130 -- case where the object is atomic or volatile.
8132 -- Var ... := Object; -- read
8134 -- 2) The captured value is the one verified by attribute 'Valid.
8135 -- As a result the object is not evaluated again, which would
8136 -- result in an unwanted read in the case where the object is
8137 -- atomic or volatile.
8139 -- if not Var'Valid then -- OK, no read of Object
8141 -- if not Object'Valid then -- Wrong, extra read of Object
8143 -- 3) The captured value replaces the original object reference.
8144 -- As a result the object is not evaluated again, in the same
8147 -- ... Var ... -- OK, no read of Object
8149 -- ... Object ... -- Wrong, extra read of Object
8151 -- 4) The use of a variable to capture the value of the object
8152 -- allows the propagation of any changes back to the original
8155 -- procedure Call (Val : in out ...);
8157 -- Var : ... := Object; -- read Object
8158 -- if not Var'Valid then -- validity check
8159 -- Call (Var); -- modify Var
8160 -- Object := Var; -- update Object
8162 if Is_Variable
(Exp
) then
8163 Var_Id
:= Make_Temporary
(Loc
, 'T', Exp
);
8165 -- Because we could be dealing with a transient scope which would
8166 -- cause our object declaration to remain unanalyzed we must do
8167 -- some manual decoration.
8169 Mutate_Ekind
(Var_Id
, E_Variable
);
8170 Set_Etype
(Var_Id
, Typ
);
8173 Make_Object_Declaration
(Loc
,
8174 Defining_Identifier
=> Var_Id
,
8175 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8176 Expression
=> New_Copy_Tree
(Exp
)),
8177 Suppress
=> Validity_Check
);
8179 Set_Validated_Object
(Var_Id
, New_Copy_Tree
(Exp
));
8181 Rewrite
(Exp
, New_Occurrence_Of
(Var_Id
, Loc
));
8183 -- Move the Do_Range_Check flag over to the new Exp so it doesn't
8184 -- get lost and doesn't leak elsewhere.
8186 if Do_Range_Check
(Validated_Object
(Var_Id
)) then
8187 Set_Do_Range_Check
(Exp
);
8188 Set_Do_Range_Check
(Validated_Object
(Var_Id
), False);
8191 -- In case of a type conversion, an expansion of the expr may be
8192 -- needed (eg. fixed-point as actual).
8195 pragma Assert
(Nkind
(Expr
) = N_Type_Conversion
);
8196 Analyze_And_Resolve
(Expr
);
8199 PV
:= New_Occurrence_Of
(Var_Id
, Loc
);
8201 -- Otherwise the expression does not denote a variable. Force its
8202 -- evaluation by capturing its value in a constant. Generate:
8204 -- Temp : constant ... := Exp;
8209 Related_Id
=> Related_Id
,
8210 Is_Low_Bound
=> Is_Low_Bound
,
8211 Is_High_Bound
=> Is_High_Bound
);
8213 PV
:= New_Copy_Tree
(Exp
);
8216 -- A rather specialized test. If PV is an analyzed expression which
8217 -- is an indexed component of a packed array that has not been
8218 -- properly expanded, turn off its Analyzed flag to make sure it
8219 -- gets properly reexpanded. If the prefix is an access value,
8220 -- the dereference will be added later.
8222 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
8223 -- an analyze with the old parent pointer. This may point e.g. to
8224 -- a subprogram call, which deactivates this expansion.
8227 and then Nkind
(PV
) = N_Indexed_Component
8228 and then Is_Array_Type
(Etype
(Prefix
(PV
)))
8229 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(PV
))))
8231 Set_Analyzed
(PV
, False);
8234 -- Build the raise CE node to check for validity. We build a type
8235 -- qualification for the prefix, since it may not be of the form of
8236 -- a name, and we don't care in this context!
8239 Make_Raise_Constraint_Error
(Loc
,
8243 Make_Attribute_Reference
(Loc
,
8245 Attribute_Name
=> Name_Valid
)),
8246 Reason
=> CE_Invalid_Data
);
8248 -- Insert the validity check. Note that we do this with validity
8249 -- checks turned off, to avoid recursion, we do not want validity
8250 -- checks on the validity checking code itself.
8252 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
8254 -- If the expression is a reference to an element of a bit-packed
8255 -- array, then it is rewritten as a renaming declaration. If the
8256 -- expression is an actual in a call, it has not been expanded,
8257 -- waiting for the proper point at which to do it. The same happens
8258 -- with renamings, so that we have to force the expansion now. This
8259 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
8262 if Is_Entity_Name
(Exp
)
8263 and then Nkind
(Parent
(Entity
(Exp
))) =
8264 N_Object_Renaming_Declaration
8267 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
8269 if Nkind
(Old_Exp
) = N_Indexed_Component
8270 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
8272 Expand_Packed_Element_Reference
(Old_Exp
);
8277 end Insert_Valid_Check
;
8279 -------------------------------------
8280 -- Is_Signed_Integer_Arithmetic_Op --
8281 -------------------------------------
8283 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
8297 return Is_Signed_Integer_Type
(Etype
(N
));
8299 when N_Case_Expression
8302 return Is_Signed_Integer_Type
(Etype
(N
));
8307 end Is_Signed_Integer_Arithmetic_Op
;
8309 ----------------------------------
8310 -- Install_Null_Excluding_Check --
8311 ----------------------------------
8313 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
8314 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
8315 Typ
: constant Entity_Id
:= Etype
(N
);
8317 procedure Mark_Non_Null
;
8318 -- After installation of check, if the node in question is an entity
8319 -- name, then mark this entity as non-null if possible.
8325 procedure Mark_Non_Null
is
8327 -- Only case of interest is if node N is an entity name
8329 if Is_Entity_Name
(N
) then
8331 -- For sure, we want to clear an indication that this is known to
8332 -- be null, since if we get past this check, it definitely is not.
8334 Set_Is_Known_Null
(Entity
(N
), False);
8336 -- We can mark the entity as known to be non-null if it is safe to
8337 -- capture the value.
8339 if Safe_To_Capture_Value
(N
, Entity
(N
)) then
8340 Set_Is_Known_Non_Null
(Entity
(N
));
8345 -- Start of processing for Install_Null_Excluding_Check
8348 -- No need to add null-excluding checks when the tree may not be fully
8351 if Serious_Errors_Detected
> 0 then
8355 pragma Assert
(Is_Access_Type
(Typ
));
8357 -- No check inside a generic, check will be emitted in instance
8359 if Inside_A_Generic
then
8363 -- No check needed if known to be non-null
8365 if Known_Non_Null
(N
) then
8369 -- If known to be null, here is where we generate a compile time check
8371 if Known_Null
(N
) then
8373 -- Avoid generating warning message inside init procs. In SPARK mode
8374 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
8375 -- since it will be turned into an error in any case.
8377 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
8379 -- Do not emit the warning within a conditional expression,
8380 -- where the expression might not be evaluated, and the warning
8381 -- appear as extraneous noise.
8383 and then not Within_Case_Or_If_Expression
(N
)
8385 Apply_Compile_Time_Constraint_Error
8386 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
8388 -- Remaining cases, where we silently insert the raise
8392 Make_Raise_Constraint_Error
(Loc
,
8393 Reason
=> CE_Access_Check_Failed
));
8400 -- If entity is never assigned, for sure a warning is appropriate
8402 if Is_Entity_Name
(N
) then
8403 Check_Unset_Reference
(N
);
8406 -- No check needed if checks are suppressed on the range. Note that we
8407 -- don't set Is_Known_Non_Null in this case (we could legitimately do
8408 -- so, since the program is erroneous, but we don't like to casually
8409 -- propagate such conclusions from erroneosity).
8411 if Access_Checks_Suppressed
(Typ
) then
8415 -- No check needed for access to concurrent record types generated by
8416 -- the expander. This is not just an optimization (though it does indeed
8417 -- remove junk checks). It also avoids generation of junk warnings.
8419 if Nkind
(N
) in N_Has_Chars
8420 and then Chars
(N
) = Name_uObject
8421 and then Is_Concurrent_Record_Type
8422 (Directly_Designated_Type
(Etype
(N
)))
8427 -- No check needed in interface thunks since the runtime check is
8428 -- already performed at the caller side.
8430 if Is_Thunk
(Current_Scope
) then
8434 -- In GNATprove mode, we do not apply the check
8436 if GNATprove_Mode
then
8440 -- Otherwise install access check
8443 Make_Raise_Constraint_Error
(Loc
,
8446 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
8447 Right_Opnd
=> Make_Null
(Loc
)),
8448 Reason
=> CE_Access_Check_Failed
));
8450 -- Mark the entity of N "non-null" except when assertions are enabled -
8451 -- since expansion becomes much more complicated (especially when it
8452 -- comes to contracts) due to the generation of wrappers and wholesale
8453 -- moving of declarations and statements which may happen.
8455 -- Additionally, it is assumed that extra checks will exist with
8456 -- assertions enabled so some potentially redundant checks are
8459 if not Assertions_Enabled
then
8462 end Install_Null_Excluding_Check
;
8464 -----------------------------------------
8465 -- Install_Primitive_Elaboration_Check --
8466 -----------------------------------------
8468 procedure Install_Primitive_Elaboration_Check
(Subp_Body
: Node_Id
) is
8469 function Within_Compilation_Unit_Instance
8470 (Subp_Id
: Entity_Id
) return Boolean;
8471 -- Determine whether subprogram Subp_Id appears within an instance which
8472 -- acts as a compilation unit.
8474 --------------------------------------
8475 -- Within_Compilation_Unit_Instance --
8476 --------------------------------------
8478 function Within_Compilation_Unit_Instance
8479 (Subp_Id
: Entity_Id
) return Boolean
8484 -- Examine the scope chain looking for a compilation-unit-level
8487 Pack
:= Scope
(Subp_Id
);
8488 while Present
(Pack
) and then Pack
/= Standard_Standard
loop
8489 if Ekind
(Pack
) = E_Package
8490 and then Is_Generic_Instance
(Pack
)
8491 and then Nkind
(Parent
(Unit_Declaration_Node
(Pack
))) =
8497 Pack
:= Scope
(Pack
);
8501 end Within_Compilation_Unit_Instance
;
8503 -- Local declarations
8505 Context
: constant Node_Id
:= Parent
(Subp_Body
);
8506 Loc
: constant Source_Ptr
:= Sloc
(Subp_Body
);
8507 Subp_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Body
);
8508 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
8511 Flag_Id
: Entity_Id
;
8514 Tag_Typ
: Entity_Id
;
8516 -- Start of processing for Install_Primitive_Elaboration_Check
8519 -- Do not generate an elaboration check in compilation modes where
8520 -- expansion is not desirable.
8522 if GNATprove_Mode
then
8525 -- Do not generate an elaboration check if all checks have been
8528 elsif Suppress_Checks
then
8531 -- Do not generate an elaboration check if the related subprogram is
8532 -- not subject to elaboration checks.
8534 elsif Elaboration_Checks_Suppressed
(Subp_Id
) then
8537 -- Do not generate an elaboration check if such code is not desirable
8539 elsif Restriction_Active
(No_Elaboration_Code
) then
8542 -- If pragma Pure or Preelaborate applies, then these elaboration checks
8543 -- cannot fail, so do not generate them.
8545 elsif In_Preelaborated_Unit
then
8548 -- Do not generate an elaboration check if exceptions cannot be used,
8549 -- caught, or propagated.
8551 elsif not Exceptions_OK
then
8554 -- Do not consider subprograms that are compilation units, because they
8555 -- cannot be the target of a dispatching call.
8557 elsif Nkind
(Context
) = N_Compilation_Unit
then
8560 -- Do not consider anything other than nonabstract library-level source
8564 (Comes_From_Source
(Subp_Id
)
8565 and then Is_Library_Level_Entity
(Subp_Id
)
8566 and then Is_Primitive
(Subp_Id
)
8567 and then not Is_Abstract_Subprogram
(Subp_Id
))
8571 -- Do not consider inlined primitives, because once the body is inlined
8572 -- the reference to the elaboration flag will be out of place and will
8573 -- result in an undefined symbol.
8575 elsif Is_Inlined
(Subp_Id
) or else Has_Pragma_Inline
(Subp_Id
) then
8578 -- Do not generate a duplicate elaboration check. This happens only in
8579 -- the case of primitives completed by an expression function, as the
8580 -- corresponding body is apparently analyzed and expanded twice.
8582 elsif Analyzed
(Subp_Body
) then
8585 -- Do not consider primitives that occur within an instance that is a
8586 -- compilation unit. Such an instance defines its spec and body out of
8587 -- order (body is first) within the tree, which causes the reference to
8588 -- the elaboration flag to appear as an undefined symbol.
8590 elsif Within_Compilation_Unit_Instance
(Subp_Id
) then
8594 Tag_Typ
:= Find_Dispatching_Type
(Subp_Id
);
8596 -- Only tagged primitives may be the target of a dispatching call
8598 if No
(Tag_Typ
) then
8601 -- Do not consider finalization-related primitives, because they may
8602 -- need to be called while elaboration is taking place.
8604 elsif Is_Controlled
(Tag_Typ
)
8606 Chars
(Subp_Id
) in Name_Adjust | Name_Finalize | Name_Initialize
8611 -- Create the declaration of the elaboration flag. The name carries a
8612 -- unique counter in case of name overloading.
8615 Make_Defining_Identifier
(Loc
,
8616 Chars
=> New_External_Name
(Chars
(Subp_Id
), 'E', -1));
8617 Set_Is_Frozen
(Flag_Id
);
8619 -- Insert the declaration of the elaboration flag in front of the
8620 -- primitive spec and analyze it in the proper context.
8622 Push_Scope
(Scope
(Subp_Id
));
8625 -- E : Boolean := False;
8627 Insert_Action
(Subp_Decl
,
8628 Make_Object_Declaration
(Loc
,
8629 Defining_Identifier
=> Flag_Id
,
8630 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8631 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
8634 -- Prevent the compiler from optimizing the elaboration check by killing
8635 -- the current value of the flag and the associated assignment.
8637 Set_Current_Value
(Flag_Id
, Empty
);
8638 Set_Last_Assignment
(Flag_Id
, Empty
);
8640 -- Add a check at the top of the body declarations to ensure that the
8641 -- elaboration flag has been set.
8643 Decls
:= Declarations
(Subp_Body
);
8647 Set_Declarations
(Subp_Body
, Decls
);
8652 -- raise Program_Error with "access before elaboration";
8656 Make_Raise_Program_Error
(Loc
,
8659 Right_Opnd
=> New_Occurrence_Of
(Flag_Id
, Loc
)),
8660 Reason
=> PE_Access_Before_Elaboration
));
8662 Analyze
(First
(Decls
));
8664 -- Set the elaboration flag once the body has been elaborated. Insert
8665 -- the statement after the subprogram stub when the primitive body is
8668 if Nkind
(Context
) = N_Subunit
then
8669 Set_Ins
:= Corresponding_Stub
(Context
);
8671 Set_Ins
:= Subp_Body
;
8678 Make_Assignment_Statement
(Loc
,
8679 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
8680 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
8682 -- Mark the assignment statement as elaboration code. This allows the
8683 -- early call region mechanism (see Sem_Elab) to properly ignore such
8684 -- assignments even though they are non-preelaborable code.
8686 Set_Is_Elaboration_Code
(Set_Stmt
);
8688 Insert_After_And_Analyze
(Set_Ins
, Set_Stmt
);
8689 end Install_Primitive_Elaboration_Check
;
8691 --------------------------
8692 -- Install_Static_Check --
8693 --------------------------
8695 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
8696 Stat
: constant Boolean := Is_OK_Static_Expression
(R_Cno
);
8697 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
8701 Make_Raise_Constraint_Error
(Loc
,
8702 Reason
=> CE_Range_Check_Failed
));
8703 Set_Analyzed
(R_Cno
);
8704 Set_Etype
(R_Cno
, Typ
);
8705 Set_Raises_Constraint_Error
(R_Cno
);
8706 Set_Is_Static_Expression
(R_Cno
, Stat
);
8708 -- Now deal with possible local raise handling
8710 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
8711 end Install_Static_Check
;
8713 -------------------------
8714 -- Is_Check_Suppressed --
8715 -------------------------
8717 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
8718 Ptr
: Suppress_Stack_Entry_Ptr
;
8721 -- First search the local entity suppress stack. We search this from the
8722 -- top of the stack down so that we get the innermost entry that applies
8723 -- to this case if there are nested entries.
8725 Ptr
:= Local_Suppress_Stack_Top
;
8726 while Ptr
/= null loop
8727 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8728 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8730 return Ptr
.Suppress
;
8736 -- Now search the global entity suppress table for a matching entry.
8737 -- We also search this from the top down so that if there are multiple
8738 -- pragmas for the same entity, the last one applies (not clear what
8739 -- or whether the RM specifies this handling, but it seems reasonable).
8741 Ptr
:= Global_Suppress_Stack_Top
;
8742 while Ptr
/= null loop
8743 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8744 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8746 return Ptr
.Suppress
;
8752 -- If we did not find a matching entry, then use the normal scope
8753 -- suppress value after all (actually this will be the global setting
8754 -- since it clearly was not overridden at any point). For a predefined
8755 -- check, we test the specific flag. For a user defined check, we check
8756 -- the All_Checks flag. The Overflow flag requires special handling to
8757 -- deal with the General vs Assertion case.
8759 if C
= Overflow_Check
then
8760 return Overflow_Checks_Suppressed
(Empty
);
8762 elsif C
in Predefined_Check_Id
then
8763 return Scope_Suppress
.Suppress
(C
);
8766 return Scope_Suppress
.Suppress
(All_Checks
);
8768 end Is_Check_Suppressed
;
8770 ---------------------
8771 -- Kill_All_Checks --
8772 ---------------------
8774 procedure Kill_All_Checks
is
8776 if Debug_Flag_CC
then
8777 w
("Kill_All_Checks");
8780 -- We reset the number of saved checks to zero, and also modify all
8781 -- stack entries for statement ranges to indicate that the number of
8782 -- checks at each level is now zero.
8784 Num_Saved_Checks
:= 0;
8786 -- Note: the Int'Min here avoids any possibility of J being out of
8787 -- range when called from e.g. Conditional_Statements_Begin.
8789 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
8790 Saved_Checks_Stack
(J
) := 0;
8792 end Kill_All_Checks
;
8798 procedure Kill_Checks
(V
: Entity_Id
) is
8800 if Debug_Flag_CC
then
8801 w
("Kill_Checks for entity", Int
(V
));
8804 for J
in 1 .. Num_Saved_Checks
loop
8805 if Saved_Checks
(J
).Entity
= V
then
8806 if Debug_Flag_CC
then
8807 w
(" Checks killed for saved check ", J
);
8810 Saved_Checks
(J
).Killed
:= True;
8815 ------------------------------
8816 -- Length_Checks_Suppressed --
8817 ------------------------------
8819 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8821 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8822 return Is_Check_Suppressed
(E
, Length_Check
);
8824 return Scope_Suppress
.Suppress
(Length_Check
);
8826 end Length_Checks_Suppressed
;
8828 -----------------------
8829 -- Make_Bignum_Block --
8830 -----------------------
8832 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
8833 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
8836 Make_Block_Statement
(Loc
,
8838 New_List
(Build_SS_Mark_Call
(Loc
, M
)),
8839 Handled_Statement_Sequence
=>
8840 Make_Handled_Sequence_Of_Statements
(Loc
,
8841 Statements
=> New_List
(Build_SS_Release_Call
(Loc
, M
))));
8842 end Make_Bignum_Block
;
8844 ----------------------------------
8845 -- Minimize_Eliminate_Overflows --
8846 ----------------------------------
8848 -- This is a recursive routine that is called at the top of an expression
8849 -- tree to properly process overflow checking for a whole subtree by making
8850 -- recursive calls to process operands. This processing may involve the use
8851 -- of bignum or long long integer arithmetic, which will change the types
8852 -- of operands and results. That's why we can't do this bottom up (since
8853 -- it would interfere with semantic analysis).
8855 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
8856 -- the operator expansion routines, as well as the expansion routines for
8857 -- if/case expression, do nothing (for the moment) except call the routine
8858 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
8859 -- routine does nothing for non top-level nodes, so at the point where the
8860 -- call is made for the top level node, the entire expression subtree has
8861 -- not been expanded, or processed for overflow. All that has to happen as
8862 -- a result of the top level call to this routine.
8864 -- As noted above, the overflow processing works by making recursive calls
8865 -- for the operands, and figuring out what to do, based on the processing
8866 -- of these operands (e.g. if a bignum operand appears, the parent op has
8867 -- to be done in bignum mode), and the determined ranges of the operands.
8869 -- After possible rewriting of a constituent subexpression node, a call is
8870 -- made to either reexpand the node (if nothing has changed) or reanalyze
8871 -- the node (if it has been modified by the overflow check processing). The
8872 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
8873 -- a recursive call into the whole overflow apparatus, an important rule
8874 -- for this call is that the overflow handling mode must be temporarily set
8877 procedure Minimize_Eliminate_Overflows
8881 Top_Level
: Boolean)
8883 Rtyp
: constant Entity_Id
:= Etype
(N
);
8884 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
8885 -- Result type, must be a signed integer type
8887 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
8888 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
8890 Loc
: constant Source_Ptr
:= Sloc
(N
);
8893 -- Ranges of values for right operand (operator case)
8895 Llo
: Uint
:= No_Uint
; -- initialize to prevent warning
8896 Lhi
: Uint
:= No_Uint
; -- initialize to prevent warning
8897 -- Ranges of values for left operand (operator case)
8899 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
8900 -- Operands and results are of this type when we convert
8902 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
8903 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
8904 -- Bounds of Long_Long_Integer
8906 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
8907 -- Indicates binary operator case
8910 -- Used in call to Determine_Range
8912 Bignum_Operands
: Boolean;
8913 -- Set True if one or more operands is already of type Bignum, meaning
8914 -- that for sure (regardless of Top_Level setting) we are committed to
8915 -- doing the operation in Bignum mode (or in the case of a case or if
8916 -- expression, converting all the dependent expressions to Bignum).
8918 Long_Long_Integer_Operands
: Boolean;
8919 -- Set True if one or more operands is already of type Long_Long_Integer
8920 -- which means that if the result is known to be in the result type
8921 -- range, then we must convert such operands back to the result type.
8923 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
8924 -- This is called when we have modified the node and we therefore need
8925 -- to reanalyze it. It is important that we reset the mode to STRICT for
8926 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
8927 -- we would reenter this routine recursively which would not be good.
8928 -- The argument Suppress is set True if we also want to suppress
8929 -- overflow checking for the reexpansion (this is set when we know
8930 -- overflow is not possible). Typ is the type for the reanalysis.
8932 procedure Reexpand
(Suppress
: Boolean := False);
8933 -- This is like Reanalyze, but does not do the Analyze step, it only
8934 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
8935 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
8936 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
8937 -- Note that skipping reanalysis is not just an optimization, testing
8938 -- has showed up several complex cases in which reanalyzing an already
8939 -- analyzed node causes incorrect behavior.
8941 function In_Result_Range
return Boolean;
8942 -- Returns True iff Lo .. Hi are within range of the result type
8944 procedure Max
(A
: in out Uint
; B
: Uint
);
8945 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
8947 procedure Min
(A
: in out Uint
; B
: Uint
);
8948 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
8950 ---------------------
8951 -- In_Result_Range --
8952 ---------------------
8954 function In_Result_Range
return Boolean is
8956 if No
(Lo
) or else No
(Hi
) then
8959 elsif Is_OK_Static_Subtype
(Etype
(N
)) then
8960 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
8962 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
8965 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
8967 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
8969 end In_Result_Range
;
8975 procedure Max
(A
: in out Uint
; B
: Uint
) is
8977 if No
(A
) or else B
> A
then
8986 procedure Min
(A
: in out Uint
; B
: Uint
) is
8988 if No
(A
) or else B
< A
then
8997 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
8998 Svg
: constant Overflow_Mode_Type
:=
8999 Scope_Suppress
.Overflow_Mode_General
;
9000 Sva
: constant Overflow_Mode_Type
:=
9001 Scope_Suppress
.Overflow_Mode_Assertions
;
9002 Svo
: constant Boolean :=
9003 Scope_Suppress
.Suppress
(Overflow_Check
);
9006 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9007 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9010 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
9013 Analyze_And_Resolve
(N
, Typ
);
9015 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
9016 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
9017 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
9024 procedure Reexpand
(Suppress
: Boolean := False) is
9025 Svg
: constant Overflow_Mode_Type
:=
9026 Scope_Suppress
.Overflow_Mode_General
;
9027 Sva
: constant Overflow_Mode_Type
:=
9028 Scope_Suppress
.Overflow_Mode_Assertions
;
9029 Svo
: constant Boolean :=
9030 Scope_Suppress
.Suppress
(Overflow_Check
);
9033 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9034 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9035 Set_Analyzed
(N
, False);
9038 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
9043 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
9044 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
9045 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
9048 -- Start of processing for Minimize_Eliminate_Overflows
9051 -- Default initialize Lo and Hi since these are not guaranteed to be
9057 -- Case where we do not have a signed integer arithmetic operation
9059 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
9061 -- Use the normal Determine_Range routine to get the range. We
9062 -- don't require operands to be valid, invalid values may result in
9063 -- rubbish results where the result has not been properly checked for
9064 -- overflow, that's fine.
9066 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
9068 -- If Determine_Range did not work (can this in fact happen? Not
9069 -- clear but might as well protect), use type bounds.
9072 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
9073 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
9076 -- If we don't have a binary operator, all we have to do is to set
9077 -- the Hi/Lo range, so we are done.
9081 -- Processing for if expression
9083 elsif Nkind
(N
) = N_If_Expression
then
9085 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
9086 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
9089 Bignum_Operands
:= False;
9091 Minimize_Eliminate_Overflows
9092 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
9095 Bignum_Operands
:= True;
9098 Minimize_Eliminate_Overflows
9099 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
9102 Bignum_Operands
:= True;
9104 Long_Long_Integer_Operands
:=
9105 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
9111 -- If at least one of our operands is now Bignum, we must rebuild
9112 -- the if expression to use Bignum operands. We will analyze the
9113 -- rebuilt if expression with overflow checks off, since once we
9114 -- are in bignum mode, we are all done with overflow checks.
9116 if Bignum_Operands
then
9118 Make_If_Expression
(Loc
,
9119 Expressions
=> New_List
(
9120 Remove_Head
(Expressions
(N
)),
9121 Convert_To_Bignum
(Then_DE
),
9122 Convert_To_Bignum
(Else_DE
)),
9123 Is_Elsif
=> Is_Elsif
(N
)));
9125 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
9127 -- If we have no Long_Long_Integer operands, then we are in result
9128 -- range, since it means that none of our operands felt the need
9129 -- to worry about overflow (otherwise it would have already been
9130 -- converted to long long integer or bignum). We reexpand to
9131 -- complete the expansion of the if expression (but we do not
9132 -- need to reanalyze).
9134 elsif not Long_Long_Integer_Operands
then
9135 Set_Do_Overflow_Check
(N
, False);
9138 -- Otherwise convert us to long long integer mode. Note that we
9139 -- don't need any further overflow checking at this level.
9142 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
9143 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
9144 Set_Etype
(N
, LLIB
);
9146 -- Now reanalyze with overflow checks off
9148 Set_Do_Overflow_Check
(N
, False);
9149 Reanalyze
(LLIB
, Suppress
=> True);
9155 -- Here for case expression
9157 elsif Nkind
(N
) = N_Case_Expression
then
9158 Bignum_Operands
:= False;
9159 Long_Long_Integer_Operands
:= False;
9165 -- Loop through expressions applying recursive call
9167 Alt
:= First
(Alternatives
(N
));
9168 while Present
(Alt
) loop
9170 Aexp
: constant Node_Id
:= Expression
(Alt
);
9173 Minimize_Eliminate_Overflows
9174 (Aexp
, Lo
, Hi
, Top_Level
=> False);
9177 Bignum_Operands
:= True;
9178 elsif Etype
(Aexp
) = LLIB
then
9179 Long_Long_Integer_Operands
:= True;
9186 -- If we have no bignum or long long integer operands, it means
9187 -- that none of our dependent expressions could raise overflow.
9188 -- In this case, we simply return with no changes except for
9189 -- resetting the overflow flag, since we are done with overflow
9190 -- checks for this node. We will reexpand to get the needed
9191 -- expansion for the case expression, but we do not need to
9192 -- reanalyze, since nothing has changed.
9194 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
9195 Set_Do_Overflow_Check
(N
, False);
9196 Reexpand
(Suppress
=> True);
9198 -- Otherwise we are going to rebuild the case expression using
9199 -- either bignum or long long integer operands throughout.
9203 Rtype
: Entity_Id
:= Empty
;
9208 New_Alts
:= New_List
;
9209 Alt
:= First
(Alternatives
(N
));
9210 while Present
(Alt
) loop
9211 if Bignum_Operands
then
9212 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
9213 Rtype
:= RTE
(RE_Bignum
);
9215 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
9219 Append_To
(New_Alts
,
9220 Make_Case_Expression_Alternative
(Sloc
(Alt
),
9221 Discrete_Choices
=> Discrete_Choices
(Alt
),
9222 Expression
=> New_Exp
));
9228 Make_Case_Expression
(Loc
,
9229 Expression
=> Expression
(N
),
9230 Alternatives
=> New_Alts
));
9232 pragma Assert
(Present
(Rtype
));
9233 Reanalyze
(Rtype
, Suppress
=> True);
9241 -- If we have an arithmetic operator we make recursive calls on the
9242 -- operands to get the ranges (and to properly process the subtree
9243 -- that lies below us).
9245 Minimize_Eliminate_Overflows
9246 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
9249 Minimize_Eliminate_Overflows
9250 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
9253 -- Record if we have Long_Long_Integer operands
9255 Long_Long_Integer_Operands
:=
9256 Etype
(Right_Opnd
(N
)) = LLIB
9257 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
9259 -- If either operand is a bignum, then result will be a bignum and we
9260 -- don't need to do any range analysis. As previously discussed we could
9261 -- do range analysis in such cases, but it could mean working with giant
9262 -- numbers at compile time for very little gain (the number of cases
9263 -- in which we could slip back from bignum mode is small).
9265 if No
(Rlo
) or else (Binary
and then No
(Llo
)) then
9268 Bignum_Operands
:= True;
9270 -- Otherwise compute result range
9273 Compute_Range_For_Arithmetic_Op
9274 (Nkind
(N
), Llo
, Lhi
, Rlo
, Rhi
, OK
, Lo
, Hi
);
9275 Bignum_Operands
:= False;
9278 -- Here for the case where we have not rewritten anything (no bignum
9279 -- operands or long long integer operands), and we know the result.
9280 -- If we know we are in the result range, and we do not have Bignum
9281 -- operands or Long_Long_Integer operands, we can just reexpand with
9282 -- overflow checks turned off (since we know we cannot have overflow).
9283 -- As always the reexpansion is required to complete expansion of the
9284 -- operator, but we do not need to reanalyze, and we prevent recursion
9285 -- by suppressing the check.
9287 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
9288 and then In_Result_Range
9290 Set_Do_Overflow_Check
(N
, False);
9291 Reexpand
(Suppress
=> True);
9294 -- Here we know that we are not in the result range, and in the general
9295 -- case we will move into either the Bignum or Long_Long_Integer domain
9296 -- to compute the result. However, there is one exception. If we are
9297 -- at the top level, and we do not have Bignum or Long_Long_Integer
9298 -- operands, we will have to immediately convert the result back to
9299 -- the result type, so there is no point in Bignum/Long_Long_Integer
9303 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
9305 -- One further refinement. If we are at the top level, but our parent
9306 -- is a type conversion, then go into bignum or long long integer node
9307 -- since the result will be converted to that type directly without
9308 -- going through the result type, and we may avoid an overflow. This
9309 -- is the case for example of Long_Long_Integer (A ** 4), where A is
9310 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
9311 -- but does not fit in Integer.
9313 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
9315 -- Here keep original types, but we need to complete analysis
9317 -- One subtlety. We can't just go ahead and do an analyze operation
9318 -- here because it will cause recursion into the whole MINIMIZED/
9319 -- ELIMINATED overflow processing which is not what we want. Here
9320 -- we are at the top level, and we need a check against the result
9321 -- mode (i.e. we want to use STRICT mode). So do exactly that.
9322 -- Also, we have not modified the node, so this is a case where
9323 -- we need to reexpand, but not reanalyze.
9328 -- Cases where we do the operation in Bignum mode. This happens either
9329 -- because one of our operands is in Bignum mode already, or because
9330 -- the computed bounds are outside the bounds of Long_Long_Integer,
9331 -- which in some cases can be indicated by Hi and Lo being No_Uint.
9333 -- Note: we could do better here and in some cases switch back from
9334 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
9335 -- 0 .. 1, but the cases are rare and it is not worth the effort.
9336 -- Failing to do this switching back is only an efficiency issue.
9338 elsif No
(Lo
) or else Lo
< LLLo
or else Hi
> LLHi
then
9340 -- OK, we are definitely outside the range of Long_Long_Integer. The
9341 -- question is whether to move to Bignum mode, or stay in the domain
9342 -- of Long_Long_Integer, signalling that an overflow check is needed.
9344 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
9345 -- the Bignum business. In ELIMINATED mode, we will normally move
9346 -- into Bignum mode, but there is an exception if neither of our
9347 -- operands is Bignum now, and we are at the top level (Top_Level
9348 -- set True). In this case, there is no point in moving into Bignum
9349 -- mode to prevent overflow if the caller will immediately convert
9350 -- the Bignum value back to LLI with an overflow check. It's more
9351 -- efficient to stay in LLI mode with an overflow check (if needed)
9353 if Check_Mode
= Minimized
9354 or else (Top_Level
and not Bignum_Operands
)
9356 if Do_Overflow_Check
(N
) then
9357 Enable_Overflow_Check
(N
);
9360 -- The result now has to be in Long_Long_Integer mode, so adjust
9361 -- the possible range to reflect this. Note these calls also
9362 -- change No_Uint values from the top level case to LLI bounds.
9367 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
9370 pragma Assert
(Check_Mode
= Eliminated
);
9379 Fent
:= RTE
(RE_Big_Abs
);
9382 Fent
:= RTE
(RE_Big_Add
);
9385 Fent
:= RTE
(RE_Big_Div
);
9388 Fent
:= RTE
(RE_Big_Exp
);
9391 Fent
:= RTE
(RE_Big_Neg
);
9394 Fent
:= RTE
(RE_Big_Mod
);
9396 when N_Op_Multiply
=>
9397 Fent
:= RTE
(RE_Big_Mul
);
9400 Fent
:= RTE
(RE_Big_Rem
);
9402 when N_Op_Subtract
=>
9403 Fent
:= RTE
(RE_Big_Sub
);
9405 -- Anything else is an internal error, this includes the
9406 -- N_Op_Plus case, since how can plus cause the result
9407 -- to be out of range if the operand is in range?
9410 raise Program_Error
;
9413 -- Construct argument list for Bignum call, converting our
9414 -- operands to Bignum form if they are not already there.
9419 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
9422 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
9424 -- Now rewrite the arithmetic operator with a call to the
9425 -- corresponding bignum function.
9428 Make_Function_Call
(Loc
,
9429 Name
=> New_Occurrence_Of
(Fent
, Loc
),
9430 Parameter_Associations
=> Args
));
9431 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
9433 -- Indicate result is Bignum mode
9441 -- Otherwise we are in range of Long_Long_Integer, so no overflow
9442 -- check is required, at least not yet.
9445 Set_Do_Overflow_Check
(N
, False);
9448 -- Here we are not in Bignum territory, but we may have long long
9449 -- integer operands that need special handling. First a special check:
9450 -- If an exponentiation operator exponent is of type Long_Long_Integer,
9451 -- it means we converted it to prevent overflow, but exponentiation
9452 -- requires a Natural right operand, so convert it back to Natural.
9453 -- This conversion may raise an exception which is fine.
9455 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
9456 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
9459 -- Here we will do the operation in Long_Long_Integer. We do this even
9460 -- if we know an overflow check is required, better to do this in long
9461 -- long integer mode, since we are less likely to overflow.
9463 -- Convert right or only operand to Long_Long_Integer, except that
9464 -- we do not touch the exponentiation right operand.
9466 if Nkind
(N
) /= N_Op_Expon
then
9467 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
9470 -- Convert left operand to Long_Long_Integer for binary case
9473 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
9476 -- Reset node to unanalyzed
9478 Set_Analyzed
(N
, False);
9479 Set_Etype
(N
, Empty
);
9480 Set_Entity
(N
, Empty
);
9482 -- Now analyze this new node. This reanalysis will complete processing
9483 -- for the node. In particular we will complete the expansion of an
9484 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
9485 -- we will complete any division checks (since we have not changed the
9486 -- setting of the Do_Division_Check flag).
9488 -- We do this reanalysis in STRICT mode to avoid recursion into the
9489 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
9492 SG
: constant Overflow_Mode_Type
:=
9493 Scope_Suppress
.Overflow_Mode_General
;
9494 SA
: constant Overflow_Mode_Type
:=
9495 Scope_Suppress
.Overflow_Mode_Assertions
;
9498 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9499 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9501 if not Do_Overflow_Check
(N
) then
9502 Reanalyze
(LLIB
, Suppress
=> True);
9507 Scope_Suppress
.Overflow_Mode_General
:= SG
;
9508 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
9510 end Minimize_Eliminate_Overflows
;
9512 -------------------------
9513 -- Overflow_Check_Mode --
9514 -------------------------
9516 function Overflow_Check_Mode
return Overflow_Mode_Type
is
9518 if In_Assertion_Expr
= 0 then
9519 return Scope_Suppress
.Overflow_Mode_General
;
9521 return Scope_Suppress
.Overflow_Mode_Assertions
;
9523 end Overflow_Check_Mode
;
9525 --------------------------------
9526 -- Overflow_Checks_Suppressed --
9527 --------------------------------
9529 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9531 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9532 return Is_Check_Suppressed
(E
, Overflow_Check
);
9534 return Scope_Suppress
.Suppress
(Overflow_Check
);
9536 end Overflow_Checks_Suppressed
;
9538 ---------------------------------
9539 -- Predicate_Checks_Suppressed --
9540 ---------------------------------
9542 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9544 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9545 return Is_Check_Suppressed
(E
, Predicate_Check
);
9547 return Scope_Suppress
.Suppress
(Predicate_Check
);
9549 end Predicate_Checks_Suppressed
;
9551 -----------------------------
9552 -- Range_Checks_Suppressed --
9553 -----------------------------
9555 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9558 if Kill_Range_Checks
(E
) then
9561 elsif Checks_May_Be_Suppressed
(E
) then
9562 return Is_Check_Suppressed
(E
, Range_Check
);
9566 return Scope_Suppress
.Suppress
(Range_Check
);
9567 end Range_Checks_Suppressed
;
9569 -----------------------------------------
9570 -- Range_Or_Validity_Checks_Suppressed --
9571 -----------------------------------------
9573 -- Note: the coding would be simpler here if we simply made appropriate
9574 -- calls to Range/Validity_Checks_Suppressed, but that would result in
9575 -- duplicated checks which we prefer to avoid.
9577 function Range_Or_Validity_Checks_Suppressed
9578 (Expr
: Node_Id
) return Boolean
9581 -- Immediate return if scope checks suppressed for either check
9583 if Scope_Suppress
.Suppress
(Range_Check
)
9585 Scope_Suppress
.Suppress
(Validity_Check
)
9590 -- If no expression, that's odd, decide that checks are suppressed,
9591 -- since we don't want anyone trying to do checks in this case, which
9592 -- is most likely the result of some other error.
9598 -- Expression is present, so perform suppress checks on type
9601 Typ
: constant Entity_Id
:= Etype
(Expr
);
9603 if Checks_May_Be_Suppressed
(Typ
)
9604 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
9606 Is_Check_Suppressed
(Typ
, Validity_Check
))
9612 -- If expression is an entity name, perform checks on this entity
9614 if Is_Entity_Name
(Expr
) then
9616 Ent
: constant Entity_Id
:= Entity
(Expr
);
9618 if Checks_May_Be_Suppressed
(Ent
) then
9619 return Is_Check_Suppressed
(Ent
, Range_Check
)
9620 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
9625 -- If we fall through, no checks suppressed
9628 end Range_Or_Validity_Checks_Suppressed
;
9634 procedure Remove_Checks
(Expr
: Node_Id
) is
9635 function Process
(N
: Node_Id
) return Traverse_Result
;
9636 -- Process a single node during the traversal
9638 procedure Traverse
is new Traverse_Proc
(Process
);
9639 -- The traversal procedure itself
9645 function Process
(N
: Node_Id
) return Traverse_Result
is
9647 if Nkind
(N
) not in N_Subexpr
then
9651 Set_Do_Range_Check
(N
, False);
9655 Traverse
(Left_Opnd
(N
));
9658 when N_Attribute_Reference
=>
9659 Set_Do_Overflow_Check
(N
, False);
9662 Set_Do_Overflow_Check
(N
, False);
9666 Set_Do_Division_Check
(N
, False);
9669 Set_Do_Length_Check
(N
, False);
9672 Set_Do_Division_Check
(N
, False);
9675 Set_Do_Length_Check
(N
, False);
9678 Set_Do_Division_Check
(N
, False);
9681 Set_Do_Length_Check
(N
, False);
9688 Traverse
(Left_Opnd
(N
));
9691 when N_Selected_Component
=>
9692 Set_Do_Discriminant_Check
(N
, False);
9694 when N_Type_Conversion
=>
9695 Set_Do_Length_Check
(N
, False);
9696 Set_Do_Overflow_Check
(N
, False);
9705 -- Start of processing for Remove_Checks
9711 ----------------------------
9712 -- Selected_Length_Checks --
9713 ----------------------------
9715 function Selected_Length_Checks
9717 Target_Typ
: Entity_Id
;
9718 Source_Typ
: Entity_Id
;
9719 Warn_Node
: Node_Id
) return Check_Result
9721 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
9724 Expr_Actual
: Node_Id
;
9726 Cond
: Node_Id
:= Empty
;
9727 Do_Access
: Boolean := False;
9728 Wnode
: Node_Id
:= Warn_Node
;
9729 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9730 Num_Checks
: Natural := 0;
9732 procedure Add_Check
(N
: Node_Id
);
9733 -- Adds the action given to Ret_Result if N is non-Empty
9735 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
9736 -- Return E'Length (Indx)
9738 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9739 -- Return N'Length (Indx)
9741 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
9742 -- True for equal literals and for nodes that denote the same constant
9743 -- entity, even if its value is not a static constant. This includes the
9744 -- case of a discriminal reference within an init proc. Removes some
9745 -- obviously superfluous checks.
9747 function Length_E_Cond
9748 (Exptyp
: Entity_Id
;
9750 Indx
: Nat
) return Node_Id
;
9751 -- Returns expression to compute:
9752 -- Typ'Length /= Exptyp'Length
9754 function Length_N_Cond
9757 Indx
: Nat
) return Node_Id
;
9758 -- Returns expression to compute:
9759 -- Typ'Length /= Exp'Length
9761 function Length_Mismatch_Info_Message
9762 (Left_Element_Count
: Unat
;
9763 Right_Element_Count
: Unat
) return String;
9764 -- Returns a message indicating how many elements were expected
9765 -- (Left_Element_Count) and how many were found (Right_Element_Count).
9771 procedure Add_Check
(N
: Node_Id
) is
9775 -- We do not support inserting more than 2 checks on the same
9776 -- node. If this happens it means we have already added an
9777 -- unconditional raise, so we can skip the other checks safely
9778 -- since N will always raise an exception.
9780 if Num_Checks
= 2 then
9784 pragma Assert
(Num_Checks
<= 1);
9785 Num_Checks
:= Num_Checks
+ 1;
9786 Ret_Result
(Num_Checks
) := N
;
9794 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
9795 SE
: constant Entity_Id
:= Scope
(E
);
9797 E1
: Entity_Id
:= E
;
9800 if Ekind
(Scope
(E
)) = E_Record_Type
9801 and then Has_Discriminants
(Scope
(E
))
9803 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
9806 Insert_Action
(Expr
, N
);
9807 E1
:= Defining_Identifier
(N
);
9811 if Ekind
(E1
) = E_String_Literal_Subtype
then
9813 Make_Integer_Literal
(Loc
,
9814 Intval
=> String_Literal_Length
(E1
));
9816 elsif SE
/= Standard_Standard
9817 and then Ekind
(Scope
(SE
)) = E_Protected_Type
9818 and then Has_Discriminants
(Scope
(SE
))
9819 and then Has_Completion
(Scope
(SE
))
9820 and then not Inside_Init_Proc
9822 -- If the type whose length is needed is a private component
9823 -- constrained by a discriminant, we must expand the 'Length
9824 -- attribute into an explicit computation, using the discriminal
9825 -- of the current protected operation. This is because the actual
9826 -- type of the prival is constructed after the protected opera-
9827 -- tion has been fully expanded.
9830 Indx_Type
: Node_Id
;
9831 Bounds
: Range_Nodes
;
9832 Do_Expand
: Boolean := False;
9835 Indx_Type
:= First_Index
(E
);
9837 for J
in 1 .. Indx
- 1 loop
9838 Next_Index
(Indx_Type
);
9841 Bounds
:= Get_Index_Bounds
(Indx_Type
);
9843 if Nkind
(Bounds
.First
) = N_Identifier
9844 and then Ekind
(Entity
(Bounds
.First
)) = E_In_Parameter
9846 Bounds
.First
:= Get_Discriminal
(E
, Bounds
.First
);
9850 if Nkind
(Bounds
.Last
) = N_Identifier
9851 and then Ekind
(Entity
(Bounds
.Last
)) = E_In_Parameter
9853 Bounds
.Last
:= Get_Discriminal
(E
, Bounds
.Last
);
9858 if not Is_Entity_Name
(Bounds
.First
) then
9860 Duplicate_Subexpr_No_Checks
(Bounds
.First
);
9863 if not Is_Entity_Name
(Bounds
.Last
) then
9864 Bounds
.First
:= Duplicate_Subexpr_No_Checks
(Bounds
.Last
);
9870 Make_Op_Subtract
(Loc
,
9871 Left_Opnd
=> Bounds
.Last
,
9872 Right_Opnd
=> Bounds
.First
),
9874 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
9879 Make_Attribute_Reference
(Loc
,
9880 Attribute_Name
=> Name_Length
,
9882 New_Occurrence_Of
(E1
, Loc
));
9885 Set_Expressions
(N
, New_List
(
9886 Make_Integer_Literal
(Loc
, Indx
)));
9895 Make_Attribute_Reference
(Loc
,
9896 Attribute_Name
=> Name_Length
,
9898 New_Occurrence_Of
(E1
, Loc
));
9901 Set_Expressions
(N
, New_List
(
9902 Make_Integer_Literal
(Loc
, Indx
)));
9913 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9916 Make_Attribute_Reference
(Loc
,
9917 Attribute_Name
=> Name_Length
,
9919 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9920 Expressions
=> New_List
(
9921 Make_Integer_Literal
(Loc
, Indx
)));
9928 function Length_E_Cond
9929 (Exptyp
: Entity_Id
;
9931 Indx
: Nat
) return Node_Id
9936 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9937 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
9944 function Length_N_Cond
9947 Indx
: Nat
) return Node_Id
9952 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9953 Right_Opnd
=> Get_N_Length
(Exp
, Indx
));
9956 ----------------------------------
9957 -- Length_Mismatch_Info_Message --
9958 ----------------------------------
9960 function Length_Mismatch_Info_Message
9961 (Left_Element_Count
: Unat
;
9962 Right_Element_Count
: Unat
) return String
9965 function Plural_Vs_Singular_Ending
(Count
: Unat
) return String;
9966 -- Returns an empty string if Count is 1; otherwise returns "s"
9968 function Plural_Vs_Singular_Ending
(Count
: Unat
) return String is
9975 end Plural_Vs_Singular_Ending
;
9979 & UI_Image
(Left_Element_Count
, Format
=> Decimal
)
9981 & Plural_Vs_Singular_Ending
(Left_Element_Count
)
9983 & UI_Image
(Right_Element_Count
, Format
=> Decimal
)
9985 & Plural_Vs_Singular_Ending
(Right_Element_Count
);
9986 -- "Format => Decimal" above is needed because otherwise UI_Image
9987 -- can sometimes return a hexadecimal number 16#...#, but "#" means
9988 -- something special to Errout. A previous version used the default
9989 -- Auto, which was essentially the same bug as documented here:
9990 -- https://xkcd.com/327/ .
9991 end Length_Mismatch_Info_Message
;
9997 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
10000 (Nkind
(L
) = N_Integer_Literal
10001 and then Nkind
(R
) = N_Integer_Literal
10002 and then Intval
(L
) = Intval
(R
))
10005 (Is_Entity_Name
(L
)
10006 and then Ekind
(Entity
(L
)) = E_Constant
10007 and then ((Is_Entity_Name
(R
)
10008 and then Entity
(L
) = Entity
(R
))
10010 (Nkind
(R
) = N_Type_Conversion
10011 and then Is_Entity_Name
(Expression
(R
))
10012 and then Entity
(L
) = Entity
(Expression
(R
)))))
10015 (Is_Entity_Name
(R
)
10016 and then Ekind
(Entity
(R
)) = E_Constant
10017 and then Nkind
(L
) = N_Type_Conversion
10018 and then Is_Entity_Name
(Expression
(L
))
10019 and then Entity
(R
) = Entity
(Expression
(L
)))
10022 (Is_Entity_Name
(L
)
10023 and then Is_Entity_Name
(R
)
10024 and then Entity
(L
) = Entity
(R
)
10025 and then Ekind
(Entity
(L
)) = E_In_Parameter
10026 and then Inside_Init_Proc
);
10029 -- Start of processing for Selected_Length_Checks
10032 -- Checks will be applied only when generating code
10034 if not Expander_Active
then
10038 if Target_Typ
= Any_Type
10039 or else Target_Typ
= Any_Composite
10040 or else Raises_Constraint_Error
(Expr
)
10049 T_Typ
:= Target_Typ
;
10051 if No
(Source_Typ
) then
10052 S_Typ
:= Etype
(Expr
);
10054 S_Typ
:= Source_Typ
;
10057 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
10061 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
10062 S_Typ
:= Designated_Type
(S_Typ
);
10063 T_Typ
:= Designated_Type
(T_Typ
);
10066 -- A simple optimization for the null case
10068 if Known_Null
(Expr
) then
10073 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
10074 if Is_Constrained
(T_Typ
) then
10076 -- The checking code to be generated will freeze the corresponding
10077 -- array type. However, we must freeze the type now, so that the
10078 -- freeze node does not appear within the generated if expression,
10079 -- but ahead of it.
10081 Freeze_Before
(Expr
, T_Typ
);
10083 Expr_Actual
:= Get_Referenced_Object
(Expr
);
10084 Exptyp
:= Get_Actual_Subtype
(Expr
);
10086 if Is_Access_Type
(Exptyp
) then
10087 Exptyp
:= Designated_Type
(Exptyp
);
10090 -- String_Literal case. This needs to be handled specially be-
10091 -- cause no index types are available for string literals. The
10092 -- condition is simply:
10094 -- T_Typ'Length = string-literal-length
10096 if Nkind
(Expr_Actual
) = N_String_Literal
10097 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
10101 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
10103 Make_Integer_Literal
(Loc
,
10105 String_Literal_Length
(Etype
(Expr_Actual
))));
10107 -- General array case. Here we have a usable actual subtype for
10108 -- the expression, and the condition is built from the two types
10111 -- T_Typ'Length /= Exptyp'Length or else
10112 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
10113 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
10116 elsif Is_Constrained
(Exptyp
) then
10118 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
10122 L_Bounds
: Range_Nodes
;
10123 R_Bounds
: Range_Nodes
;
10126 Ref_Node
: Node_Id
;
10129 -- At the library level, we need to ensure that the type of
10130 -- the object is elaborated before the check itself is
10131 -- emitted. This is only done if the object is in the
10132 -- current compilation unit, otherwise the type is frozen
10133 -- and elaborated in its unit.
10135 if Is_Itype
(Exptyp
)
10137 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
10139 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
10140 and then In_Open_Scopes
(Scope
(Exptyp
))
10142 Ref_Node
:= Make_Itype_Reference
(Sloc
(Expr
));
10143 Set_Itype
(Ref_Node
, Exptyp
);
10144 Insert_Action
(Expr
, Ref_Node
);
10147 L_Index
:= First_Index
(T_Typ
);
10148 R_Index
:= First_Index
(Exptyp
);
10150 for Indx
in 1 .. Ndims
loop
10151 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
10153 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
10155 L_Bounds
:= Get_Index_Bounds
(L_Index
);
10156 R_Bounds
:= Get_Index_Bounds
(R_Index
);
10158 -- Deal with compile time length check. Note that we
10159 -- skip this in the access case, because the access
10160 -- value may be null, so we cannot know statically.
10163 and then Compile_Time_Known_Value
(L_Bounds
.First
)
10164 and then Compile_Time_Known_Value
(L_Bounds
.Last
)
10165 and then Compile_Time_Known_Value
(R_Bounds
.First
)
10166 and then Compile_Time_Known_Value
(R_Bounds
.Last
)
10168 if Expr_Value
(L_Bounds
.Last
) >=
10169 Expr_Value
(L_Bounds
.First
)
10171 L_Length
:= Expr_Value
(L_Bounds
.Last
) -
10172 Expr_Value
(L_Bounds
.First
) + 1;
10174 L_Length
:= UI_From_Int
(0);
10177 if Expr_Value
(R_Bounds
.Last
) >=
10178 Expr_Value
(R_Bounds
.First
)
10180 R_Length
:= Expr_Value
(R_Bounds
.Last
) -
10181 Expr_Value
(R_Bounds
.First
) + 1;
10183 R_Length
:= UI_From_Int
(0);
10186 if L_Length
> R_Length
then
10188 (Compile_Time_Constraint_Error
10189 (Wnode
, "too few elements for}!!??", T_Typ
,
10190 Extra_Msg
=> Length_Mismatch_Info_Message
10191 (L_Length
, R_Length
)));
10193 elsif L_Length
< R_Length
then
10195 (Compile_Time_Constraint_Error
10196 (Wnode
, "too many elements for}!!??", T_Typ
,
10197 Extra_Msg
=> Length_Mismatch_Info_Message
10198 (L_Length
, R_Length
)));
10201 -- The comparison for an individual index subtype
10202 -- is omitted if the corresponding index subtypes
10203 -- statically match, since the result is known to
10204 -- be true. Note that this test is worth while even
10205 -- though we do static evaluation, because non-static
10206 -- subtypes can statically match.
10209 Subtypes_Statically_Match
10210 (Etype
(L_Index
), Etype
(R_Index
))
10213 (Same_Bounds
(L_Bounds
.First
, R_Bounds
.First
)
10215 Same_Bounds
(L_Bounds
.Last
, R_Bounds
.Last
))
10218 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
10227 -- Handle cases where we do not get a usable actual subtype that
10228 -- is constrained. This happens for example in the function call
10229 -- and explicit dereference cases. In these cases, we have to get
10230 -- the length or range from the expression itself, making sure we
10231 -- do not evaluate it more than once.
10233 -- Here Expr is the original expression, or more properly the
10234 -- result of applying Duplicate_Expr to the original tree, forcing
10235 -- the result to be a name.
10239 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
10242 -- Build the condition for the explicit dereference case
10244 for Indx
in 1 .. Ndims
loop
10246 (Cond
, Length_N_Cond
(Expr
, T_Typ
, Indx
));
10253 -- Construct the test and insert into the tree
10255 if Present
(Cond
) then
10257 Cond
:= Guard_Access
(Cond
, Loc
, Expr
);
10261 (Make_Raise_Constraint_Error
(Loc
,
10263 Reason
=> CE_Length_Check_Failed
));
10267 end Selected_Length_Checks
;
10269 ---------------------------
10270 -- Selected_Range_Checks --
10271 ---------------------------
10273 function Selected_Range_Checks
10275 Target_Typ
: Entity_Id
;
10276 Source_Typ
: Entity_Id
;
10277 Warn_Node
: Node_Id
) return Check_Result
10279 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
10282 Expr_Actual
: Node_Id
;
10283 Exptyp
: Entity_Id
;
10284 Cond
: Node_Id
:= Empty
;
10285 Do_Access
: Boolean := False;
10286 Wnode
: Node_Id
:= Warn_Node
;
10287 Ret_Result
: Check_Result
:= (Empty
, Empty
);
10288 Num_Checks
: Natural := 0;
10290 procedure Add_Check
(N
: Node_Id
);
10291 -- Adds the action given to Ret_Result if N is non-Empty
10293 function Discrete_Range_Cond
10295 Typ
: Entity_Id
) return Node_Id
;
10296 -- Returns expression to compute:
10297 -- Low_Bound (Exp) < Typ'First
10299 -- High_Bound (Exp) > Typ'Last
10301 function Discrete_Expr_Cond
10303 Typ
: Entity_Id
) return Node_Id
;
10304 -- Returns expression to compute:
10309 function Get_E_First_Or_Last
10313 Nam
: Name_Id
) return Node_Id
;
10314 -- Returns an attribute reference
10315 -- E'First or E'Last
10316 -- with a source location of Loc.
10318 -- Nam is Name_First or Name_Last, according to which attribute is
10319 -- desired. If Indx is non-zero, it is passed as a literal in the
10320 -- Expressions of the attribute reference (identifying the desired
10321 -- array dimension).
10323 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
10324 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
10325 -- Returns expression to compute:
10326 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
10328 function Is_Cond_Expr_Ge
(N
: Node_Id
; V
: Node_Id
) return Boolean;
10329 function Is_Cond_Expr_Le
(N
: Node_Id
; V
: Node_Id
) return Boolean;
10330 -- Return True if N is a conditional expression whose dependent
10331 -- expressions are all known and greater/lower than or equal to V.
10333 function Range_E_Cond
10334 (Exptyp
: Entity_Id
;
10338 -- Returns expression to compute:
10339 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
10341 function Range_Equal_E_Cond
10342 (Exptyp
: Entity_Id
;
10344 Indx
: Nat
) return Node_Id
;
10345 -- Returns expression to compute:
10346 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
10348 function Range_N_Cond
10351 Indx
: Nat
) return Node_Id
;
10352 -- Return expression to compute:
10353 -- Exp'First < Typ'First or else Exp'Last > Typ'Last
10355 function "<" (Left
, Right
: Node_Id
) return Boolean
10356 is (if Is_Floating_Point_Type
(S_Typ
)
10357 then Expr_Value_R
(Left
) < Expr_Value_R
(Right
)
10358 else Expr_Value
(Left
) < Expr_Value
(Right
));
10359 function "<=" (Left
, Right
: Node_Id
) return Boolean
10360 is (if Is_Floating_Point_Type
(S_Typ
)
10361 then Expr_Value_R
(Left
) <= Expr_Value_R
(Right
)
10362 else Expr_Value
(Left
) <= Expr_Value
(Right
));
10363 -- Convenience comparison functions of integer or floating point values
10369 procedure Add_Check
(N
: Node_Id
) is
10371 if Present
(N
) then
10373 -- We do not support inserting more than 2 checks on the same
10374 -- node. If this happens it means we have already added an
10375 -- unconditional raise, so we can skip the other checks safely
10376 -- since N will always raise an exception.
10378 if Num_Checks
= 2 then
10382 pragma Assert
(Num_Checks
<= 1);
10383 Num_Checks
:= Num_Checks
+ 1;
10384 Ret_Result
(Num_Checks
) := N
;
10388 -------------------------
10389 -- Discrete_Expr_Cond --
10390 -------------------------
10392 function Discrete_Expr_Cond
10394 Typ
: Entity_Id
) return Node_Id
10402 Convert_To
(Base_Type
(Typ
),
10403 Duplicate_Subexpr_No_Checks
(Exp
)),
10405 Convert_To
(Base_Type
(Typ
),
10406 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
10411 Convert_To
(Base_Type
(Typ
),
10412 Duplicate_Subexpr_No_Checks
(Exp
)),
10416 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
10417 end Discrete_Expr_Cond
;
10419 -------------------------
10420 -- Discrete_Range_Cond --
10421 -------------------------
10423 function Discrete_Range_Cond
10425 Typ
: Entity_Id
) return Node_Id
10427 LB
: Node_Id
:= Low_Bound
(Exp
);
10428 HB
: Node_Id
:= High_Bound
(Exp
);
10430 Left_Opnd
: Node_Id
;
10431 Right_Opnd
: Node_Id
;
10434 if Nkind
(LB
) = N_Identifier
10435 and then Ekind
(Entity
(LB
)) = E_Discriminant
10437 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10440 -- If the index type has a fixed lower bound, then we require an
10441 -- exact match of the range's lower bound against that fixed lower
10444 if Is_Fixed_Lower_Bound_Index_Subtype
(Typ
) then
10449 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
10454 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
10456 -- Otherwise we do the expected less-than comparison
10463 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
10468 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
10471 if Nkind
(HB
) = N_Identifier
10472 and then Ekind
(Entity
(HB
)) = E_Discriminant
10474 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10481 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
10486 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
10488 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
10489 end Discrete_Range_Cond
;
10491 -------------------------
10492 -- Get_E_First_Or_Last --
10493 -------------------------
10495 function Get_E_First_Or_Last
10499 Nam
: Name_Id
) return Node_Id
10504 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
10509 return Make_Attribute_Reference
(Loc
,
10510 Prefix
=> New_Occurrence_Of
(E
, Loc
),
10511 Attribute_Name
=> Nam
,
10512 Expressions
=> Exprs
);
10513 end Get_E_First_Or_Last
;
10519 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10522 Make_Attribute_Reference
(Loc
,
10523 Attribute_Name
=> Name_First
,
10525 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10526 Expressions
=> New_List
(
10527 Make_Integer_Literal
(Loc
, Indx
)));
10534 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10537 Make_Attribute_Reference
(Loc
,
10538 Attribute_Name
=> Name_Last
,
10540 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10541 Expressions
=> New_List
(
10542 Make_Integer_Literal
(Loc
, Indx
)));
10545 ---------------------
10546 -- Is_Cond_Expr_Ge --
10547 ---------------------
10549 function Is_Cond_Expr_Ge
(N
: Node_Id
; V
: Node_Id
) return Boolean is
10551 -- Only if expressions are relevant for the time being
10553 if Nkind
(N
) = N_If_Expression
then
10555 Cond
: constant Node_Id
:= First
(Expressions
(N
));
10556 Thenx
: constant Node_Id
:= Next
(Cond
);
10557 Elsex
: constant Node_Id
:= Next
(Thenx
);
10560 return Compile_Time_Known_Value
(Thenx
)
10561 and then V
<= Thenx
10563 ((Compile_Time_Known_Value
(Elsex
) and then V
<= Elsex
)
10564 or else Is_Cond_Expr_Ge
(Elsex
, V
));
10570 end Is_Cond_Expr_Ge
;
10572 ---------------------
10573 -- Is_Cond_Expr_Le --
10574 ---------------------
10576 function Is_Cond_Expr_Le
(N
: Node_Id
; V
: Node_Id
) return Boolean is
10578 -- Only if expressions are relevant for the time being
10580 if Nkind
(N
) = N_If_Expression
then
10582 Cond
: constant Node_Id
:= First
(Expressions
(N
));
10583 Thenx
: constant Node_Id
:= Next
(Cond
);
10584 Elsex
: constant Node_Id
:= Next
(Thenx
);
10587 return Compile_Time_Known_Value
(Thenx
)
10588 and then Thenx
<= V
10590 ((Compile_Time_Known_Value
(Elsex
) and then Elsex
<= V
)
10591 or else Is_Cond_Expr_Le
(Elsex
, V
));
10597 end Is_Cond_Expr_Le
;
10603 function Range_E_Cond
10604 (Exptyp
: Entity_Id
;
10606 Indx
: Nat
) return Node_Id
10614 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10616 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10621 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10623 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10626 ------------------------
10627 -- Range_Equal_E_Cond --
10628 ------------------------
10630 function Range_Equal_E_Cond
10631 (Exptyp
: Entity_Id
;
10633 Indx
: Nat
) return Node_Id
10641 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10643 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10648 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10650 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10651 end Range_Equal_E_Cond
;
10657 function Range_N_Cond
10660 Indx
: Nat
) return Node_Id
10668 Get_N_First
(Exp
, Indx
),
10670 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10675 Get_N_Last
(Exp
, Indx
),
10677 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10680 -- Start of processing for Selected_Range_Checks
10683 -- Checks will be applied only when generating code. In GNATprove mode,
10684 -- we do not apply the checks, but we still call Selected_Range_Checks
10685 -- outside of generics to possibly issue errors on SPARK code when a
10686 -- run-time error can be detected at compile time.
10688 if Inside_A_Generic
or (not GNATprove_Mode
and not Expander_Active
) then
10692 if Target_Typ
= Any_Type
10693 or else Target_Typ
= Any_Composite
10694 or else Raises_Constraint_Error
(Expr
)
10703 T_Typ
:= Target_Typ
;
10705 if No
(Source_Typ
) then
10706 S_Typ
:= Etype
(Expr
);
10708 S_Typ
:= Source_Typ
;
10711 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
10715 -- The order of evaluating T_Typ before S_Typ seems to be critical
10716 -- because S_Typ can be derived from Etype (Expr), if it's not passed
10717 -- in, and since Node can be an N_Range node, it might be invalid.
10718 -- Should there be an assert check somewhere for taking the Etype of
10719 -- an N_Range node ???
10721 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
10722 S_Typ
:= Designated_Type
(S_Typ
);
10723 T_Typ
:= Designated_Type
(T_Typ
);
10726 -- A simple optimization for the null case
10728 if Known_Null
(Expr
) then
10733 -- For an N_Range Node, check for a null range and then if not
10734 -- null generate a range check action.
10736 if Nkind
(Expr
) = N_Range
then
10738 -- There's no point in checking a range against itself
10740 if Expr
= Scalar_Range
(T_Typ
) then
10745 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
10746 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
10747 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
10748 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
10750 LB
: Node_Id
:= Low_Bound
(Expr
);
10751 HB
: Node_Id
:= High_Bound
(Expr
);
10752 Known_LB
: Boolean := False;
10753 Known_HB
: Boolean := False;
10754 Check_Added
: Boolean := False;
10756 Out_Of_Range_L
: Boolean := False;
10757 Out_Of_Range_H
: Boolean := False;
10760 -- Compute what is known at compile time
10762 if Known_T_LB
and Known_T_HB
then
10763 if Compile_Time_Known_Value
(LB
) then
10766 -- There's no point in checking that a bound is within its
10767 -- own range so pretend that it is known in this case. First
10768 -- deal with low bound.
10770 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
10771 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
10776 -- Similarly; deal with the case where the low bound is a
10777 -- conditional expression whose result is greater than or
10778 -- equal to the target low bound.
10780 elsif Is_Cond_Expr_Ge
(LB
, T_LB
) then
10785 -- Likewise for the high bound
10787 if Compile_Time_Known_Value
(HB
) then
10790 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
10791 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
10796 elsif Is_Cond_Expr_Le
(HB
, T_HB
) then
10802 -- Check for the simple cases where we can do the check at
10803 -- compile time. This is skipped if we have an access type, since
10804 -- the access value may be null.
10806 if not Do_Access
and then Not_Null_Range
(LB
, HB
) then
10809 Out_Of_Range_L
:= LB
< T_LB
;
10812 if Known_T_HB
and not Out_Of_Range_L
then
10813 Out_Of_Range_L
:= T_HB
< LB
;
10816 if Out_Of_Range_L
then
10817 if No
(Warn_Node
) then
10819 (Compile_Time_Constraint_Error
10821 "static value out of range of}??", T_Typ
));
10822 Check_Added
:= True;
10826 (Compile_Time_Constraint_Error
10828 "static range out of bounds of}??", T_Typ
));
10829 Check_Added
:= True;
10834 -- Flag the case of a fixed-lower-bound index where the static
10835 -- bounds are not equal.
10838 and then Is_Fixed_Lower_Bound_Index_Subtype
(T_Typ
)
10840 and then Known_T_LB
10841 and then Expr_Value
(LB
) /= Expr_Value
(T_LB
)
10844 (Compile_Time_Constraint_Error
10845 ((if Present
(Warn_Node
)
10846 then Warn_Node
else Low_Bound
(Expr
)),
10847 "static value does not equal lower bound of}??",
10849 Check_Added
:= True;
10854 Out_Of_Range_H
:= T_HB
< HB
;
10857 if Known_T_LB
and not Out_Of_Range_H
then
10858 Out_Of_Range_H
:= HB
< T_LB
;
10861 if Out_Of_Range_H
then
10862 if No
(Warn_Node
) then
10864 (Compile_Time_Constraint_Error
10865 (High_Bound
(Expr
),
10866 "static value out of range of}??", T_Typ
));
10867 Check_Added
:= True;
10871 (Compile_Time_Constraint_Error
10873 "static range out of bounds of}??", T_Typ
));
10874 Check_Added
:= True;
10880 -- Check for the case where not everything is static
10885 or else not Known_T_LB
10886 or else not Known_LB
10887 or else not Known_T_HB
10888 or else not Known_HB
)
10891 LB
: Node_Id
:= Low_Bound
(Expr
);
10892 HB
: Node_Id
:= High_Bound
(Expr
);
10895 -- If either bound is a discriminant and we are within the
10896 -- record declaration, it is a use of the discriminant in a
10897 -- constraint of a component, and nothing can be checked
10898 -- here. The check will be emitted within the init proc.
10899 -- Before then, the discriminal has no real meaning.
10900 -- Similarly, if the entity is a discriminal, there is no
10901 -- check to perform yet.
10903 -- The same holds within a discriminated synchronized type,
10904 -- where the discriminant may constrain a component or an
10907 if Nkind
(LB
) = N_Identifier
10908 and then Denotes_Discriminant
(LB
, True)
10910 if Current_Scope
= Scope
(Entity
(LB
))
10911 or else Is_Concurrent_Type
(Current_Scope
)
10912 or else Ekind
(Entity
(LB
)) /= E_Discriminant
10917 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10921 if Nkind
(HB
) = N_Identifier
10922 and then Denotes_Discriminant
(HB
, True)
10924 if Current_Scope
= Scope
(Entity
(HB
))
10925 or else Is_Concurrent_Type
(Current_Scope
)
10926 or else Ekind
(Entity
(HB
)) /= E_Discriminant
10931 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10935 Cond
:= Discrete_Range_Cond
(Expr
, T_Typ
);
10936 Set_Paren_Count
(Cond
, 1);
10939 Make_And_Then
(Loc
,
10943 Convert_To
(Base_Type
(Etype
(HB
)),
10944 Duplicate_Subexpr_No_Checks
(HB
)),
10946 Convert_To
(Base_Type
(Etype
(LB
)),
10947 Duplicate_Subexpr_No_Checks
(LB
))),
10948 Right_Opnd
=> Cond
);
10953 elsif Is_Scalar_Type
(S_Typ
) then
10955 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
10956 -- except the above simply sets a flag in the node and lets the
10957 -- check be generated based on the Etype of the expression.
10958 -- Sometimes, however we want to do a dynamic check against an
10959 -- arbitrary target type, so we do that here.
10961 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
10962 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
10964 -- For literals, we can tell if the constraint error will be
10965 -- raised at compile time, so we never need a dynamic check, but
10966 -- if the exception will be raised, then post the usual warning,
10967 -- and replace the literal with a raise constraint error
10968 -- expression. As usual, skip this for access types
10970 elsif Compile_Time_Known_Value
(Expr
) and then not Do_Access
then
10971 if Is_Out_Of_Range
(Expr
, T_Typ
) then
10973 -- Bounds of the type are static and the literal is out of
10974 -- range so output a warning message.
10976 if No
(Warn_Node
) then
10978 (Compile_Time_Constraint_Error
10979 (Expr
, "static value out of range of}??", T_Typ
));
10983 (Compile_Time_Constraint_Error
10984 (Wnode
, "static value out of range of}??", T_Typ
));
10987 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
10990 -- Here for the case of a non-static expression, we need a runtime
10991 -- check unless the source type range is guaranteed to be in the
10992 -- range of the target type.
10995 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
10996 Cond
:= Discrete_Expr_Cond
(Expr
, T_Typ
);
11001 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
11002 if Is_Constrained
(T_Typ
) then
11003 Expr_Actual
:= Get_Referenced_Object
(Expr
);
11004 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
11006 if Is_Access_Type
(Exptyp
) then
11007 Exptyp
:= Designated_Type
(Exptyp
);
11010 -- String_Literal case. This needs to be handled specially be-
11011 -- cause no index types are available for string literals. The
11012 -- condition is simply:
11014 -- T_Typ'Length = string-literal-length
11016 if Nkind
(Expr_Actual
) = N_String_Literal
then
11019 -- General array case. Here we have a usable actual subtype for
11020 -- the expression, and the condition is built from the two types
11022 -- T_Typ'First < Exptyp'First or else
11023 -- T_Typ'Last > Exptyp'Last or else
11024 -- T_Typ'First(1) < Exptyp'First(1) or else
11025 -- T_Typ'Last(1) > Exptyp'Last(1) or else
11028 elsif Is_Constrained
(Exptyp
) then
11030 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11036 L_Index
:= First_Index
(T_Typ
);
11037 R_Index
:= First_Index
(Exptyp
);
11039 for Indx
in 1 .. Ndims
loop
11040 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
11042 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
11044 -- Deal with compile time length check. Note that we
11045 -- skip this in the access case, because the access
11046 -- value may be null, so we cannot know statically.
11049 Subtypes_Statically_Match
11050 (Etype
(L_Index
), Etype
(R_Index
))
11052 -- If the target type is constrained then we
11053 -- have to check for exact equality of bounds
11054 -- (required for qualified expressions).
11056 if Is_Constrained
(T_Typ
) then
11059 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
11062 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
11072 -- Handle cases where we do not get a usable actual subtype that
11073 -- is constrained. This happens for example in the function call
11074 -- and explicit dereference cases. In these cases, we have to get
11075 -- the length or range from the expression itself, making sure we
11076 -- do not evaluate it more than once.
11078 -- Here Expr is the original expression, or more properly the
11079 -- result of applying Duplicate_Expr to the original tree,
11080 -- forcing the result to be a name.
11084 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11087 -- Build the condition for the explicit dereference case
11089 for Indx
in 1 .. Ndims
loop
11091 (Cond
, Range_N_Cond
(Expr
, T_Typ
, Indx
));
11096 -- If the context is a qualified_expression where the subtype is
11097 -- an unconstrained array subtype with fixed-lower-bound indexes,
11098 -- then consistency checks must be done between the lower bounds
11099 -- of any such indexes and the corresponding lower bounds of the
11100 -- qualified array object.
11102 elsif Is_Fixed_Lower_Bound_Array_Subtype
(T_Typ
)
11103 and then Nkind
(Parent
(Expr
)) = N_Qualified_Expression
11104 and then not Do_Access
11107 Ndims
: constant Pos
:= Number_Dimensions
(T_Typ
);
11109 Qual_Index
: Node_Id
;
11110 Expr_Index
: Node_Id
;
11113 Expr_Actual
:= Get_Referenced_Object
(Expr
);
11114 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
11116 Qual_Index
:= First_Index
(T_Typ
);
11117 Expr_Index
:= First_Index
(Exptyp
);
11119 for Indx
in 1 .. Ndims
loop
11120 if Nkind
(Expr_Index
) /= N_Raise_Constraint_Error
then
11122 -- If this index of the qualifying array subtype has
11123 -- a fixed lower bound, then apply a check that the
11124 -- corresponding lower bound of the array expression
11127 if Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Qual_Index
))
11133 Get_E_First_Or_Last
11134 (Loc
, Exptyp
, Indx
, Name_First
),
11137 (Type_Low_Bound
(Etype
(Qual_Index
)))));
11147 -- For a conversion to an unconstrained array type, generate an
11148 -- Action to check that the bounds of the source value are within
11149 -- the constraints imposed by the target type (RM 4.6(38)). No
11150 -- check is needed for a conversion to an access to unconstrained
11151 -- array type, as 4.6(24.15/2) requires the designated subtypes
11152 -- of the two access types to statically match.
11154 if Nkind
(Parent
(Expr
)) = N_Type_Conversion
11155 and then not Do_Access
11158 Opnd_Index
: Node_Id
;
11159 Targ_Index
: Node_Id
;
11160 Opnd_Range
: Node_Id
;
11163 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Expr
));
11164 Targ_Index
:= First_Index
(T_Typ
);
11165 while Present
(Opnd_Index
) loop
11167 -- If the index is a range, use its bounds. If it is an
11168 -- entity (as will be the case if it is a named subtype
11169 -- or an itype created for a slice) retrieve its range.
11171 if Is_Entity_Name
(Opnd_Index
)
11172 and then Is_Type
(Entity
(Opnd_Index
))
11174 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
11176 Opnd_Range
:= Opnd_Index
;
11179 if Nkind
(Opnd_Range
) = N_Range
then
11181 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11182 Assume_Valid
=> True)
11185 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11186 Assume_Valid
=> True)
11190 -- If null range, no check needed
11193 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
11195 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
11197 Expr_Value
(High_Bound
(Opnd_Range
)) <
11198 Expr_Value
(Low_Bound
(Opnd_Range
))
11202 elsif Is_Out_Of_Range
11203 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11204 Assume_Valid
=> True)
11207 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
11208 Assume_Valid
=> True)
11211 (Compile_Time_Constraint_Error
11212 (Wnode
, "value out of range of}??", T_Typ
));
11217 Discrete_Range_Cond
11218 (Opnd_Range
, Etype
(Targ_Index
)));
11222 Next_Index
(Opnd_Index
);
11223 Next_Index
(Targ_Index
);
11230 -- Construct the test and insert into the tree
11232 if Present
(Cond
) then
11234 Cond
:= Guard_Access
(Cond
, Loc
, Expr
);
11238 (Make_Raise_Constraint_Error
(Loc
,
11240 Reason
=> CE_Range_Check_Failed
));
11244 end Selected_Range_Checks
;
11246 -------------------------------
11247 -- Storage_Checks_Suppressed --
11248 -------------------------------
11250 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
11252 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
11253 return Is_Check_Suppressed
(E
, Storage_Check
);
11255 return Scope_Suppress
.Suppress
(Storage_Check
);
11257 end Storage_Checks_Suppressed
;
11259 ---------------------------
11260 -- Tag_Checks_Suppressed --
11261 ---------------------------
11263 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
11266 and then Checks_May_Be_Suppressed
(E
)
11268 return Is_Check_Suppressed
(E
, Tag_Check
);
11270 return Scope_Suppress
.Suppress
(Tag_Check
);
11272 end Tag_Checks_Suppressed
;
11274 ---------------------------------------
11275 -- Validate_Alignment_Check_Warnings --
11276 ---------------------------------------
11278 procedure Validate_Alignment_Check_Warnings
is
11280 for J
in Alignment_Warnings
.First
.. Alignment_Warnings
.Last
loop
11282 AWR
: Alignment_Warnings_Record
11283 renames Alignment_Warnings
.Table
(J
);
11285 if Known_Alignment
(AWR
.E
)
11286 and then ((Present
(AWR
.A
)
11287 and then AWR
.A
mod Alignment
(AWR
.E
) = 0)
11288 or else (Present
(AWR
.P
)
11289 and then Has_Compatible_Alignment
11290 (AWR
.E
, AWR
.P
, True) =
11293 Delete_Warning_And_Continuations
(AWR
.W
);
11297 end Validate_Alignment_Check_Warnings
;
11299 --------------------------
11300 -- Validity_Check_Range --
11301 --------------------------
11303 procedure Validity_Check_Range
11305 Related_Id
: Entity_Id
:= Empty
) is
11307 if Validity_Checks_On
and Validity_Check_Operands
then
11308 if Nkind
(N
) = N_Range
then
11310 (Expr
=> Low_Bound
(N
),
11311 Related_Id
=> Related_Id
,
11312 Is_Low_Bound
=> True);
11315 (Expr
=> High_Bound
(N
),
11316 Related_Id
=> Related_Id
,
11317 Is_High_Bound
=> True);
11320 end Validity_Check_Range
;