1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Errout
; use Errout
;
30 with Exp_Ch2
; use Exp_Ch2
;
31 with Exp_Ch11
; use Exp_Ch11
;
32 with Exp_Pakd
; use Exp_Pakd
;
33 with Exp_Util
; use Exp_Util
;
34 with Elists
; use Elists
;
35 with Eval_Fat
; use Eval_Fat
;
36 with Freeze
; use Freeze
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Output
; use Output
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Eval
; use Sem_Eval
;
47 with Sem_Ch3
; use Sem_Ch3
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Res
; use Sem_Res
;
50 with Sem_Util
; use Sem_Util
;
51 with Sem_Warn
; use Sem_Warn
;
52 with Sinfo
; use Sinfo
;
53 with Sinput
; use Sinput
;
54 with Snames
; use Snames
;
55 with Sprint
; use Sprint
;
56 with Stand
; use Stand
;
57 with Targparm
; use Targparm
;
58 with Tbuild
; use Tbuild
;
59 with Ttypes
; use Ttypes
;
60 with Urealp
; use Urealp
;
61 with Validsw
; use Validsw
;
63 package body Checks
is
65 -- General note: many of these routines are concerned with generating
66 -- checking code to make sure that constraint error is raised at runtime.
67 -- Clearly this code is only needed if the expander is active, since
68 -- otherwise we will not be generating code or going into the runtime
71 -- We therefore disconnect most of these checks if the expander is
72 -- inactive. This has the additional benefit that we do not need to
73 -- worry about the tree being messed up by previous errors (since errors
74 -- turn off expansion anyway).
76 -- There are a few exceptions to the above rule. For instance routines
77 -- such as Apply_Scalar_Range_Check that do not insert any code can be
78 -- safely called even when the Expander is inactive (but Errors_Detected
79 -- is 0). The benefit of executing this code when expansion is off, is
80 -- the ability to emit constraint error warning for static expressions
81 -- even when we are not generating code.
83 -------------------------------------
84 -- Suppression of Redundant Checks --
85 -------------------------------------
87 -- This unit implements a limited circuit for removal of redundant
88 -- checks. The processing is based on a tracing of simple sequential
89 -- flow. For any sequence of statements, we save expressions that are
90 -- marked to be checked, and then if the same expression appears later
91 -- with the same check, then under certain circumstances, the second
92 -- check can be suppressed.
94 -- Basically, we can suppress the check if we know for certain that
95 -- the previous expression has been elaborated (together with its
96 -- check), and we know that the exception frame is the same, and that
97 -- nothing has happened to change the result of the exception.
99 -- Let us examine each of these three conditions in turn to describe
100 -- how we ensure that this condition is met.
102 -- First, we need to know for certain that the previous expression has
103 -- been executed. This is done principly by the mechanism of calling
104 -- Conditional_Statements_Begin at the start of any statement sequence
105 -- and Conditional_Statements_End at the end. The End call causes all
106 -- checks remembered since the Begin call to be discarded. This does
107 -- miss a few cases, notably the case of a nested BEGIN-END block with
108 -- no exception handlers. But the important thing is to be conservative.
109 -- The other protection is that all checks are discarded if a label
110 -- is encountered, since then the assumption of sequential execution
111 -- is violated, and we don't know enough about the flow.
113 -- Second, we need to know that the exception frame is the same. We
114 -- do this by killing all remembered checks when we enter a new frame.
115 -- Again, that's over-conservative, but generally the cases we can help
116 -- with are pretty local anyway (like the body of a loop for example).
118 -- Third, we must be sure to forget any checks which are no longer valid.
119 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
120 -- used to note any changes to local variables. We only attempt to deal
121 -- with checks involving local variables, so we do not need to worry
122 -- about global variables. Second, a call to any non-global procedure
123 -- causes us to abandon all stored checks, since such a all may affect
124 -- the values of any local variables.
126 -- The following define the data structures used to deal with remembering
127 -- checks so that redundant checks can be eliminated as described above.
129 -- Right now, the only expressions that we deal with are of the form of
130 -- simple local objects (either declared locally, or IN parameters) or
131 -- such objects plus/minus a compile time known constant. We can do
132 -- more later on if it seems worthwhile, but this catches many simple
133 -- cases in practice.
135 -- The following record type reflects a single saved check. An entry
136 -- is made in the stack of saved checks if and only if the expression
137 -- has been elaborated with the indicated checks.
139 type Saved_Check
is record
141 -- Set True if entry is killed by Kill_Checks
144 -- The entity involved in the expression that is checked
147 -- A compile time value indicating the result of adding or
148 -- subtracting a compile time value. This value is to be
149 -- added to the value of the Entity. A value of zero is
150 -- used for the case of a simple entity reference.
152 Check_Type
: Character;
153 -- This is set to 'R' for a range check (in which case Target_Type
154 -- is set to the target type for the range check) or to 'O' for an
155 -- overflow check (in which case Target_Type is set to Empty).
157 Target_Type
: Entity_Id
;
158 -- Used only if Do_Range_Check is set. Records the target type for
159 -- the check. We need this, because a check is a duplicate only if
160 -- it has a the same target type (or more accurately one with a
161 -- range that is smaller or equal to the stored target type of a
165 -- The following table keeps track of saved checks. Rather than use an
166 -- extensible table. We just use a table of fixed size, and we discard
167 -- any saved checks that do not fit. That's very unlikely to happen and
168 -- this is only an optimization in any case.
170 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
171 -- Array of saved checks
173 Num_Saved_Checks
: Nat
:= 0;
174 -- Number of saved checks
176 -- The following stack keeps track of statement ranges. It is treated
177 -- as a stack. When Conditional_Statements_Begin is called, an entry
178 -- is pushed onto this stack containing the value of Num_Saved_Checks
179 -- at the time of the call. Then when Conditional_Statements_End is
180 -- called, this value is popped off and used to reset Num_Saved_Checks.
182 -- Note: again, this is a fixed length stack with a size that should
183 -- always be fine. If the value of the stack pointer goes above the
184 -- limit, then we just forget all saved checks.
186 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
187 Saved_Checks_TOS
: Nat
:= 0;
189 -----------------------
190 -- Local Subprograms --
191 -----------------------
193 procedure Apply_Float_Conversion_Check
195 Target_Typ
: Entity_Id
);
196 -- The checks on a conversion from a floating-point type to an integer
197 -- type are delicate. They have to be performed before conversion, they
198 -- have to raise an exception when the operand is a NaN, and rounding must
199 -- be taken into account to determine the safe bounds of the operand.
201 procedure Apply_Selected_Length_Checks
203 Target_Typ
: Entity_Id
;
204 Source_Typ
: Entity_Id
;
205 Do_Static
: Boolean);
206 -- This is the subprogram that does all the work for Apply_Length_Check
207 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
208 -- described for the above routines. The Do_Static flag indicates that
209 -- only a static check is to be done.
211 procedure Apply_Selected_Range_Checks
213 Target_Typ
: Entity_Id
;
214 Source_Typ
: Entity_Id
;
215 Do_Static
: Boolean);
216 -- This is the subprogram that does all the work for Apply_Range_Check.
217 -- Expr, Target_Typ and Source_Typ are as described for the above
218 -- routine. The Do_Static flag indicates that only a static check is
221 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
222 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
223 -- This function is used to see if an access or division by zero check is
224 -- needed. The check is to be applied to a single variable appearing in the
225 -- source, and N is the node for the reference. If N is not of this form,
226 -- True is returned with no further processing. If N is of the right form,
227 -- then further processing determines if the given Check is needed.
229 -- The particular circuit is to see if we have the case of a check that is
230 -- not needed because it appears in the right operand of a short circuited
231 -- conditional where the left operand guards the check. For example:
233 -- if Var = 0 or else Q / Var > 12 then
237 -- In this example, the division check is not required. At the same time
238 -- we can issue warnings for suspicious use of non-short-circuited forms,
241 -- if Var = 0 or Q / Var > 12 then
247 Check_Type
: Character;
248 Target_Type
: Entity_Id
;
249 Entry_OK
: out Boolean;
253 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
254 -- to see if a check is of the form for optimization, and if so, to see
255 -- if it has already been performed. Expr is the expression to check,
256 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
257 -- Target_Type is the target type for a range check, and Empty for an
258 -- overflow check. If the entry is not of the form for optimization,
259 -- then Entry_OK is set to False, and the remaining out parameters
260 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
261 -- entity and offset from the expression. Check_Num is the number of
262 -- a matching saved entry in Saved_Checks, or zero if no such entry
265 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
266 -- If a discriminal is used in constraining a prival, Return reference
267 -- to the discriminal of the protected body (which renames the parameter
268 -- of the enclosing protected operation). This clumsy transformation is
269 -- needed because privals are created too late and their actual subtypes
270 -- are not available when analysing the bodies of the protected operations.
271 -- This function is called whenever the bound is an entity and the scope
272 -- indicates a protected operation. If the bound is an in-parameter of
273 -- a protected operation that is not a prival, the function returns the
275 -- To be cleaned up???
277 function Guard_Access
280 Ck_Node
: Node_Id
) return Node_Id
;
281 -- In the access type case, guard the test with a test to ensure
282 -- that the access value is non-null, since the checks do not
283 -- not apply to null access values.
285 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
286 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
287 -- Constraint_Error node.
289 function Range_Or_Validity_Checks_Suppressed
290 (Expr
: Node_Id
) return Boolean;
291 -- Returns True if either range or validity checks or both are suppressed
292 -- for the type of the given expression, or, if the expression is the name
293 -- of an entity, if these checks are suppressed for the entity.
295 function Selected_Length_Checks
297 Target_Typ
: Entity_Id
;
298 Source_Typ
: Entity_Id
;
299 Warn_Node
: Node_Id
) return Check_Result
;
300 -- Like Apply_Selected_Length_Checks, except it doesn't modify
301 -- anything, just returns a list of nodes as described in the spec of
302 -- this package for the Range_Check function.
304 function Selected_Range_Checks
306 Target_Typ
: Entity_Id
;
307 Source_Typ
: Entity_Id
;
308 Warn_Node
: Node_Id
) return Check_Result
;
309 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
310 -- just returns a list of nodes as described in the spec of this package
311 -- for the Range_Check function.
313 ------------------------------
314 -- Access_Checks_Suppressed --
315 ------------------------------
317 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
319 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
320 return Is_Check_Suppressed
(E
, Access_Check
);
322 return Scope_Suppress
(Access_Check
);
324 end Access_Checks_Suppressed
;
326 -------------------------------------
327 -- Accessibility_Checks_Suppressed --
328 -------------------------------------
330 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
332 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
333 return Is_Check_Suppressed
(E
, Accessibility_Check
);
335 return Scope_Suppress
(Accessibility_Check
);
337 end Accessibility_Checks_Suppressed
;
339 -----------------------------
340 -- Activate_Division_Check --
341 -----------------------------
343 procedure Activate_Division_Check
(N
: Node_Id
) is
345 Set_Do_Division_Check
(N
, True);
346 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
347 end Activate_Division_Check
;
349 -----------------------------
350 -- Activate_Overflow_Check --
351 -----------------------------
353 procedure Activate_Overflow_Check
(N
: Node_Id
) is
355 Set_Do_Overflow_Check
(N
, True);
356 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
357 end Activate_Overflow_Check
;
359 --------------------------
360 -- Activate_Range_Check --
361 --------------------------
363 procedure Activate_Range_Check
(N
: Node_Id
) is
365 Set_Do_Range_Check
(N
, True);
366 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
367 end Activate_Range_Check
;
369 ---------------------------------
370 -- Alignment_Checks_Suppressed --
371 ---------------------------------
373 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
375 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
376 return Is_Check_Suppressed
(E
, Alignment_Check
);
378 return Scope_Suppress
(Alignment_Check
);
380 end Alignment_Checks_Suppressed
;
382 -------------------------
383 -- Append_Range_Checks --
384 -------------------------
386 procedure Append_Range_Checks
387 (Checks
: Check_Result
;
389 Suppress_Typ
: Entity_Id
;
390 Static_Sloc
: Source_Ptr
;
393 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
394 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
396 Checks_On
: constant Boolean :=
397 (not Index_Checks_Suppressed
(Suppress_Typ
))
399 (not Range_Checks_Suppressed
(Suppress_Typ
));
402 -- For now we just return if Checks_On is false, however this should
403 -- be enhanced to check for an always True value in the condition
404 -- and to generate a compilation warning???
406 if not Checks_On
then
411 exit when No
(Checks
(J
));
413 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
414 and then Present
(Condition
(Checks
(J
)))
416 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
417 Append_To
(Stmts
, Checks
(J
));
418 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
424 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
425 Reason
=> CE_Range_Check_Failed
));
428 end Append_Range_Checks
;
430 ------------------------
431 -- Apply_Access_Check --
432 ------------------------
434 procedure Apply_Access_Check
(N
: Node_Id
) is
435 P
: constant Node_Id
:= Prefix
(N
);
438 -- We do not need checks if we are not generating code (i.e. the
439 -- expander is not active). This is not just an optimization, there
440 -- are cases (e.g. with pragma Debug) where generating the checks
441 -- can cause real trouble).
443 if not Expander_Active
then
447 -- No check if short circuiting makes check unnecessary
449 if not Check_Needed
(P
, Access_Check
) then
453 -- No check if accessing the Offset_To_Top component of a dispatch
454 -- table. They are safe by construction.
456 if Present
(Etype
(P
))
457 and then RTU_Loaded
(Ada_Tags
)
458 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
459 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
464 -- Otherwise go ahead and install the check
466 Install_Null_Excluding_Check
(P
);
467 end Apply_Access_Check
;
469 -------------------------------
470 -- Apply_Accessibility_Check --
471 -------------------------------
473 procedure Apply_Accessibility_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
474 Loc
: constant Source_Ptr
:= Sloc
(N
);
475 Param_Ent
: constant Entity_Id
:= Param_Entity
(N
);
476 Param_Level
: Node_Id
;
477 Type_Level
: Node_Id
;
480 if Inside_A_Generic
then
483 -- Only apply the run-time check if the access parameter
484 -- has an associated extra access level parameter and
485 -- when the level of the type is less deep than the level
486 -- of the access parameter.
488 elsif Present
(Param_Ent
)
489 and then Present
(Extra_Accessibility
(Param_Ent
))
490 and then UI_Gt
(Object_Access_Level
(N
),
491 Type_Access_Level
(Typ
))
492 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
493 and then not Accessibility_Checks_Suppressed
(Typ
)
496 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
499 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
));
501 -- Raise Program_Error if the accessibility level of the the access
502 -- parameter is deeper than the level of the target access type.
505 Make_Raise_Program_Error
(Loc
,
508 Left_Opnd
=> Param_Level
,
509 Right_Opnd
=> Type_Level
),
510 Reason
=> PE_Accessibility_Check_Failed
));
512 Analyze_And_Resolve
(N
);
514 end Apply_Accessibility_Check
;
516 --------------------------------
517 -- Apply_Address_Clause_Check --
518 --------------------------------
520 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
521 AC
: constant Node_Id
:= Address_Clause
(E
);
522 Loc
: constant Source_Ptr
:= Sloc
(AC
);
523 Typ
: constant Entity_Id
:= Etype
(E
);
524 Aexp
: constant Node_Id
:= Expression
(AC
);
527 -- Address expression (not necessarily the same as Aexp, for example
528 -- when Aexp is a reference to a constant, in which case Expr gets
529 -- reset to reference the value expression of the constant.
531 Size_Warning_Output
: Boolean := False;
532 -- If we output a size warning we set this True, to stop generating
533 -- what is likely to be an unuseful redundant alignment warning.
535 procedure Compile_Time_Bad_Alignment
;
536 -- Post error warnings when alignment is known to be incompatible. Note
537 -- that we do not go as far as inserting a raise of Program_Error since
538 -- this is an erroneous case, and it may happen that we are lucky and an
539 -- underaligned address turns out to be OK after all. Also this warning
540 -- is suppressed if we already complained about the size.
542 --------------------------------
543 -- Compile_Time_Bad_Alignment --
544 --------------------------------
546 procedure Compile_Time_Bad_Alignment
is
548 if not Size_Warning_Output
549 and then Address_Clause_Overlay_Warnings
552 ("?specified address for& may be inconsistent with alignment ",
555 ("\?program execution may be erroneous (RM 13.3(27))",
557 Set_Address_Warning_Posted
(AC
);
559 end Compile_Time_Bad_Alignment
;
561 -- Start of processing for Apply_Address_Clause_Check
564 -- First obtain expression from address clause
566 Expr
:= Expression
(AC
);
568 -- The following loop digs for the real expression to use in the check
571 -- For constant, get constant expression
573 if Is_Entity_Name
(Expr
)
574 and then Ekind
(Entity
(Expr
)) = E_Constant
576 Expr
:= Constant_Value
(Entity
(Expr
));
578 -- For unchecked conversion, get result to convert
580 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
581 Expr
:= Expression
(Expr
);
583 -- For (common case) of To_Address call, get argument
585 elsif Nkind
(Expr
) = N_Function_Call
586 and then Is_Entity_Name
(Name
(Expr
))
587 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
589 Expr
:= First
(Parameter_Associations
(Expr
));
591 if Nkind
(Expr
) = N_Parameter_Association
then
592 Expr
:= Explicit_Actual_Parameter
(Expr
);
595 -- We finally have the real expression
602 -- Output a warning if we have the situation of
604 -- for X'Address use Y'Address
606 -- and X and Y both have known object sizes, and Y is smaller than X
608 if Nkind
(Expr
) = N_Attribute_Reference
609 and then Attribute_Name
(Expr
) = Name_Address
610 and then Is_Entity_Name
(Prefix
(Expr
))
613 Exp_Ent
: constant Entity_Id
:= Entity
(Prefix
(Expr
));
614 Obj_Size
: Uint
:= No_Uint
;
615 Exp_Size
: Uint
:= No_Uint
;
618 if Known_Esize
(E
) then
619 Obj_Size
:= Esize
(E
);
620 elsif Known_Esize
(Etype
(E
)) then
621 Obj_Size
:= Esize
(Etype
(E
));
624 if Known_Esize
(Exp_Ent
) then
625 Exp_Size
:= Esize
(Exp_Ent
);
626 elsif Known_Esize
(Etype
(Exp_Ent
)) then
627 Exp_Size
:= Esize
(Etype
(Exp_Ent
));
630 if Obj_Size
/= No_Uint
631 and then Exp_Size
/= No_Uint
632 and then Obj_Size
> Exp_Size
633 and then not Has_Warnings_Off
(E
)
635 if Address_Clause_Overlay_Warnings
then
637 ("?& overlays smaller object", Aexp
, E
);
639 ("\?program execution may be erroneous", Aexp
, E
);
640 Size_Warning_Output
:= True;
641 Set_Address_Warning_Posted
(AC
);
647 -- See if alignment check needed. Note that we never need a check if the
648 -- maximum alignment is one, since the check will always succeed.
650 -- Note: we do not check for checks suppressed here, since that check
651 -- was done in Sem_Ch13 when the address clause was processed. We are
652 -- only called if checks were not suppressed. The reason for this is
653 -- that we have to delay the call to Apply_Alignment_Check till freeze
654 -- time (so that all types etc are elaborated), but we have to check
655 -- the status of check suppressing at the point of the address clause.
658 or else not Check_Address_Alignment
(AC
)
659 or else Maximum_Alignment
= 1
664 -- See if we know that Expr is a bad alignment at compile time
666 if Compile_Time_Known_Value
(Expr
)
667 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
670 AL
: Uint
:= Alignment
(Typ
);
673 -- The object alignment might be more restrictive than the
676 if Known_Alignment
(E
) then
680 if Expr_Value
(Expr
) mod AL
/= 0 then
681 Compile_Time_Bad_Alignment
;
687 -- If the expression has the form X'Address, then we can find out if
688 -- the object X has an alignment that is compatible with the object E.
690 elsif Nkind
(Expr
) = N_Attribute_Reference
691 and then Attribute_Name
(Expr
) = Name_Address
694 AR
: constant Alignment_Result
:=
695 Has_Compatible_Alignment
(E
, Prefix
(Expr
));
697 if AR
= Known_Compatible
then
699 elsif AR
= Known_Incompatible
then
700 Compile_Time_Bad_Alignment
;
705 -- Here we do not know if the value is acceptable. Stricly we don't have
706 -- to do anything, since if the alignment is bad, we have an erroneous
707 -- program. However we are allowed to check for erroneous conditions and
708 -- we decide to do this by default if the check is not suppressed.
710 -- However, don't do the check if elaboration code is unwanted
712 if Restriction_Active
(No_Elaboration_Code
) then
715 -- Generate a check to raise PE if alignment may be inappropriate
718 -- If the original expression is a non-static constant, use the
719 -- name of the constant itself rather than duplicating its
720 -- defining expression, which was extracted above.
722 -- Note: Expr is empty if the address-clause is applied to in-mode
723 -- actuals (allowed by 13.1(22)).
725 if not Present
(Expr
)
727 (Is_Entity_Name
(Expression
(AC
))
728 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
729 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
730 = N_Object_Declaration
)
732 Expr
:= New_Copy_Tree
(Expression
(AC
));
734 Remove_Side_Effects
(Expr
);
737 Insert_After_And_Analyze
(N
,
738 Make_Raise_Program_Error
(Loc
,
745 (RTE
(RE_Integer_Address
), Expr
),
747 Make_Attribute_Reference
(Loc
,
748 Prefix
=> New_Occurrence_Of
(E
, Loc
),
749 Attribute_Name
=> Name_Alignment
)),
750 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
751 Reason
=> PE_Misaligned_Address_Value
),
752 Suppress
=> All_Checks
);
757 -- If we have some missing run time component in configurable run time
758 -- mode then just skip the check (it is not required in any case).
760 when RE_Not_Available
=>
762 end Apply_Address_Clause_Check
;
764 -------------------------------------
765 -- Apply_Arithmetic_Overflow_Check --
766 -------------------------------------
768 -- This routine is called only if the type is an integer type, and a
769 -- software arithmetic overflow check may be needed for op (add, subtract,
770 -- or multiply). This check is performed only if Software_Overflow_Checking
771 -- is enabled and Do_Overflow_Check is set. In this case we expand the
772 -- operation into a more complex sequence of tests that ensures that
773 -- overflow is properly caught.
775 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
776 Loc
: constant Source_Ptr
:= Sloc
(N
);
777 Typ
: Entity_Id
:= Etype
(N
);
778 Rtyp
: Entity_Id
:= Root_Type
(Typ
);
781 -- An interesting special case. If the arithmetic operation appears as
782 -- the operand of a type conversion:
786 -- and all the following conditions apply:
788 -- arithmetic operation is for a signed integer type
789 -- target type type1 is a static integer subtype
790 -- range of x and y are both included in the range of type1
791 -- range of x op y is included in the range of type1
792 -- size of type1 is at least twice the result size of op
794 -- then we don't do an overflow check in any case, instead we transform
795 -- the operation so that we end up with:
797 -- type1 (type1 (x) op type1 (y))
799 -- This avoids intermediate overflow before the conversion. It is
800 -- explicitly permitted by RM 3.5.4(24):
802 -- For the execution of a predefined operation of a signed integer
803 -- type, the implementation need not raise Constraint_Error if the
804 -- result is outside the base range of the type, so long as the
805 -- correct result is produced.
807 -- It's hard to imagine that any programmer counts on the exception
808 -- being raised in this case, and in any case it's wrong coding to
809 -- have this expectation, given the RM permission. Furthermore, other
810 -- Ada compilers do allow such out of range results.
812 -- Note that we do this transformation even if overflow checking is
813 -- off, since this is precisely about giving the "right" result and
814 -- avoiding the need for an overflow check.
816 if Is_Signed_Integer_Type
(Typ
)
817 and then Nkind
(Parent
(N
)) = N_Type_Conversion
820 Target_Type
: constant Entity_Id
:=
821 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
835 if Is_Integer_Type
(Target_Type
)
836 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
838 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
839 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
841 Determine_Range
(Left_Opnd
(N
), LOK
, Llo
, Lhi
);
842 Determine_Range
(Right_Opnd
(N
), ROK
, Rlo
, Rhi
);
845 and then Tlo
<= Llo
and then Lhi
<= Thi
846 and then Tlo
<= Rlo
and then Rhi
<= Thi
848 Determine_Range
(N
, VOK
, Vlo
, Vhi
);
850 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
851 Rewrite
(Left_Opnd
(N
),
852 Make_Type_Conversion
(Loc
,
853 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
854 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
856 Rewrite
(Right_Opnd
(N
),
857 Make_Type_Conversion
(Loc
,
858 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
859 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
861 Set_Etype
(N
, Target_Type
);
863 Rtyp
:= Root_Type
(Typ
);
864 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
865 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
867 -- Given that the target type is twice the size of the
868 -- source type, overflow is now impossible, so we can
869 -- safely kill the overflow check and return.
871 Set_Do_Overflow_Check
(N
, False);
879 -- Now see if an overflow check is required
882 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
883 Dsiz
: constant Int
:= Siz
* 2;
890 -- Skip check if back end does overflow checks, or the overflow flag
891 -- is not set anyway, or we are not doing code expansion.
893 -- Special case CLI target, where arithmetic overflow checks can be
894 -- performed for integer and long_integer
896 if Backend_Overflow_Checks_On_Target
897 or else not Do_Overflow_Check
(N
)
898 or else not Expander_Active
900 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
905 -- Otherwise, generate the full general code for front end overflow
906 -- detection, which works by doing arithmetic in a larger type:
912 -- Typ (Checktyp (x) op Checktyp (y));
914 -- where Typ is the type of the original expression, and Checktyp is
915 -- an integer type of sufficient length to hold the largest possible
918 -- If the size of check type exceeds the size of Long_Long_Integer,
919 -- we use a different approach, expanding to:
921 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
923 -- where xxx is Add, Multiply or Subtract as appropriate
925 -- Find check type if one exists
927 if Dsiz
<= Standard_Integer_Size
then
928 Ctyp
:= Standard_Integer
;
930 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
931 Ctyp
:= Standard_Long_Long_Integer
;
933 -- No check type exists, use runtime call
936 if Nkind
(N
) = N_Op_Add
then
937 Cent
:= RE_Add_With_Ovflo_Check
;
939 elsif Nkind
(N
) = N_Op_Multiply
then
940 Cent
:= RE_Multiply_With_Ovflo_Check
;
943 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
944 Cent
:= RE_Subtract_With_Ovflo_Check
;
949 Make_Function_Call
(Loc
,
950 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
951 Parameter_Associations
=> New_List
(
952 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
953 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
955 Analyze_And_Resolve
(N
, Typ
);
959 -- If we fall through, we have the case where we do the arithmetic
960 -- in the next higher type and get the check by conversion. In these
961 -- cases Ctyp is set to the type to be used as the check type.
963 Opnod
:= Relocate_Node
(N
);
965 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
968 Set_Etype
(Opnd
, Ctyp
);
969 Set_Analyzed
(Opnd
, True);
970 Set_Left_Opnd
(Opnod
, Opnd
);
972 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
975 Set_Etype
(Opnd
, Ctyp
);
976 Set_Analyzed
(Opnd
, True);
977 Set_Right_Opnd
(Opnod
, Opnd
);
979 -- The type of the operation changes to the base type of the check
980 -- type, and we reset the overflow check indication, since clearly no
981 -- overflow is possible now that we are using a double length type.
982 -- We also set the Analyzed flag to avoid a recursive attempt to
985 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
986 Set_Do_Overflow_Check
(Opnod
, False);
987 Set_Analyzed
(Opnod
, True);
989 -- Now build the outer conversion
991 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
993 Set_Etype
(Opnd
, Typ
);
995 -- In the discrete type case, we directly generate the range check
996 -- for the outer operand. This range check will implement the
997 -- required overflow check.
999 if Is_Discrete_Type
(Typ
) then
1001 Generate_Range_Check
1002 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1004 -- For other types, we enable overflow checking on the conversion,
1005 -- after setting the node as analyzed to prevent recursive attempts
1006 -- to expand the conversion node.
1009 Set_Analyzed
(Opnd
, True);
1010 Enable_Overflow_Check
(Opnd
);
1015 when RE_Not_Available
=>
1018 end Apply_Arithmetic_Overflow_Check
;
1020 ----------------------------
1021 -- Apply_Constraint_Check --
1022 ----------------------------
1024 procedure Apply_Constraint_Check
1027 No_Sliding
: Boolean := False)
1029 Desig_Typ
: Entity_Id
;
1032 if Inside_A_Generic
then
1035 elsif Is_Scalar_Type
(Typ
) then
1036 Apply_Scalar_Range_Check
(N
, Typ
);
1038 elsif Is_Array_Type
(Typ
) then
1040 -- A useful optimization: an aggregate with only an others clause
1041 -- always has the right bounds.
1043 if Nkind
(N
) = N_Aggregate
1044 and then No
(Expressions
(N
))
1046 (First
(Choices
(First
(Component_Associations
(N
)))))
1052 if Is_Constrained
(Typ
) then
1053 Apply_Length_Check
(N
, Typ
);
1056 Apply_Range_Check
(N
, Typ
);
1059 Apply_Range_Check
(N
, Typ
);
1062 elsif (Is_Record_Type
(Typ
)
1063 or else Is_Private_Type
(Typ
))
1064 and then Has_Discriminants
(Base_Type
(Typ
))
1065 and then Is_Constrained
(Typ
)
1067 Apply_Discriminant_Check
(N
, Typ
);
1069 elsif Is_Access_Type
(Typ
) then
1071 Desig_Typ
:= Designated_Type
(Typ
);
1073 -- No checks necessary if expression statically null
1075 if Known_Null
(N
) then
1076 if Can_Never_Be_Null
(Typ
) then
1077 Install_Null_Excluding_Check
(N
);
1080 -- No sliding possible on access to arrays
1082 elsif Is_Array_Type
(Desig_Typ
) then
1083 if Is_Constrained
(Desig_Typ
) then
1084 Apply_Length_Check
(N
, Typ
);
1087 Apply_Range_Check
(N
, Typ
);
1089 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1090 and then Is_Constrained
(Desig_Typ
)
1092 Apply_Discriminant_Check
(N
, Typ
);
1095 -- Apply the the 2005 Null_Excluding check. Note that we do not apply
1096 -- this check if the constraint node is illegal, as shown by having
1097 -- an error posted. This additional guard prevents cascaded errors
1098 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1100 if Can_Never_Be_Null
(Typ
)
1101 and then not Can_Never_Be_Null
(Etype
(N
))
1102 and then not Error_Posted
(N
)
1104 Install_Null_Excluding_Check
(N
);
1107 end Apply_Constraint_Check
;
1109 ------------------------------
1110 -- Apply_Discriminant_Check --
1111 ------------------------------
1113 procedure Apply_Discriminant_Check
1116 Lhs
: Node_Id
:= Empty
)
1118 Loc
: constant Source_Ptr
:= Sloc
(N
);
1119 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1120 S_Typ
: Entity_Id
:= Etype
(N
);
1124 function Is_Aliased_Unconstrained_Component
return Boolean;
1125 -- It is possible for an aliased component to have a nominal
1126 -- unconstrained subtype (through instantiation). If this is a
1127 -- discriminated component assigned in the expansion of an aggregate
1128 -- in an initialization, the check must be suppressed. This unusual
1129 -- situation requires a predicate of its own.
1131 ----------------------------------------
1132 -- Is_Aliased_Unconstrained_Component --
1133 ----------------------------------------
1135 function Is_Aliased_Unconstrained_Component
return Boolean is
1140 if Nkind
(Lhs
) /= N_Selected_Component
then
1143 Comp
:= Entity
(Selector_Name
(Lhs
));
1144 Pref
:= Prefix
(Lhs
);
1147 if Ekind
(Comp
) /= E_Component
1148 or else not Is_Aliased
(Comp
)
1153 return not Comes_From_Source
(Pref
)
1154 and then In_Instance
1155 and then not Is_Constrained
(Etype
(Comp
));
1156 end Is_Aliased_Unconstrained_Component
;
1158 -- Start of processing for Apply_Discriminant_Check
1162 T_Typ
:= Designated_Type
(Typ
);
1167 -- Nothing to do if discriminant checks are suppressed or else no code
1168 -- is to be generated
1170 if not Expander_Active
1171 or else Discriminant_Checks_Suppressed
(T_Typ
)
1176 -- No discriminant checks necessary for an access when expression is
1177 -- statically Null. This is not only an optimization, it is fundamental
1178 -- because otherwise discriminant checks may be generated in init procs
1179 -- for types containing an access to a not-yet-frozen record, causing a
1180 -- deadly forward reference.
1182 -- Also, if the expression is of an access type whose designated type is
1183 -- incomplete, then the access value must be null and we suppress the
1186 if Known_Null
(N
) then
1189 elsif Is_Access_Type
(S_Typ
) then
1190 S_Typ
:= Designated_Type
(S_Typ
);
1192 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1197 -- If an assignment target is present, then we need to generate the
1198 -- actual subtype if the target is a parameter or aliased object with
1199 -- an unconstrained nominal subtype.
1201 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1202 -- subtype to the parameter and dereference cases, since other aliased
1203 -- objects are unconstrained (unless the nominal subtype is explicitly
1204 -- constrained). (But we also need to test for renamings???)
1207 and then (Present
(Param_Entity
(Lhs
))
1208 or else (Ada_Version
< Ada_05
1209 and then not Is_Constrained
(T_Typ
)
1210 and then Is_Aliased_View
(Lhs
)
1211 and then not Is_Aliased_Unconstrained_Component
)
1212 or else (Ada_Version
>= Ada_05
1213 and then not Is_Constrained
(T_Typ
)
1214 and then Nkind
(Lhs
) = N_Explicit_Dereference
1215 and then Nkind
(Original_Node
(Lhs
)) /=
1218 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1221 -- Nothing to do if the type is unconstrained (this is the case where
1222 -- the actual subtype in the RM sense of N is unconstrained and no check
1225 if not Is_Constrained
(T_Typ
) then
1228 -- Ada 2005: nothing to do if the type is one for which there is a
1229 -- partial view that is constrained.
1231 elsif Ada_Version
>= Ada_05
1232 and then Has_Constrained_Partial_View
(Base_Type
(T_Typ
))
1237 -- Nothing to do if the type is an Unchecked_Union
1239 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1243 -- Suppress checks if the subtypes are the same. the check must be
1244 -- preserved in an assignment to a formal, because the constraint is
1245 -- given by the actual.
1247 if Nkind
(Original_Node
(N
)) /= N_Allocator
1249 or else not Is_Entity_Name
(Lhs
)
1250 or else No
(Param_Entity
(Lhs
)))
1253 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1254 and then not Is_Aliased_View
(Lhs
)
1259 -- We can also eliminate checks on allocators with a subtype mark that
1260 -- coincides with the context type. The context type may be a subtype
1261 -- without a constraint (common case, a generic actual).
1263 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1264 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1267 Alloc_Typ
: constant Entity_Id
:=
1268 Entity
(Expression
(Original_Node
(N
)));
1271 if Alloc_Typ
= T_Typ
1272 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1273 and then Is_Entity_Name
(
1274 Subtype_Indication
(Parent
(T_Typ
)))
1275 and then Alloc_Typ
= Base_Type
(T_Typ
))
1283 -- See if we have a case where the types are both constrained, and all
1284 -- the constraints are constants. In this case, we can do the check
1285 -- successfully at compile time.
1287 -- We skip this check for the case where the node is a rewritten`
1288 -- allocator, because it already carries the context subtype, and
1289 -- extracting the discriminants from the aggregate is messy.
1291 if Is_Constrained
(S_Typ
)
1292 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1302 -- S_Typ may not have discriminants in the case where it is a
1303 -- private type completed by a default discriminated type. In that
1304 -- case, we need to get the constraints from the underlying_type.
1305 -- If the underlying type is unconstrained (i.e. has no default
1306 -- discriminants) no check is needed.
1308 if Has_Discriminants
(S_Typ
) then
1309 Discr
:= First_Discriminant
(S_Typ
);
1310 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1313 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1316 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1322 -- A further optimization: if T_Typ is derived from S_Typ
1323 -- without imposing a constraint, no check is needed.
1325 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1326 N_Full_Type_Declaration
1329 Type_Def
: constant Node_Id
:=
1331 (Original_Node
(Parent
(T_Typ
)));
1333 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1334 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1335 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1343 DconT
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
1345 while Present
(Discr
) loop
1346 ItemS
:= Node
(DconS
);
1347 ItemT
:= Node
(DconT
);
1349 -- For a discriminated component type constrained by the
1350 -- current instance of an enclosing type, there is no
1351 -- applicable discriminant check.
1353 if Nkind
(ItemT
) = N_Attribute_Reference
1354 and then Is_Access_Type
(Etype
(ItemT
))
1355 and then Is_Entity_Name
(Prefix
(ItemT
))
1356 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1361 -- If the expressions for the discriminants are identical
1362 -- and it is side-effect free (for now just an entity),
1363 -- this may be a shared constraint, e.g. from a subtype
1364 -- without a constraint introduced as a generic actual.
1365 -- Examine other discriminants if any.
1368 and then Is_Entity_Name
(ItemS
)
1372 elsif not Is_OK_Static_Expression
(ItemS
)
1373 or else not Is_OK_Static_Expression
(ItemT
)
1377 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1378 if Do_Access
then -- needs run-time check.
1381 Apply_Compile_Time_Constraint_Error
1382 (N
, "incorrect value for discriminant&?",
1383 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1390 Next_Discriminant
(Discr
);
1399 -- Here we need a discriminant check. First build the expression
1400 -- for the comparisons of the discriminants:
1402 -- (n.disc1 /= typ.disc1) or else
1403 -- (n.disc2 /= typ.disc2) or else
1405 -- (n.discn /= typ.discn)
1407 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1409 -- If Lhs is set and is a parameter, then the condition is
1410 -- guarded by: lhs'constrained and then (condition built above)
1412 if Present
(Param_Entity
(Lhs
)) then
1416 Make_Attribute_Reference
(Loc
,
1417 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1418 Attribute_Name
=> Name_Constrained
),
1419 Right_Opnd
=> Cond
);
1423 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1427 Make_Raise_Constraint_Error
(Loc
,
1429 Reason
=> CE_Discriminant_Check_Failed
));
1430 end Apply_Discriminant_Check
;
1432 ------------------------
1433 -- Apply_Divide_Check --
1434 ------------------------
1436 procedure Apply_Divide_Check
(N
: Node_Id
) is
1437 Loc
: constant Source_Ptr
:= Sloc
(N
);
1438 Typ
: constant Entity_Id
:= Etype
(N
);
1439 Left
: constant Node_Id
:= Left_Opnd
(N
);
1440 Right
: constant Node_Id
:= Right_Opnd
(N
);
1450 pragma Warnings
(Off
, Lhi
);
1451 -- Don't actually use this value
1455 and then not Backend_Divide_Checks_On_Target
1456 and then Check_Needed
(Right
, Division_Check
)
1458 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
1460 -- See if division by zero possible, and if so generate test. This
1461 -- part of the test is not controlled by the -gnato switch.
1463 if Do_Division_Check
(N
) then
1464 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1466 Make_Raise_Constraint_Error
(Loc
,
1469 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1470 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1471 Reason
=> CE_Divide_By_Zero
));
1475 -- Test for extremely annoying case of xxx'First divided by -1
1477 if Do_Overflow_Check
(N
) then
1478 if Nkind
(N
) = N_Op_Divide
1479 and then Is_Signed_Integer_Type
(Typ
)
1481 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
1482 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1484 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1486 ((not LOK
) or else (Llo
= LLB
))
1489 Make_Raise_Constraint_Error
(Loc
,
1495 Duplicate_Subexpr_Move_Checks
(Left
),
1496 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1500 Duplicate_Subexpr
(Right
),
1502 Make_Integer_Literal
(Loc
, -1))),
1503 Reason
=> CE_Overflow_Check_Failed
));
1508 end Apply_Divide_Check
;
1510 ----------------------------------
1511 -- Apply_Float_Conversion_Check --
1512 ----------------------------------
1514 -- Let F and I be the source and target types of the conversion. The RM
1515 -- specifies that a floating-point value X is rounded to the nearest
1516 -- integer, with halfway cases being rounded away from zero. The rounded
1517 -- value of X is checked against I'Range.
1519 -- The catch in the above paragraph is that there is no good way to know
1520 -- whether the round-to-integer operation resulted in overflow. A remedy is
1521 -- to perform a range check in the floating-point domain instead, however:
1523 -- (1) The bounds may not be known at compile time
1524 -- (2) The check must take into account rounding or truncation.
1525 -- (3) The range of type I may not be exactly representable in F.
1526 -- (4) For the rounding case, The end-points I'First - 0.5 and
1527 -- I'Last + 0.5 may or may not be in range, depending on the
1528 -- sign of I'First and I'Last.
1529 -- (5) X may be a NaN, which will fail any comparison
1531 -- The following steps correctly convert X with rounding:
1533 -- (1) If either I'First or I'Last is not known at compile time, use
1534 -- I'Base instead of I in the next three steps and perform a
1535 -- regular range check against I'Range after conversion.
1536 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1537 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1538 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1539 -- In other words, take one of the closest floating-point numbers
1540 -- (which is an integer value) to I'First, and see if it is in
1542 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1543 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1544 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1545 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1546 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1548 -- For the truncating case, replace steps (2) and (3) as follows:
1549 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1550 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1552 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1553 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1556 procedure Apply_Float_Conversion_Check
1558 Target_Typ
: Entity_Id
)
1560 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1561 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1562 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1563 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1564 Target_Base
: constant Entity_Id
:=
1565 Implementation_Base_Type
(Target_Typ
);
1567 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1568 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1569 -- Parent of check node, must be a type conversion
1571 Truncate
: constant Boolean := Float_Truncate
(Par
);
1572 Max_Bound
: constant Uint
:=
1574 (Machine_Radix
(Expr_Type
),
1575 Machine_Mantissa
(Expr_Type
) - 1) - 1;
1577 -- Largest bound, so bound plus or minus half is a machine number of F
1579 Ifirst
, Ilast
: Uint
;
1580 -- Bounds of integer type
1583 -- Bounds to check in floating-point domain
1585 Lo_OK
, Hi_OK
: Boolean;
1586 -- True iff Lo resp. Hi belongs to I'Range
1588 Lo_Chk
, Hi_Chk
: Node_Id
;
1589 -- Expressions that are False iff check fails
1591 Reason
: RT_Exception_Code
;
1594 if not Compile_Time_Known_Value
(LB
)
1595 or not Compile_Time_Known_Value
(HB
)
1598 -- First check that the value falls in the range of the base type,
1599 -- to prevent overflow during conversion and then perform a
1600 -- regular range check against the (dynamic) bounds.
1602 pragma Assert
(Target_Base
/= Target_Typ
);
1604 Temp
: constant Entity_Id
:=
1605 Make_Defining_Identifier
(Loc
,
1606 Chars
=> New_Internal_Name
('T'));
1609 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1610 Set_Etype
(Temp
, Target_Base
);
1612 Insert_Action
(Parent
(Par
),
1613 Make_Object_Declaration
(Loc
,
1614 Defining_Identifier
=> Temp
,
1615 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1616 Expression
=> New_Copy_Tree
(Par
)),
1617 Suppress
=> All_Checks
);
1620 Make_Raise_Constraint_Error
(Loc
,
1623 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1624 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1625 Reason
=> CE_Range_Check_Failed
));
1626 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1632 -- Get the bounds of the target type
1634 Ifirst
:= Expr_Value
(LB
);
1635 Ilast
:= Expr_Value
(HB
);
1637 -- Check against lower bound
1639 if Truncate
and then Ifirst
> 0 then
1640 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
1644 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
1647 elsif abs (Ifirst
) < Max_Bound
then
1648 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1649 Lo_OK
:= (Ifirst
> 0);
1652 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
1653 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
1658 -- Lo_Chk := (X >= Lo)
1660 Lo_Chk
:= Make_Op_Ge
(Loc
,
1661 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1662 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1665 -- Lo_Chk := (X > Lo)
1667 Lo_Chk
:= Make_Op_Gt
(Loc
,
1668 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1669 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1672 -- Check against higher bound
1674 if Truncate
and then Ilast
< 0 then
1675 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
1679 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
1682 elsif abs (Ilast
) < Max_Bound
then
1683 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
1684 Hi_OK
:= (Ilast
< 0);
1686 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
1687 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
1692 -- Hi_Chk := (X <= Hi)
1694 Hi_Chk
:= Make_Op_Le
(Loc
,
1695 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1696 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1699 -- Hi_Chk := (X < Hi)
1701 Hi_Chk
:= Make_Op_Lt
(Loc
,
1702 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1703 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1706 -- If the bounds of the target type are the same as those of the base
1707 -- type, the check is an overflow check as a range check is not
1708 -- performed in these cases.
1710 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
1711 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
1713 Reason
:= CE_Overflow_Check_Failed
;
1715 Reason
:= CE_Range_Check_Failed
;
1718 -- Raise CE if either conditions does not hold
1720 Insert_Action
(Ck_Node
,
1721 Make_Raise_Constraint_Error
(Loc
,
1722 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
1724 end Apply_Float_Conversion_Check
;
1726 ------------------------
1727 -- Apply_Length_Check --
1728 ------------------------
1730 procedure Apply_Length_Check
1732 Target_Typ
: Entity_Id
;
1733 Source_Typ
: Entity_Id
:= Empty
)
1736 Apply_Selected_Length_Checks
1737 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1738 end Apply_Length_Check
;
1740 -----------------------
1741 -- Apply_Range_Check --
1742 -----------------------
1744 procedure Apply_Range_Check
1746 Target_Typ
: Entity_Id
;
1747 Source_Typ
: Entity_Id
:= Empty
)
1750 Apply_Selected_Range_Checks
1751 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1752 end Apply_Range_Check
;
1754 ------------------------------
1755 -- Apply_Scalar_Range_Check --
1756 ------------------------------
1758 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
1759 -- off if it is already set on.
1761 procedure Apply_Scalar_Range_Check
1763 Target_Typ
: Entity_Id
;
1764 Source_Typ
: Entity_Id
:= Empty
;
1765 Fixed_Int
: Boolean := False)
1767 Parnt
: constant Node_Id
:= Parent
(Expr
);
1769 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
1770 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
1773 Is_Subscr_Ref
: Boolean;
1774 -- Set true if Expr is a subscript
1776 Is_Unconstrained_Subscr_Ref
: Boolean;
1777 -- Set true if Expr is a subscript of an unconstrained array. In this
1778 -- case we do not attempt to do an analysis of the value against the
1779 -- range of the subscript, since we don't know the actual subtype.
1782 -- Set to True if Expr should be regarded as a real value even though
1783 -- the type of Expr might be discrete.
1785 procedure Bad_Value
;
1786 -- Procedure called if value is determined to be out of range
1792 procedure Bad_Value
is
1794 Apply_Compile_Time_Constraint_Error
1795 (Expr
, "value not in range of}?", CE_Range_Check_Failed
,
1800 -- Start of processing for Apply_Scalar_Range_Check
1803 -- Return if check obviously not needed
1806 -- Not needed inside generic
1810 -- Not needed if previous error
1812 or else Target_Typ
= Any_Type
1813 or else Nkind
(Expr
) = N_Error
1815 -- Not needed for non-scalar type
1817 or else not Is_Scalar_Type
(Target_Typ
)
1819 -- Not needed if we know node raises CE already
1821 or else Raises_Constraint_Error
(Expr
)
1826 -- Now, see if checks are suppressed
1829 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
1831 if Is_Subscr_Ref
then
1832 Arr
:= Prefix
(Parnt
);
1833 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
1836 if not Do_Range_Check
(Expr
) then
1838 -- Subscript reference. Check for Index_Checks suppressed
1840 if Is_Subscr_Ref
then
1842 -- Check array type and its base type
1844 if Index_Checks_Suppressed
(Arr_Typ
)
1845 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
1849 -- Check array itself if it is an entity name
1851 elsif Is_Entity_Name
(Arr
)
1852 and then Index_Checks_Suppressed
(Entity
(Arr
))
1856 -- Check expression itself if it is an entity name
1858 elsif Is_Entity_Name
(Expr
)
1859 and then Index_Checks_Suppressed
(Entity
(Expr
))
1864 -- All other cases, check for Range_Checks suppressed
1867 -- Check target type and its base type
1869 if Range_Checks_Suppressed
(Target_Typ
)
1870 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
1874 -- Check expression itself if it is an entity name
1876 elsif Is_Entity_Name
(Expr
)
1877 and then Range_Checks_Suppressed
(Entity
(Expr
))
1881 -- If Expr is part of an assignment statement, then check left
1882 -- side of assignment if it is an entity name.
1884 elsif Nkind
(Parnt
) = N_Assignment_Statement
1885 and then Is_Entity_Name
(Name
(Parnt
))
1886 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
1893 -- Do not set range checks if they are killed
1895 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
1896 and then Kill_Range_Check
(Expr
)
1901 -- Do not set range checks for any values from System.Scalar_Values
1902 -- since the whole idea of such values is to avoid checking them!
1904 if Is_Entity_Name
(Expr
)
1905 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
1910 -- Now see if we need a check
1912 if No
(Source_Typ
) then
1913 S_Typ
:= Etype
(Expr
);
1915 S_Typ
:= Source_Typ
;
1918 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
1922 Is_Unconstrained_Subscr_Ref
:=
1923 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
1925 -- Always do a range check if the source type includes infinities and
1926 -- the target type does not include infinities. We do not do this if
1927 -- range checks are killed.
1929 if Is_Floating_Point_Type
(S_Typ
)
1930 and then Has_Infinities
(S_Typ
)
1931 and then not Has_Infinities
(Target_Typ
)
1933 Enable_Range_Check
(Expr
);
1936 -- Return if we know expression is definitely in the range of the target
1937 -- type as determined by Determine_Range. Right now we only do this for
1938 -- discrete types, and not fixed-point or floating-point types.
1940 -- The additional less-precise tests below catch these cases
1942 -- Note: skip this if we are given a source_typ, since the point of
1943 -- supplying a Source_Typ is to stop us looking at the expression.
1944 -- We could sharpen this test to be out parameters only ???
1946 if Is_Discrete_Type
(Target_Typ
)
1947 and then Is_Discrete_Type
(Etype
(Expr
))
1948 and then not Is_Unconstrained_Subscr_Ref
1949 and then No
(Source_Typ
)
1952 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1953 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1958 if Compile_Time_Known_Value
(Tlo
)
1959 and then Compile_Time_Known_Value
(Thi
)
1962 Lov
: constant Uint
:= Expr_Value
(Tlo
);
1963 Hiv
: constant Uint
:= Expr_Value
(Thi
);
1966 -- If range is null, we for sure have a constraint error
1967 -- (we don't even need to look at the value involved,
1968 -- since all possible values will raise CE).
1975 -- Otherwise determine range of value
1977 Determine_Range
(Expr
, OK
, Lo
, Hi
);
1981 -- If definitely in range, all OK
1983 if Lo
>= Lov
and then Hi
<= Hiv
then
1986 -- If definitely not in range, warn
1988 elsif Lov
> Hi
or else Hiv
< Lo
then
1992 -- Otherwise we don't know
2004 Is_Floating_Point_Type
(S_Typ
)
2005 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2007 -- Check if we can determine at compile time whether Expr is in the
2008 -- range of the target type. Note that if S_Typ is within the bounds
2009 -- of Target_Typ then this must be the case. This check is meaningful
2010 -- only if this is not a conversion between integer and real types.
2012 if not Is_Unconstrained_Subscr_Ref
2014 Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2016 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2018 Is_In_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
))
2022 elsif Is_Out_Of_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
) then
2026 -- In the floating-point case, we only do range checks if the type is
2027 -- constrained. We definitely do NOT want range checks for unconstrained
2028 -- types, since we want to have infinities
2030 elsif Is_Floating_Point_Type
(S_Typ
) then
2031 if Is_Constrained
(S_Typ
) then
2032 Enable_Range_Check
(Expr
);
2035 -- For all other cases we enable a range check unconditionally
2038 Enable_Range_Check
(Expr
);
2041 end Apply_Scalar_Range_Check
;
2043 ----------------------------------
2044 -- Apply_Selected_Length_Checks --
2045 ----------------------------------
2047 procedure Apply_Selected_Length_Checks
2049 Target_Typ
: Entity_Id
;
2050 Source_Typ
: Entity_Id
;
2051 Do_Static
: Boolean)
2054 R_Result
: Check_Result
;
2057 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2058 Checks_On
: constant Boolean :=
2059 (not Index_Checks_Suppressed
(Target_Typ
))
2061 (not Length_Checks_Suppressed
(Target_Typ
));
2064 if not Expander_Active
then
2069 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2071 for J
in 1 .. 2 loop
2072 R_Cno
:= R_Result
(J
);
2073 exit when No
(R_Cno
);
2075 -- A length check may mention an Itype which is attached to a
2076 -- subsequent node. At the top level in a package this can cause
2077 -- an order-of-elaboration problem, so we make sure that the itype
2078 -- is referenced now.
2080 if Ekind
(Current_Scope
) = E_Package
2081 and then Is_Compilation_Unit
(Current_Scope
)
2083 Ensure_Defined
(Target_Typ
, Ck_Node
);
2085 if Present
(Source_Typ
) then
2086 Ensure_Defined
(Source_Typ
, Ck_Node
);
2088 elsif Is_Itype
(Etype
(Ck_Node
)) then
2089 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2093 -- If the item is a conditional raise of constraint error, then have
2094 -- a look at what check is being performed and ???
2096 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2097 and then Present
(Condition
(R_Cno
))
2099 Cond
:= Condition
(R_Cno
);
2101 -- Case where node does not now have a dynamic check
2103 if not Has_Dynamic_Length_Check
(Ck_Node
) then
2105 -- If checks are on, just insert the check
2108 Insert_Action
(Ck_Node
, R_Cno
);
2110 if not Do_Static
then
2111 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2114 -- If checks are off, then analyze the length check after
2115 -- temporarily attaching it to the tree in case the relevant
2116 -- condition can be evaluted at compile time. We still want a
2117 -- compile time warning in this case.
2120 Set_Parent
(R_Cno
, Ck_Node
);
2125 -- Output a warning if the condition is known to be True
2127 if Is_Entity_Name
(Cond
)
2128 and then Entity
(Cond
) = Standard_True
2130 Apply_Compile_Time_Constraint_Error
2131 (Ck_Node
, "wrong length for array of}?",
2132 CE_Length_Check_Failed
,
2136 -- If we were only doing a static check, or if checks are not
2137 -- on, then we want to delete the check, since it is not needed.
2138 -- We do this by replacing the if statement by a null statement
2140 elsif Do_Static
or else not Checks_On
then
2141 Remove_Warning_Messages
(R_Cno
);
2142 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2146 Install_Static_Check
(R_Cno
, Loc
);
2149 end Apply_Selected_Length_Checks
;
2151 ---------------------------------
2152 -- Apply_Selected_Range_Checks --
2153 ---------------------------------
2155 procedure Apply_Selected_Range_Checks
2157 Target_Typ
: Entity_Id
;
2158 Source_Typ
: Entity_Id
;
2159 Do_Static
: Boolean)
2162 R_Result
: Check_Result
;
2165 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2166 Checks_On
: constant Boolean :=
2167 (not Index_Checks_Suppressed
(Target_Typ
))
2169 (not Range_Checks_Suppressed
(Target_Typ
));
2172 if not Expander_Active
or else not Checks_On
then
2177 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2179 for J
in 1 .. 2 loop
2181 R_Cno
:= R_Result
(J
);
2182 exit when No
(R_Cno
);
2184 -- If the item is a conditional raise of constraint error, then have
2185 -- a look at what check is being performed and ???
2187 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2188 and then Present
(Condition
(R_Cno
))
2190 Cond
:= Condition
(R_Cno
);
2192 if not Has_Dynamic_Range_Check
(Ck_Node
) then
2193 Insert_Action
(Ck_Node
, R_Cno
);
2195 if not Do_Static
then
2196 Set_Has_Dynamic_Range_Check
(Ck_Node
);
2200 -- Output a warning if the condition is known to be True
2202 if Is_Entity_Name
(Cond
)
2203 and then Entity
(Cond
) = Standard_True
2205 -- Since an N_Range is technically not an expression, we have
2206 -- to set one of the bounds to C_E and then just flag the
2207 -- N_Range. The warning message will point to the lower bound
2208 -- and complain about a range, which seems OK.
2210 if Nkind
(Ck_Node
) = N_Range
then
2211 Apply_Compile_Time_Constraint_Error
2212 (Low_Bound
(Ck_Node
), "static range out of bounds of}?",
2213 CE_Range_Check_Failed
,
2217 Set_Raises_Constraint_Error
(Ck_Node
);
2220 Apply_Compile_Time_Constraint_Error
2221 (Ck_Node
, "static value out of range of}?",
2222 CE_Range_Check_Failed
,
2227 -- If we were only doing a static check, or if checks are not
2228 -- on, then we want to delete the check, since it is not needed.
2229 -- We do this by replacing the if statement by a null statement
2231 elsif Do_Static
or else not Checks_On
then
2232 Remove_Warning_Messages
(R_Cno
);
2233 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2237 Install_Static_Check
(R_Cno
, Loc
);
2240 end Apply_Selected_Range_Checks
;
2242 -------------------------------
2243 -- Apply_Static_Length_Check --
2244 -------------------------------
2246 procedure Apply_Static_Length_Check
2248 Target_Typ
: Entity_Id
;
2249 Source_Typ
: Entity_Id
:= Empty
)
2252 Apply_Selected_Length_Checks
2253 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
2254 end Apply_Static_Length_Check
;
2256 -------------------------------------
2257 -- Apply_Subscript_Validity_Checks --
2258 -------------------------------------
2260 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
2264 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
2266 -- Loop through subscripts
2268 Sub
:= First
(Expressions
(Expr
));
2269 while Present
(Sub
) loop
2271 -- Check one subscript. Note that we do not worry about enumeration
2272 -- type with holes, since we will convert the value to a Pos value
2273 -- for the subscript, and that convert will do the necessary validity
2276 Ensure_Valid
(Sub
, Holes_OK
=> True);
2278 -- Move to next subscript
2282 end Apply_Subscript_Validity_Checks
;
2284 ----------------------------------
2285 -- Apply_Type_Conversion_Checks --
2286 ----------------------------------
2288 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
2289 Target_Type
: constant Entity_Id
:= Etype
(N
);
2290 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
2291 Expr
: constant Node_Id
:= Expression
(N
);
2292 Expr_Type
: constant Entity_Id
:= Etype
(Expr
);
2295 if Inside_A_Generic
then
2298 -- Skip these checks if serious errors detected, there are some nasty
2299 -- situations of incomplete trees that blow things up.
2301 elsif Serious_Errors_Detected
> 0 then
2304 -- Scalar type conversions of the form Target_Type (Expr) require a
2305 -- range check if we cannot be sure that Expr is in the base type of
2306 -- Target_Typ and also that Expr is in the range of Target_Typ. These
2307 -- are not quite the same condition from an implementation point of
2308 -- view, but clearly the second includes the first.
2310 elsif Is_Scalar_Type
(Target_Type
) then
2312 Conv_OK
: constant Boolean := Conversion_OK
(N
);
2313 -- If the Conversion_OK flag on the type conversion is set and no
2314 -- floating point type is involved in the type conversion then
2315 -- fixed point values must be read as integral values.
2317 Float_To_Int
: constant Boolean :=
2318 Is_Floating_Point_Type
(Expr_Type
)
2319 and then Is_Integer_Type
(Target_Type
);
2322 if not Overflow_Checks_Suppressed
(Target_Base
)
2323 and then not In_Subrange_Of
(Expr_Type
, Target_Base
, Conv_OK
)
2324 and then not Float_To_Int
2326 Activate_Overflow_Check
(N
);
2329 if not Range_Checks_Suppressed
(Target_Type
)
2330 and then not Range_Checks_Suppressed
(Expr_Type
)
2332 if Float_To_Int
then
2333 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
2335 Apply_Scalar_Range_Check
2336 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
2341 elsif Comes_From_Source
(N
)
2342 and then not Discriminant_Checks_Suppressed
(Target_Type
)
2343 and then Is_Record_Type
(Target_Type
)
2344 and then Is_Derived_Type
(Target_Type
)
2345 and then not Is_Tagged_Type
(Target_Type
)
2346 and then not Is_Constrained
(Target_Type
)
2347 and then Present
(Stored_Constraint
(Target_Type
))
2349 -- An unconstrained derived type may have inherited discriminant
2350 -- Build an actual discriminant constraint list using the stored
2351 -- constraint, to verify that the expression of the parent type
2352 -- satisfies the constraints imposed by the (unconstrained!)
2353 -- derived type. This applies to value conversions, not to view
2354 -- conversions of tagged types.
2357 Loc
: constant Source_Ptr
:= Sloc
(N
);
2359 Constraint
: Elmt_Id
;
2360 Discr_Value
: Node_Id
;
2363 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
2364 Old_Constraints
: constant Elist_Id
:=
2365 Discriminant_Constraint
(Expr_Type
);
2368 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
2369 while Present
(Constraint
) loop
2370 Discr_Value
:= Node
(Constraint
);
2372 if Is_Entity_Name
(Discr_Value
)
2373 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
2375 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
2378 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
2380 -- Parent is constrained by new discriminant. Obtain
2381 -- Value of original discriminant in expression. If the
2382 -- new discriminant has been used to constrain more than
2383 -- one of the stored discriminants, this will provide the
2384 -- required consistency check.
2387 Make_Selected_Component
(Loc
,
2389 Duplicate_Subexpr_No_Checks
2390 (Expr
, Name_Req
=> True),
2392 Make_Identifier
(Loc
, Chars
(Discr
))),
2396 -- Discriminant of more remote ancestor ???
2401 -- Derived type definition has an explicit value for this
2402 -- stored discriminant.
2406 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
2410 Next_Elmt
(Constraint
);
2413 -- Use the unconstrained expression type to retrieve the
2414 -- discriminants of the parent, and apply momentarily the
2415 -- discriminant constraint synthesized above.
2417 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
2418 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
2419 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
2422 Make_Raise_Constraint_Error
(Loc
,
2424 Reason
=> CE_Discriminant_Check_Failed
));
2427 -- For arrays, conversions are applied during expansion, to take into
2428 -- accounts changes of representation. The checks become range checks on
2429 -- the base type or length checks on the subtype, depending on whether
2430 -- the target type is unconstrained or constrained.
2435 end Apply_Type_Conversion_Checks
;
2437 ----------------------------------------------
2438 -- Apply_Universal_Integer_Attribute_Checks --
2439 ----------------------------------------------
2441 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
2442 Loc
: constant Source_Ptr
:= Sloc
(N
);
2443 Typ
: constant Entity_Id
:= Etype
(N
);
2446 if Inside_A_Generic
then
2449 -- Nothing to do if checks are suppressed
2451 elsif Range_Checks_Suppressed
(Typ
)
2452 and then Overflow_Checks_Suppressed
(Typ
)
2456 -- Nothing to do if the attribute does not come from source. The
2457 -- internal attributes we generate of this type do not need checks,
2458 -- and furthermore the attempt to check them causes some circular
2459 -- elaboration orders when dealing with packed types.
2461 elsif not Comes_From_Source
(N
) then
2464 -- If the prefix is a selected component that depends on a discriminant
2465 -- the check may improperly expose a discriminant instead of using
2466 -- the bounds of the object itself. Set the type of the attribute to
2467 -- the base type of the context, so that a check will be imposed when
2468 -- needed (e.g. if the node appears as an index).
2470 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
2471 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
2472 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
2474 Set_Etype
(N
, Base_Type
(Typ
));
2476 -- Otherwise, replace the attribute node with a type conversion node
2477 -- whose expression is the attribute, retyped to universal integer, and
2478 -- whose subtype mark is the target type. The call to analyze this
2479 -- conversion will set range and overflow checks as required for proper
2480 -- detection of an out of range value.
2483 Set_Etype
(N
, Universal_Integer
);
2484 Set_Analyzed
(N
, True);
2487 Make_Type_Conversion
(Loc
,
2488 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
2489 Expression
=> Relocate_Node
(N
)));
2491 Analyze_And_Resolve
(N
, Typ
);
2494 end Apply_Universal_Integer_Attribute_Checks
;
2496 -------------------------------
2497 -- Build_Discriminant_Checks --
2498 -------------------------------
2500 function Build_Discriminant_Checks
2502 T_Typ
: Entity_Id
) return Node_Id
2504 Loc
: constant Source_Ptr
:= Sloc
(N
);
2507 Disc_Ent
: Entity_Id
;
2511 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
2513 ----------------------------------
2514 -- Aggregate_Discriminant_Value --
2515 ----------------------------------
2517 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
2521 -- The aggregate has been normalized with named associations. We use
2522 -- the Chars field to locate the discriminant to take into account
2523 -- discriminants in derived types, which carry the same name as those
2526 Assoc
:= First
(Component_Associations
(N
));
2527 while Present
(Assoc
) loop
2528 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
2529 return Expression
(Assoc
);
2535 -- Discriminant must have been found in the loop above
2537 raise Program_Error
;
2538 end Aggregate_Discriminant_Val
;
2540 -- Start of processing for Build_Discriminant_Checks
2543 -- Loop through discriminants evolving the condition
2546 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
2548 -- For a fully private type, use the discriminants of the parent type
2550 if Is_Private_Type
(T_Typ
)
2551 and then No
(Full_View
(T_Typ
))
2553 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
2555 Disc_Ent
:= First_Discriminant
(T_Typ
);
2558 while Present
(Disc
) loop
2559 Dval
:= Node
(Disc
);
2561 if Nkind
(Dval
) = N_Identifier
2562 and then Ekind
(Entity
(Dval
)) = E_Discriminant
2564 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
2566 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
2569 -- If we have an Unchecked_Union node, we can infer the discriminants
2572 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
2574 Get_Discriminant_Value
(
2575 First_Discriminant
(T_Typ
),
2577 Stored_Constraint
(T_Typ
)));
2579 elsif Nkind
(N
) = N_Aggregate
then
2581 Duplicate_Subexpr_No_Checks
2582 (Aggregate_Discriminant_Val
(Disc_Ent
));
2586 Make_Selected_Component
(Loc
,
2588 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
2590 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
2592 Set_Is_In_Discriminant_Check
(Dref
);
2595 Evolve_Or_Else
(Cond
,
2598 Right_Opnd
=> Dval
));
2601 Next_Discriminant
(Disc_Ent
);
2605 end Build_Discriminant_Checks
;
2611 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
2619 -- Always check if not simple entity
2621 if Nkind
(Nod
) not in N_Has_Entity
2622 or else not Comes_From_Source
(Nod
)
2627 -- Look up tree for short circuit
2634 -- Done if out of subexpression (note that we allow generated stuff
2635 -- such as itype declarations in this context, to keep the loop going
2636 -- since we may well have generated such stuff in complex situations.
2637 -- Also done if no parent (probably an error condition, but no point
2638 -- in behaving nasty if we find it!)
2641 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
2645 -- Or/Or Else case, where test is part of the right operand, or is
2646 -- part of one of the actions associated with the right operand, and
2647 -- the left operand is an equality test.
2649 elsif K
= N_Op_Or
then
2650 exit when N
= Right_Opnd
(P
)
2651 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
2653 elsif K
= N_Or_Else
then
2654 exit when (N
= Right_Opnd
(P
)
2657 and then List_Containing
(N
) = Actions
(P
)))
2658 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
2660 -- Similar test for the And/And then case, where the left operand
2661 -- is an inequality test.
2663 elsif K
= N_Op_And
then
2664 exit when N
= Right_Opnd
(P
)
2665 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
2667 elsif K
= N_And_Then
then
2668 exit when (N
= Right_Opnd
(P
)
2671 and then List_Containing
(N
) = Actions
(P
)))
2672 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
2678 -- If we fall through the loop, then we have a conditional with an
2679 -- appropriate test as its left operand. So test further.
2682 R
:= Right_Opnd
(L
);
2685 -- Left operand of test must match original variable
2687 if Nkind
(L
) not in N_Has_Entity
2688 or else Entity
(L
) /= Entity
(Nod
)
2693 -- Right operand of test must be key value (zero or null)
2696 when Access_Check
=>
2697 if not Known_Null
(R
) then
2701 when Division_Check
=>
2702 if not Compile_Time_Known_Value
(R
)
2703 or else Expr_Value
(R
) /= Uint_0
2709 raise Program_Error
;
2712 -- Here we have the optimizable case, warn if not short-circuited
2714 if K
= N_Op_And
or else K
= N_Op_Or
then
2716 when Access_Check
=>
2718 ("Constraint_Error may be raised (access check)?",
2720 when Division_Check
=>
2722 ("Constraint_Error may be raised (zero divide)?",
2726 raise Program_Error
;
2729 if K
= N_Op_And
then
2730 Error_Msg_N
("use `AND THEN` instead of AND?", P
);
2732 Error_Msg_N
("use `OR ELSE` instead of OR?", P
);
2735 -- If not short-circuited, we need the ckeck
2739 -- If short-circuited, we can omit the check
2746 -----------------------------------
2747 -- Check_Valid_Lvalue_Subscripts --
2748 -----------------------------------
2750 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
2752 -- Skip this if range checks are suppressed
2754 if Range_Checks_Suppressed
(Etype
(Expr
)) then
2757 -- Only do this check for expressions that come from source. We assume
2758 -- that expander generated assignments explicitly include any necessary
2759 -- checks. Note that this is not just an optimization, it avoids
2760 -- infinite recursions!
2762 elsif not Comes_From_Source
(Expr
) then
2765 -- For a selected component, check the prefix
2767 elsif Nkind
(Expr
) = N_Selected_Component
then
2768 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2771 -- Case of indexed component
2773 elsif Nkind
(Expr
) = N_Indexed_Component
then
2774 Apply_Subscript_Validity_Checks
(Expr
);
2776 -- Prefix may itself be or contain an indexed component, and these
2777 -- subscripts need checking as well.
2779 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2781 end Check_Valid_Lvalue_Subscripts
;
2783 ----------------------------------
2784 -- Null_Exclusion_Static_Checks --
2785 ----------------------------------
2787 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
2788 Error_Node
: Node_Id
;
2790 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
2791 K
: constant Node_Kind
:= Nkind
(N
);
2796 (K
= N_Component_Declaration
2797 or else K
= N_Discriminant_Specification
2798 or else K
= N_Function_Specification
2799 or else K
= N_Object_Declaration
2800 or else K
= N_Parameter_Specification
);
2802 if K
= N_Function_Specification
then
2803 Typ
:= Etype
(Defining_Entity
(N
));
2805 Typ
:= Etype
(Defining_Identifier
(N
));
2809 when N_Component_Declaration
=>
2810 if Present
(Access_Definition
(Component_Definition
(N
))) then
2811 Error_Node
:= Component_Definition
(N
);
2813 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
2816 when N_Discriminant_Specification
=>
2817 Error_Node
:= Discriminant_Type
(N
);
2819 when N_Function_Specification
=>
2820 Error_Node
:= Result_Definition
(N
);
2822 when N_Object_Declaration
=>
2823 Error_Node
:= Object_Definition
(N
);
2825 when N_Parameter_Specification
=>
2826 Error_Node
:= Parameter_Type
(N
);
2829 raise Program_Error
;
2834 -- Enforce legality rule 3.10 (13): A null exclusion can only be
2835 -- applied to an access [sub]type.
2837 if not Is_Access_Type
(Typ
) then
2839 ("`NOT NULL` allowed only for an access type", Error_Node
);
2841 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
2842 -- be applied to a [sub]type that does not exclude null already.
2844 elsif Can_Never_Be_Null
(Typ
)
2846 -- No need to check itypes that have a null exclusion because
2847 -- they are already examined at their point of creation.
2849 and then not Is_Itype
(Typ
)
2852 ("`NOT NULL` not allowed (& already excludes null)",
2857 -- Check that null-excluding objects are always initialized, except for
2858 -- deferred constants, for which the expression will appear in the full
2861 if K
= N_Object_Declaration
2862 and then No
(Expression
(N
))
2863 and then not Constant_Present
(N
)
2864 and then not No_Initialization
(N
)
2866 -- Add an expression that assigns null. This node is needed by
2867 -- Apply_Compile_Time_Constraint_Error, which will replace this with
2868 -- a Constraint_Error node.
2870 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
2871 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
2873 Apply_Compile_Time_Constraint_Error
2874 (N
=> Expression
(N
),
2875 Msg
=> "(Ada 2005) null-excluding objects must be initialized?",
2876 Reason
=> CE_Null_Not_Allowed
);
2879 -- Check that a null-excluding component, formal or object is not being
2880 -- assigned a null value. Otherwise generate a warning message and
2881 -- replace Expression (N) by an N_Constraint_Error node.
2883 if K
/= N_Function_Specification
then
2884 Expr
:= Expression
(N
);
2886 if Present
(Expr
) and then Known_Null
(Expr
) then
2888 when N_Component_Declaration |
2889 N_Discriminant_Specification
=>
2890 Apply_Compile_Time_Constraint_Error
2892 Msg
=> "(Ada 2005) null not allowed " &
2893 "in null-excluding components?",
2894 Reason
=> CE_Null_Not_Allowed
);
2896 when N_Object_Declaration
=>
2897 Apply_Compile_Time_Constraint_Error
2899 Msg
=> "(Ada 2005) null not allowed " &
2900 "in null-excluding objects?",
2901 Reason
=> CE_Null_Not_Allowed
);
2903 when N_Parameter_Specification
=>
2904 Apply_Compile_Time_Constraint_Error
2906 Msg
=> "(Ada 2005) null not allowed " &
2907 "in null-excluding formals?",
2908 Reason
=> CE_Null_Not_Allowed
);
2915 end Null_Exclusion_Static_Checks
;
2917 ----------------------------------
2918 -- Conditional_Statements_Begin --
2919 ----------------------------------
2921 procedure Conditional_Statements_Begin
is
2923 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
2925 -- If stack overflows, kill all checks, that way we know to simply reset
2926 -- the number of saved checks to zero on return. This should never occur
2929 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2932 -- In the normal case, we just make a new stack entry saving the current
2933 -- number of saved checks for a later restore.
2936 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
2938 if Debug_Flag_CC
then
2939 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
2943 end Conditional_Statements_Begin
;
2945 --------------------------------
2946 -- Conditional_Statements_End --
2947 --------------------------------
2949 procedure Conditional_Statements_End
is
2951 pragma Assert
(Saved_Checks_TOS
> 0);
2953 -- If the saved checks stack overflowed, then we killed all checks, so
2954 -- setting the number of saved checks back to zero is correct. This
2955 -- should never occur in practice.
2957 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2958 Num_Saved_Checks
:= 0;
2960 -- In the normal case, restore the number of saved checks from the top
2964 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
2965 if Debug_Flag_CC
then
2966 w
("Conditional_Statements_End: Num_Saved_Checks = ",
2971 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
2972 end Conditional_Statements_End
;
2974 ---------------------
2975 -- Determine_Range --
2976 ---------------------
2978 Cache_Size
: constant := 2 ** 10;
2979 type Cache_Index
is range 0 .. Cache_Size
- 1;
2980 -- Determine size of below cache (power of 2 is more efficient!)
2982 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
2983 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
2984 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
2985 -- The above arrays are used to implement a small direct cache for
2986 -- Determine_Range calls. Because of the way Determine_Range recursively
2987 -- traces subexpressions, and because overflow checking calls the routine
2988 -- on the way up the tree, a quadratic behavior can otherwise be
2989 -- encountered in large expressions. The cache entry for node N is stored
2990 -- in the (N mod Cache_Size) entry, and can be validated by checking the
2991 -- actual node value stored there.
2993 procedure Determine_Range
2999 Typ
: constant Entity_Id
:= Etype
(N
);
3003 -- Lo and Hi bounds of left operand
3007 -- Lo and Hi bounds of right (or only) operand
3010 -- Temp variable used to hold a bound node
3013 -- High bound of base type of expression
3017 -- Refined values for low and high bounds, after tightening
3020 -- Used in lower level calls to indicate if call succeeded
3022 Cindex
: Cache_Index
;
3023 -- Used to search cache
3025 function OK_Operands
return Boolean;
3026 -- Used for binary operators. Determines the ranges of the left and
3027 -- right operands, and if they are both OK, returns True, and puts
3028 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
3034 function OK_Operands
return Boolean is
3036 Determine_Range
(Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
);
3042 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
3046 -- Start of processing for Determine_Range
3049 -- Prevent junk warnings by initializing range variables
3056 -- If the type is not discrete, or is undefined, then we can't do
3057 -- anything about determining the range.
3059 if No
(Typ
) or else not Is_Discrete_Type
(Typ
)
3060 or else Error_Posted
(N
)
3066 -- For all other cases, we can determine the range
3070 -- If value is compile time known, then the possible range is the one
3071 -- value that we know this expression definitely has!
3073 if Compile_Time_Known_Value
(N
) then
3074 Lo
:= Expr_Value
(N
);
3079 -- Return if already in the cache
3081 Cindex
:= Cache_Index
(N
mod Cache_Size
);
3083 if Determine_Range_Cache_N
(Cindex
) = N
then
3084 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
3085 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
3089 -- Otherwise, start by finding the bounds of the type of the expression,
3090 -- the value cannot be outside this range (if it is, then we have an
3091 -- overflow situation, which is a separate check, we are talking here
3092 -- only about the expression value).
3094 -- We use the actual bound unless it is dynamic, in which case use the
3095 -- corresponding base type bound if possible. If we can't get a bound
3096 -- then we figure we can't determine the range (a peculiar case, that
3097 -- perhaps cannot happen, but there is no point in bombing in this
3098 -- optimization circuit.
3100 -- First the low bound
3102 Bound
:= Type_Low_Bound
(Typ
);
3104 if Compile_Time_Known_Value
(Bound
) then
3105 Lo
:= Expr_Value
(Bound
);
3107 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Base_Type
(Typ
))) then
3108 Lo
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
3115 -- Now the high bound
3117 Bound
:= Type_High_Bound
(Typ
);
3119 -- We need the high bound of the base type later on, and this should
3120 -- always be compile time known. Again, it is not clear that this
3121 -- can ever be false, but no point in bombing.
3123 if Compile_Time_Known_Value
(Type_High_Bound
(Base_Type
(Typ
))) then
3124 Hbound
:= Expr_Value
(Type_High_Bound
(Base_Type
(Typ
)));
3132 -- If we have a static subtype, then that may have a tighter bound so
3133 -- use the upper bound of the subtype instead in this case.
3135 if Compile_Time_Known_Value
(Bound
) then
3136 Hi
:= Expr_Value
(Bound
);
3139 -- We may be able to refine this value in certain situations. If any
3140 -- refinement is possible, then Lor and Hir are set to possibly tighter
3141 -- bounds, and OK1 is set to True.
3145 -- For unary plus, result is limited by range of operand
3148 Determine_Range
(Right_Opnd
(N
), OK1
, Lor
, Hir
);
3150 -- For unary minus, determine range of operand, and negate it
3153 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
3160 -- For binary addition, get range of each operand and do the
3161 -- addition to get the result range.
3165 Lor
:= Lo_Left
+ Lo_Right
;
3166 Hir
:= Hi_Left
+ Hi_Right
;
3169 -- Division is tricky. The only case we consider is where the right
3170 -- operand is a positive constant, and in this case we simply divide
3171 -- the bounds of the left operand
3175 if Lo_Right
= Hi_Right
3176 and then Lo_Right
> 0
3178 Lor
:= Lo_Left
/ Lo_Right
;
3179 Hir
:= Hi_Left
/ Lo_Right
;
3186 -- For binary subtraction, get range of each operand and do the worst
3187 -- case subtraction to get the result range.
3189 when N_Op_Subtract
=>
3191 Lor
:= Lo_Left
- Hi_Right
;
3192 Hir
:= Hi_Left
- Lo_Right
;
3195 -- For MOD, if right operand is a positive constant, then result must
3196 -- be in the allowable range of mod results.
3200 if Lo_Right
= Hi_Right
3201 and then Lo_Right
/= 0
3203 if Lo_Right
> 0 then
3205 Hir
:= Lo_Right
- 1;
3207 else -- Lo_Right < 0
3208 Lor
:= Lo_Right
+ 1;
3217 -- For REM, if right operand is a positive constant, then result must
3218 -- be in the allowable range of mod results.
3222 if Lo_Right
= Hi_Right
3223 and then Lo_Right
/= 0
3226 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
3229 -- The sign of the result depends on the sign of the
3230 -- dividend (but not on the sign of the divisor, hence
3231 -- the abs operation above).
3251 -- Attribute reference cases
3253 when N_Attribute_Reference
=>
3254 case Attribute_Name
(N
) is
3256 -- For Pos/Val attributes, we can refine the range using the
3257 -- possible range of values of the attribute expression
3259 when Name_Pos | Name_Val
=>
3260 Determine_Range
(First
(Expressions
(N
)), OK1
, Lor
, Hir
);
3262 -- For Length attribute, use the bounds of the corresponding
3263 -- index type to refine the range.
3267 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
3275 if Is_Access_Type
(Atyp
) then
3276 Atyp
:= Designated_Type
(Atyp
);
3279 -- For string literal, we know exact value
3281 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
3283 Lo
:= String_Literal_Length
(Atyp
);
3284 Hi
:= String_Literal_Length
(Atyp
);
3288 -- Otherwise check for expression given
3290 if No
(Expressions
(N
)) then
3294 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
3297 Indx
:= First_Index
(Atyp
);
3298 for J
in 2 .. Inum
loop
3299 Indx
:= Next_Index
(Indx
);
3303 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
);
3307 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
);
3311 -- The maximum value for Length is the biggest
3312 -- possible gap between the values of the bounds.
3313 -- But of course, this value cannot be negative.
3315 Hir
:= UI_Max
(Uint_0
, UU
- LL
);
3317 -- For constrained arrays, the minimum value for
3318 -- Length is taken from the actual value of the
3319 -- bounds, since the index will be exactly of
3322 if Is_Constrained
(Atyp
) then
3323 Lor
:= UI_Max
(Uint_0
, UL
- LU
);
3325 -- For an unconstrained array, the minimum value
3326 -- for length is always zero.
3335 -- No special handling for other attributes
3336 -- Probably more opportunities exist here ???
3343 -- For type conversion from one discrete type to another, we can
3344 -- refine the range using the converted value.
3346 when N_Type_Conversion
=>
3347 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
);
3349 -- Nothing special to do for all other expression kinds
3357 -- At this stage, if OK1 is true, then we know that the actual
3358 -- result of the computed expression is in the range Lor .. Hir.
3359 -- We can use this to restrict the possible range of results.
3363 -- If the refined value of the low bound is greater than the
3364 -- type high bound, then reset it to the more restrictive
3365 -- value. However, we do NOT do this for the case of a modular
3366 -- type where the possible upper bound on the value is above the
3367 -- base type high bound, because that means the result could wrap.
3370 and then not (Is_Modular_Integer_Type
(Typ
)
3371 and then Hir
> Hbound
)
3376 -- Similarly, if the refined value of the high bound is less
3377 -- than the value so far, then reset it to the more restrictive
3378 -- value. Again, we do not do this if the refined low bound is
3379 -- negative for a modular type, since this would wrap.
3382 and then not (Is_Modular_Integer_Type
(Typ
)
3383 and then Lor
< Uint_0
)
3389 -- Set cache entry for future call and we are all done
3391 Determine_Range_Cache_N
(Cindex
) := N
;
3392 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
3393 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
3396 -- If any exception occurs, it means that we have some bug in the compiler
3397 -- possibly triggered by a previous error, or by some unforseen peculiar
3398 -- occurrence. However, this is only an optimization attempt, so there is
3399 -- really no point in crashing the compiler. Instead we just decide, too
3400 -- bad, we can't figure out a range in this case after all.
3405 -- Debug flag K disables this behavior (useful for debugging)
3407 if Debug_Flag_K
then
3415 end Determine_Range
;
3417 ------------------------------------
3418 -- Discriminant_Checks_Suppressed --
3419 ------------------------------------
3421 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3424 if Is_Unchecked_Union
(E
) then
3426 elsif Checks_May_Be_Suppressed
(E
) then
3427 return Is_Check_Suppressed
(E
, Discriminant_Check
);
3431 return Scope_Suppress
(Discriminant_Check
);
3432 end Discriminant_Checks_Suppressed
;
3434 --------------------------------
3435 -- Division_Checks_Suppressed --
3436 --------------------------------
3438 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3440 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3441 return Is_Check_Suppressed
(E
, Division_Check
);
3443 return Scope_Suppress
(Division_Check
);
3445 end Division_Checks_Suppressed
;
3447 -----------------------------------
3448 -- Elaboration_Checks_Suppressed --
3449 -----------------------------------
3451 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3453 -- The complication in this routine is that if we are in the dynamic
3454 -- model of elaboration, we also check All_Checks, since All_Checks
3455 -- does not set Elaboration_Check explicitly.
3458 if Kill_Elaboration_Checks
(E
) then
3461 elsif Checks_May_Be_Suppressed
(E
) then
3462 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
3464 elsif Dynamic_Elaboration_Checks
then
3465 return Is_Check_Suppressed
(E
, All_Checks
);
3472 if Scope_Suppress
(Elaboration_Check
) then
3474 elsif Dynamic_Elaboration_Checks
then
3475 return Scope_Suppress
(All_Checks
);
3479 end Elaboration_Checks_Suppressed
;
3481 ---------------------------
3482 -- Enable_Overflow_Check --
3483 ---------------------------
3485 procedure Enable_Overflow_Check
(N
: Node_Id
) is
3486 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
3495 if Debug_Flag_CC
then
3496 w
("Enable_Overflow_Check for node ", Int
(N
));
3497 Write_Str
(" Source location = ");
3502 -- Nothing to do if the range of the result is known OK. We skip this
3503 -- for conversions, since the caller already did the check, and in any
3504 -- case the condition for deleting the check for a type conversion is
3507 if Nkind
(N
) /= N_Type_Conversion
then
3508 Determine_Range
(N
, OK
, Lo
, Hi
);
3510 -- Note in the test below that we assume that the range is not OK
3511 -- if a bound of the range is equal to that of the type. That's not
3512 -- quite accurate but we do this for the following reasons:
3514 -- a) The way that Determine_Range works, it will typically report
3515 -- the bounds of the value as being equal to the bounds of the
3516 -- type, because it either can't tell anything more precise, or
3517 -- does not think it is worth the effort to be more precise.
3519 -- b) It is very unusual to have a situation in which this would
3520 -- generate an unnecessary overflow check (an example would be
3521 -- a subtype with a range 0 .. Integer'Last - 1 to which the
3522 -- literal value one is added).
3524 -- c) The alternative is a lot of special casing in this routine
3525 -- which would partially duplicate Determine_Range processing.
3528 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
3529 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
3531 if Debug_Flag_CC
then
3532 w
("No overflow check required");
3539 -- If not in optimizing mode, set flag and we are done. We are also done
3540 -- (and just set the flag) if the type is not a discrete type, since it
3541 -- is not worth the effort to eliminate checks for other than discrete
3542 -- types. In addition, we take this same path if we have stored the
3543 -- maximum number of checks possible already (a very unlikely situation,
3544 -- but we do not want to blow up!)
3546 if Optimization_Level
= 0
3547 or else not Is_Discrete_Type
(Etype
(N
))
3548 or else Num_Saved_Checks
= Saved_Checks
'Last
3550 Activate_Overflow_Check
(N
);
3552 if Debug_Flag_CC
then
3553 w
("Optimization off");
3559 -- Otherwise evaluate and check the expression
3564 Target_Type
=> Empty
,
3570 if Debug_Flag_CC
then
3571 w
("Called Find_Check");
3575 w
(" Check_Num = ", Chk
);
3576 w
(" Ent = ", Int
(Ent
));
3577 Write_Str
(" Ofs = ");
3582 -- If check is not of form to optimize, then set flag and we are done
3585 Activate_Overflow_Check
(N
);
3589 -- If check is already performed, then return without setting flag
3592 if Debug_Flag_CC
then
3593 w
("Check suppressed!");
3599 -- Here we will make a new entry for the new check
3601 Activate_Overflow_Check
(N
);
3602 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3603 Saved_Checks
(Num_Saved_Checks
) :=
3608 Target_Type
=> Empty
);
3610 if Debug_Flag_CC
then
3611 w
("Make new entry, check number = ", Num_Saved_Checks
);
3612 w
(" Entity = ", Int
(Ent
));
3613 Write_Str
(" Offset = ");
3615 w
(" Check_Type = O");
3616 w
(" Target_Type = Empty");
3619 -- If we get an exception, then something went wrong, probably because of
3620 -- an error in the structure of the tree due to an incorrect program. Or it
3621 -- may be a bug in the optimization circuit. In either case the safest
3622 -- thing is simply to set the check flag unconditionally.
3626 Activate_Overflow_Check
(N
);
3628 if Debug_Flag_CC
then
3629 w
(" exception occurred, overflow flag set");
3633 end Enable_Overflow_Check
;
3635 ------------------------
3636 -- Enable_Range_Check --
3637 ------------------------
3639 procedure Enable_Range_Check
(N
: Node_Id
) is
3648 -- Return if unchecked type conversion with range check killed. In this
3649 -- case we never set the flag (that's what Kill_Range_Check is about!)
3651 if Nkind
(N
) = N_Unchecked_Type_Conversion
3652 and then Kill_Range_Check
(N
)
3657 -- Check for various cases where we should suppress the range check
3659 -- No check if range checks suppressed for type of node
3661 if Present
(Etype
(N
))
3662 and then Range_Checks_Suppressed
(Etype
(N
))
3666 -- No check if node is an entity name, and range checks are suppressed
3667 -- for this entity, or for the type of this entity.
3669 elsif Is_Entity_Name
(N
)
3670 and then (Range_Checks_Suppressed
(Entity
(N
))
3671 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
3675 -- No checks if index of array, and index checks are suppressed for
3676 -- the array object or the type of the array.
3678 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
3680 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
3682 if Is_Entity_Name
(Pref
)
3683 and then Index_Checks_Suppressed
(Entity
(Pref
))
3686 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
3692 -- Debug trace output
3694 if Debug_Flag_CC
then
3695 w
("Enable_Range_Check for node ", Int
(N
));
3696 Write_Str
(" Source location = ");
3701 -- If not in optimizing mode, set flag and we are done. We are also done
3702 -- (and just set the flag) if the type is not a discrete type, since it
3703 -- is not worth the effort to eliminate checks for other than discrete
3704 -- types. In addition, we take this same path if we have stored the
3705 -- maximum number of checks possible already (a very unlikely situation,
3706 -- but we do not want to blow up!)
3708 if Optimization_Level
= 0
3709 or else No
(Etype
(N
))
3710 or else not Is_Discrete_Type
(Etype
(N
))
3711 or else Num_Saved_Checks
= Saved_Checks
'Last
3713 Activate_Range_Check
(N
);
3715 if Debug_Flag_CC
then
3716 w
("Optimization off");
3722 -- Otherwise find out the target type
3726 -- For assignment, use left side subtype
3728 if Nkind
(P
) = N_Assignment_Statement
3729 and then Expression
(P
) = N
3731 Ttyp
:= Etype
(Name
(P
));
3733 -- For indexed component, use subscript subtype
3735 elsif Nkind
(P
) = N_Indexed_Component
then
3742 Atyp
:= Etype
(Prefix
(P
));
3744 if Is_Access_Type
(Atyp
) then
3745 Atyp
:= Designated_Type
(Atyp
);
3747 -- If the prefix is an access to an unconstrained array,
3748 -- perform check unconditionally: it depends on the bounds of
3749 -- an object and we cannot currently recognize whether the test
3750 -- may be redundant.
3752 if not Is_Constrained
(Atyp
) then
3753 Activate_Range_Check
(N
);
3757 -- Ditto if the prefix is an explicit dereference whose designated
3758 -- type is unconstrained.
3760 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
3761 and then not Is_Constrained
(Atyp
)
3763 Activate_Range_Check
(N
);
3767 Indx
:= First_Index
(Atyp
);
3768 Subs
:= First
(Expressions
(P
));
3771 Ttyp
:= Etype
(Indx
);
3780 -- For now, ignore all other cases, they are not so interesting
3783 if Debug_Flag_CC
then
3784 w
(" target type not found, flag set");
3787 Activate_Range_Check
(N
);
3791 -- Evaluate and check the expression
3796 Target_Type
=> Ttyp
,
3802 if Debug_Flag_CC
then
3803 w
("Called Find_Check");
3804 w
("Target_Typ = ", Int
(Ttyp
));
3808 w
(" Check_Num = ", Chk
);
3809 w
(" Ent = ", Int
(Ent
));
3810 Write_Str
(" Ofs = ");
3815 -- If check is not of form to optimize, then set flag and we are done
3818 if Debug_Flag_CC
then
3819 w
(" expression not of optimizable type, flag set");
3822 Activate_Range_Check
(N
);
3826 -- If check is already performed, then return without setting flag
3829 if Debug_Flag_CC
then
3830 w
("Check suppressed!");
3836 -- Here we will make a new entry for the new check
3838 Activate_Range_Check
(N
);
3839 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3840 Saved_Checks
(Num_Saved_Checks
) :=
3845 Target_Type
=> Ttyp
);
3847 if Debug_Flag_CC
then
3848 w
("Make new entry, check number = ", Num_Saved_Checks
);
3849 w
(" Entity = ", Int
(Ent
));
3850 Write_Str
(" Offset = ");
3852 w
(" Check_Type = R");
3853 w
(" Target_Type = ", Int
(Ttyp
));
3854 pg
(Union_Id
(Ttyp
));
3857 -- If we get an exception, then something went wrong, probably because of
3858 -- an error in the structure of the tree due to an incorrect program. Or
3859 -- it may be a bug in the optimization circuit. In either case the safest
3860 -- thing is simply to set the check flag unconditionally.
3864 Activate_Range_Check
(N
);
3866 if Debug_Flag_CC
then
3867 w
(" exception occurred, range flag set");
3871 end Enable_Range_Check
;
3877 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
3878 Typ
: constant Entity_Id
:= Etype
(Expr
);
3881 -- Ignore call if we are not doing any validity checking
3883 if not Validity_Checks_On
then
3886 -- Ignore call if range or validity checks suppressed on entity or type
3888 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
3891 -- No check required if expression is from the expander, we assume the
3892 -- expander will generate whatever checks are needed. Note that this is
3893 -- not just an optimization, it avoids infinite recursions!
3895 -- Unchecked conversions must be checked, unless they are initialized
3896 -- scalar values, as in a component assignment in an init proc.
3898 -- In addition, we force a check if Force_Validity_Checks is set
3900 elsif not Comes_From_Source
(Expr
)
3901 and then not Force_Validity_Checks
3902 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
3903 or else Kill_Range_Check
(Expr
))
3907 -- No check required if expression is known to have valid value
3909 elsif Expr_Known_Valid
(Expr
) then
3912 -- Ignore case of enumeration with holes where the flag is set not to
3913 -- worry about holes, since no special validity check is needed
3915 elsif Is_Enumeration_Type
(Typ
)
3916 and then Has_Non_Standard_Rep
(Typ
)
3921 -- No check required on the left-hand side of an assignment
3923 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3924 and then Expr
= Name
(Parent
(Expr
))
3928 -- No check on a univeral real constant. The context will eventually
3929 -- convert it to a machine number for some target type, or report an
3932 elsif Nkind
(Expr
) = N_Real_Literal
3933 and then Etype
(Expr
) = Universal_Real
3937 -- If the expression denotes a component of a packed boolean arrray,
3938 -- no possible check applies. We ignore the old ACATS chestnuts that
3939 -- involve Boolean range True..True.
3941 -- Note: validity checks are generated for expressions that yield a
3942 -- scalar type, when it is possible to create a value that is outside of
3943 -- the type. If this is a one-bit boolean no such value exists. This is
3944 -- an optimization, and it also prevents compiler blowing up during the
3945 -- elaboration of improperly expanded packed array references.
3947 elsif Nkind
(Expr
) = N_Indexed_Component
3948 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
3949 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
3953 -- An annoying special case. If this is an out parameter of a scalar
3954 -- type, then the value is not going to be accessed, therefore it is
3955 -- inappropriate to do any validity check at the call site.
3958 -- Only need to worry about scalar types
3960 if Is_Scalar_Type
(Typ
) then
3970 -- Find actual argument (which may be a parameter association)
3971 -- and the parent of the actual argument (the call statement)
3976 if Nkind
(P
) = N_Parameter_Association
then
3981 -- Only need to worry if we are argument of a procedure call
3982 -- since functions don't have out parameters. If this is an
3983 -- indirect or dispatching call, get signature from the
3986 if Nkind
(P
) = N_Procedure_Call_Statement
then
3987 L
:= Parameter_Associations
(P
);
3989 if Is_Entity_Name
(Name
(P
)) then
3990 E
:= Entity
(Name
(P
));
3992 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
3993 E
:= Etype
(Name
(P
));
3996 -- Only need to worry if there are indeed actuals, and if
3997 -- this could be a procedure call, otherwise we cannot get a
3998 -- match (either we are not an argument, or the mode of the
3999 -- formal is not OUT). This test also filters out the
4002 if Is_Non_Empty_List
(L
)
4003 and then Is_Subprogram
(E
)
4005 -- This is the loop through parameters, looking for an
4006 -- OUT parameter for which we are the argument.
4008 F
:= First_Formal
(E
);
4010 while Present
(F
) loop
4011 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
4024 -- If we fall through, a validity check is required
4026 Insert_Valid_Check
(Expr
);
4028 if Is_Entity_Name
(Expr
)
4029 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
4031 Set_Is_Known_Valid
(Entity
(Expr
));
4035 ----------------------
4036 -- Expr_Known_Valid --
4037 ----------------------
4039 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
4040 Typ
: constant Entity_Id
:= Etype
(Expr
);
4043 -- Non-scalar types are always considered valid, since they never give
4044 -- rise to the issues of erroneous or bounded error behavior that are
4045 -- the concern. In formal reference manual terms the notion of validity
4046 -- only applies to scalar types. Note that even when packed arrays are
4047 -- represented using modular types, they are still arrays semantically,
4048 -- so they are also always valid (in particular, the unused bits can be
4049 -- random rubbish without affecting the validity of the array value).
4051 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
4054 -- If no validity checking, then everything is considered valid
4056 elsif not Validity_Checks_On
then
4059 -- Floating-point types are considered valid unless floating-point
4060 -- validity checks have been specifically turned on.
4062 elsif Is_Floating_Point_Type
(Typ
)
4063 and then not Validity_Check_Floating_Point
4067 -- If the expression is the value of an object that is known to be
4068 -- valid, then clearly the expression value itself is valid.
4070 elsif Is_Entity_Name
(Expr
)
4071 and then Is_Known_Valid
(Entity
(Expr
))
4075 -- References to discriminants are always considered valid. The value
4076 -- of a discriminant gets checked when the object is built. Within the
4077 -- record, we consider it valid, and it is important to do so, since
4078 -- otherwise we can try to generate bogus validity checks which
4079 -- reference discriminants out of scope. Discriminants of concurrent
4080 -- types are excluded for the same reason.
4082 elsif Is_Entity_Name
(Expr
)
4083 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
4087 -- If the type is one for which all values are known valid, then we are
4088 -- sure that the value is valid except in the slightly odd case where
4089 -- the expression is a reference to a variable whose size has been
4090 -- explicitly set to a value greater than the object size.
4092 elsif Is_Known_Valid
(Typ
) then
4093 if Is_Entity_Name
(Expr
)
4094 and then Ekind
(Entity
(Expr
)) = E_Variable
4095 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
4102 -- Integer and character literals always have valid values, where
4103 -- appropriate these will be range checked in any case.
4105 elsif Nkind
(Expr
) = N_Integer_Literal
4107 Nkind
(Expr
) = N_Character_Literal
4111 -- If we have a type conversion or a qualification of a known valid
4112 -- value, then the result will always be valid.
4114 elsif Nkind
(Expr
) = N_Type_Conversion
4116 Nkind
(Expr
) = N_Qualified_Expression
4118 return Expr_Known_Valid
(Expression
(Expr
));
4120 -- The result of any operator is always considered valid, since we
4121 -- assume the necessary checks are done by the operator. For operators
4122 -- on floating-point operations, we must also check when the operation
4123 -- is the right-hand side of an assignment, or is an actual in a call.
4125 elsif Nkind
(Expr
) in N_Op
then
4126 if Is_Floating_Point_Type
(Typ
)
4127 and then Validity_Check_Floating_Point
4129 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
4130 or else Nkind
(Parent
(Expr
)) = N_Function_Call
4131 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
4138 -- The result of a membership test is always valid, since it is true or
4139 -- false, there are no other possibilities.
4141 elsif Nkind
(Expr
) in N_Membership_Test
then
4144 -- For all other cases, we do not know the expression is valid
4149 end Expr_Known_Valid
;
4155 procedure Find_Check
4157 Check_Type
: Character;
4158 Target_Type
: Entity_Id
;
4159 Entry_OK
: out Boolean;
4160 Check_Num
: out Nat
;
4161 Ent
: out Entity_Id
;
4164 function Within_Range_Of
4165 (Target_Type
: Entity_Id
;
4166 Check_Type
: Entity_Id
) return Boolean;
4167 -- Given a requirement for checking a range against Target_Type, and
4168 -- and a range Check_Type against which a check has already been made,
4169 -- determines if the check against check type is sufficient to ensure
4170 -- that no check against Target_Type is required.
4172 ---------------------
4173 -- Within_Range_Of --
4174 ---------------------
4176 function Within_Range_Of
4177 (Target_Type
: Entity_Id
;
4178 Check_Type
: Entity_Id
) return Boolean
4181 if Target_Type
= Check_Type
then
4186 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
4187 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
4188 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
4189 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
4193 or else (Compile_Time_Known_Value
(Tlo
)
4195 Compile_Time_Known_Value
(Clo
)
4197 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
4200 or else (Compile_Time_Known_Value
(Thi
)
4202 Compile_Time_Known_Value
(Chi
)
4204 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
4212 end Within_Range_Of
;
4214 -- Start of processing for Find_Check
4217 -- Establish default, to avoid warnings from GCC
4221 -- Case of expression is simple entity reference
4223 if Is_Entity_Name
(Expr
) then
4224 Ent
:= Entity
(Expr
);
4227 -- Case of expression is entity + known constant
4229 elsif Nkind
(Expr
) = N_Op_Add
4230 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
4231 and then Is_Entity_Name
(Left_Opnd
(Expr
))
4233 Ent
:= Entity
(Left_Opnd
(Expr
));
4234 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
4236 -- Case of expression is entity - known constant
4238 elsif Nkind
(Expr
) = N_Op_Subtract
4239 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
4240 and then Is_Entity_Name
(Left_Opnd
(Expr
))
4242 Ent
:= Entity
(Left_Opnd
(Expr
));
4243 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
4245 -- Any other expression is not of the right form
4254 -- Come here with expression of appropriate form, check if entity is an
4255 -- appropriate one for our purposes.
4257 if (Ekind
(Ent
) = E_Variable
4258 or else Is_Constant_Object
(Ent
))
4259 and then not Is_Library_Level_Entity
(Ent
)
4267 -- See if there is matching check already
4269 for J
in reverse 1 .. Num_Saved_Checks
loop
4271 SC
: Saved_Check
renames Saved_Checks
(J
);
4274 if SC
.Killed
= False
4275 and then SC
.Entity
= Ent
4276 and then SC
.Offset
= Ofs
4277 and then SC
.Check_Type
= Check_Type
4278 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
4286 -- If we fall through entry was not found
4292 ---------------------------------
4293 -- Generate_Discriminant_Check --
4294 ---------------------------------
4296 -- Note: the code for this procedure is derived from the
4297 -- Emit_Discriminant_Check Routine in trans.c.
4299 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
4300 Loc
: constant Source_Ptr
:= Sloc
(N
);
4301 Pref
: constant Node_Id
:= Prefix
(N
);
4302 Sel
: constant Node_Id
:= Selector_Name
(N
);
4304 Orig_Comp
: constant Entity_Id
:=
4305 Original_Record_Component
(Entity
(Sel
));
4306 -- The original component to be checked
4308 Discr_Fct
: constant Entity_Id
:=
4309 Discriminant_Checking_Func
(Orig_Comp
);
4310 -- The discriminant checking function
4313 -- One discriminant to be checked in the type
4315 Real_Discr
: Entity_Id
;
4316 -- Actual discriminant in the call
4318 Pref_Type
: Entity_Id
;
4319 -- Type of relevant prefix (ignoring private/access stuff)
4322 -- List of arguments for function call
4325 -- Keep track of the formal corresponding to the actual we build for
4326 -- each discriminant, in order to be able to perform the necessary type
4330 -- Selected component reference for checking function argument
4333 Pref_Type
:= Etype
(Pref
);
4335 -- Force evaluation of the prefix, so that it does not get evaluated
4336 -- twice (once for the check, once for the actual reference). Such a
4337 -- double evaluation is always a potential source of inefficiency,
4338 -- and is functionally incorrect in the volatile case, or when the
4339 -- prefix may have side-effects. An entity or a component of an
4340 -- entity requires no evaluation.
4342 if Is_Entity_Name
(Pref
) then
4343 if Treat_As_Volatile
(Entity
(Pref
)) then
4344 Force_Evaluation
(Pref
, Name_Req
=> True);
4347 elsif Treat_As_Volatile
(Etype
(Pref
)) then
4348 Force_Evaluation
(Pref
, Name_Req
=> True);
4350 elsif Nkind
(Pref
) = N_Selected_Component
4351 and then Is_Entity_Name
(Prefix
(Pref
))
4356 Force_Evaluation
(Pref
, Name_Req
=> True);
4359 -- For a tagged type, use the scope of the original component to
4360 -- obtain the type, because ???
4362 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
4363 Pref_Type
:= Scope
(Orig_Comp
);
4365 -- For an untagged derived type, use the discriminants of the parent
4366 -- which have been renamed in the derivation, possibly by a one-to-many
4367 -- discriminant constraint. For non-tagged type, initially get the Etype
4371 if Is_Derived_Type
(Pref_Type
)
4372 and then Number_Discriminants
(Pref_Type
) /=
4373 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
4375 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
4379 -- We definitely should have a checking function, This routine should
4380 -- not be called if no discriminant checking function is present.
4382 pragma Assert
(Present
(Discr_Fct
));
4384 -- Create the list of the actual parameters for the call. This list
4385 -- is the list of the discriminant fields of the record expression to
4386 -- be discriminant checked.
4389 Formal
:= First_Formal
(Discr_Fct
);
4390 Discr
:= First_Discriminant
(Pref_Type
);
4391 while Present
(Discr
) loop
4393 -- If we have a corresponding discriminant field, and a parent
4394 -- subtype is present, then we want to use the corresponding
4395 -- discriminant since this is the one with the useful value.
4397 if Present
(Corresponding_Discriminant
(Discr
))
4398 and then Ekind
(Pref_Type
) = E_Record_Type
4399 and then Present
(Parent_Subtype
(Pref_Type
))
4401 Real_Discr
:= Corresponding_Discriminant
(Discr
);
4403 Real_Discr
:= Discr
;
4406 -- Construct the reference to the discriminant
4409 Make_Selected_Component
(Loc
,
4411 Unchecked_Convert_To
(Pref_Type
,
4412 Duplicate_Subexpr
(Pref
)),
4413 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
4415 -- Manually analyze and resolve this selected component. We really
4416 -- want it just as it appears above, and do not want the expander
4417 -- playing discriminal games etc with this reference. Then we append
4418 -- the argument to the list we are gathering.
4420 Set_Etype
(Scomp
, Etype
(Real_Discr
));
4421 Set_Analyzed
(Scomp
, True);
4422 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
4424 Next_Formal_With_Extras
(Formal
);
4425 Next_Discriminant
(Discr
);
4428 -- Now build and insert the call
4431 Make_Raise_Constraint_Error
(Loc
,
4433 Make_Function_Call
(Loc
,
4434 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
4435 Parameter_Associations
=> Args
),
4436 Reason
=> CE_Discriminant_Check_Failed
));
4437 end Generate_Discriminant_Check
;
4439 ---------------------------
4440 -- Generate_Index_Checks --
4441 ---------------------------
4443 procedure Generate_Index_Checks
(N
: Node_Id
) is
4444 Loc
: constant Source_Ptr
:= Sloc
(N
);
4445 A
: constant Node_Id
:= Prefix
(N
);
4451 -- Ignore call if index checks suppressed for array object or type
4453 if (Is_Entity_Name
(A
) and then Index_Checks_Suppressed
(Entity
(A
)))
4454 or else Index_Checks_Suppressed
(Etype
(A
))
4459 -- Generate the checks
4461 Sub
:= First
(Expressions
(N
));
4463 while Present
(Sub
) loop
4464 if Do_Range_Check
(Sub
) then
4465 Set_Do_Range_Check
(Sub
, False);
4467 -- Force evaluation except for the case of a simple name of a
4468 -- non-volatile entity.
4470 if not Is_Entity_Name
(Sub
)
4471 or else Treat_As_Volatile
(Entity
(Sub
))
4473 Force_Evaluation
(Sub
);
4476 -- Generate a raise of constraint error with the appropriate
4477 -- reason and a condition of the form:
4479 -- Base_Type(Sub) not in array'range (subscript)
4481 -- Note that the reason we generate the conversion to the base
4482 -- type here is that we definitely want the range check to take
4483 -- place, even if it looks like the subtype is OK. Optimization
4484 -- considerations that allow us to omit the check have already
4485 -- been taken into account in the setting of the Do_Range_Check
4491 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
4495 Make_Raise_Constraint_Error
(Loc
,
4499 Convert_To
(Base_Type
(Etype
(Sub
)),
4500 Duplicate_Subexpr_Move_Checks
(Sub
)),
4502 Make_Attribute_Reference
(Loc
,
4504 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
4505 Attribute_Name
=> Name_Range
,
4506 Expressions
=> Num
)),
4507 Reason
=> CE_Index_Check_Failed
));
4513 end Generate_Index_Checks
;
4515 --------------------------
4516 -- Generate_Range_Check --
4517 --------------------------
4519 procedure Generate_Range_Check
4521 Target_Type
: Entity_Id
;
4522 Reason
: RT_Exception_Code
)
4524 Loc
: constant Source_Ptr
:= Sloc
(N
);
4525 Source_Type
: constant Entity_Id
:= Etype
(N
);
4526 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
4527 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
4530 -- First special case, if the source type is already within the range
4531 -- of the target type, then no check is needed (probably we should have
4532 -- stopped Do_Range_Check from being set in the first place, but better
4533 -- late than later in preventing junk code!
4535 -- We do NOT apply this if the source node is a literal, since in this
4536 -- case the literal has already been labeled as having the subtype of
4539 if In_Subrange_Of
(Source_Type
, Target_Type
)
4541 (Nkind
(N
) = N_Integer_Literal
4543 Nkind
(N
) = N_Real_Literal
4545 Nkind
(N
) = N_Character_Literal
4548 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
4553 -- We need a check, so force evaluation of the node, so that it does
4554 -- not get evaluated twice (once for the check, once for the actual
4555 -- reference). Such a double evaluation is always a potential source
4556 -- of inefficiency, and is functionally incorrect in the volatile case.
4558 if not Is_Entity_Name
(N
)
4559 or else Treat_As_Volatile
(Entity
(N
))
4561 Force_Evaluation
(N
);
4564 -- The easiest case is when Source_Base_Type and Target_Base_Type are
4565 -- the same since in this case we can simply do a direct check of the
4566 -- value of N against the bounds of Target_Type.
4568 -- [constraint_error when N not in Target_Type]
4570 -- Note: this is by far the most common case, for example all cases of
4571 -- checks on the RHS of assignments are in this category, but not all
4572 -- cases are like this. Notably conversions can involve two types.
4574 if Source_Base_Type
= Target_Base_Type
then
4576 Make_Raise_Constraint_Error
(Loc
,
4579 Left_Opnd
=> Duplicate_Subexpr
(N
),
4580 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4583 -- Next test for the case where the target type is within the bounds
4584 -- of the base type of the source type, since in this case we can
4585 -- simply convert these bounds to the base type of T to do the test.
4587 -- [constraint_error when N not in
4588 -- Source_Base_Type (Target_Type'First)
4590 -- Source_Base_Type(Target_Type'Last))]
4592 -- The conversions will always work and need no check
4594 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
4596 Make_Raise_Constraint_Error
(Loc
,
4599 Left_Opnd
=> Duplicate_Subexpr
(N
),
4604 Convert_To
(Source_Base_Type
,
4605 Make_Attribute_Reference
(Loc
,
4607 New_Occurrence_Of
(Target_Type
, Loc
),
4608 Attribute_Name
=> Name_First
)),
4611 Convert_To
(Source_Base_Type
,
4612 Make_Attribute_Reference
(Loc
,
4614 New_Occurrence_Of
(Target_Type
, Loc
),
4615 Attribute_Name
=> Name_Last
)))),
4618 -- Note that at this stage we now that the Target_Base_Type is not in
4619 -- the range of the Source_Base_Type (since even the Target_Type itself
4620 -- is not in this range). It could still be the case that Source_Type is
4621 -- in range of the target base type since we have not checked that case.
4623 -- If that is the case, we can freely convert the source to the target,
4624 -- and then test the target result against the bounds.
4626 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
4628 -- We make a temporary to hold the value of the converted value
4629 -- (converted to the base type), and then we will do the test against
4632 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4633 -- [constraint_error when Tnn not in Target_Type]
4635 -- Then the conversion itself is replaced by an occurrence of Tnn
4638 Tnn
: constant Entity_Id
:=
4639 Make_Defining_Identifier
(Loc
,
4640 Chars
=> New_Internal_Name
('T'));
4643 Insert_Actions
(N
, New_List
(
4644 Make_Object_Declaration
(Loc
,
4645 Defining_Identifier
=> Tnn
,
4646 Object_Definition
=>
4647 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4648 Constant_Present
=> True,
4650 Make_Type_Conversion
(Loc
,
4651 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
4652 Expression
=> Duplicate_Subexpr
(N
))),
4654 Make_Raise_Constraint_Error
(Loc
,
4657 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4658 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4660 Reason
=> Reason
)));
4662 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4664 -- Set the type of N, because the declaration for Tnn might not
4665 -- be analyzed yet, as is the case if N appears within a record
4666 -- declaration, as a discriminant constraint or expression.
4668 Set_Etype
(N
, Target_Base_Type
);
4671 -- At this stage, we know that we have two scalar types, which are
4672 -- directly convertible, and where neither scalar type has a base
4673 -- range that is in the range of the other scalar type.
4675 -- The only way this can happen is with a signed and unsigned type.
4676 -- So test for these two cases:
4679 -- Case of the source is unsigned and the target is signed
4681 if Is_Unsigned_Type
(Source_Base_Type
)
4682 and then not Is_Unsigned_Type
(Target_Base_Type
)
4684 -- If the source is unsigned and the target is signed, then we
4685 -- know that the source is not shorter than the target (otherwise
4686 -- the source base type would be in the target base type range).
4688 -- In other words, the unsigned type is either the same size as
4689 -- the target, or it is larger. It cannot be smaller.
4692 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
4694 -- We only need to check the low bound if the low bound of the
4695 -- target type is non-negative. If the low bound of the target
4696 -- type is negative, then we know that we will fit fine.
4698 -- If the high bound of the target type is negative, then we
4699 -- know we have a constraint error, since we can't possibly
4700 -- have a negative source.
4702 -- With these two checks out of the way, we can do the check
4703 -- using the source type safely
4705 -- This is definitely the most annoying case!
4707 -- [constraint_error
4708 -- when (Target_Type'First >= 0
4710 -- N < Source_Base_Type (Target_Type'First))
4711 -- or else Target_Type'Last < 0
4712 -- or else N > Source_Base_Type (Target_Type'Last)];
4714 -- We turn off all checks since we know that the conversions
4715 -- will work fine, given the guards for negative values.
4718 Make_Raise_Constraint_Error
(Loc
,
4724 Left_Opnd
=> Make_Op_Ge
(Loc
,
4726 Make_Attribute_Reference
(Loc
,
4728 New_Occurrence_Of
(Target_Type
, Loc
),
4729 Attribute_Name
=> Name_First
),
4730 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4734 Left_Opnd
=> Duplicate_Subexpr
(N
),
4736 Convert_To
(Source_Base_Type
,
4737 Make_Attribute_Reference
(Loc
,
4739 New_Occurrence_Of
(Target_Type
, Loc
),
4740 Attribute_Name
=> Name_First
)))),
4745 Make_Attribute_Reference
(Loc
,
4746 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4747 Attribute_Name
=> Name_Last
),
4748 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
4752 Left_Opnd
=> Duplicate_Subexpr
(N
),
4754 Convert_To
(Source_Base_Type
,
4755 Make_Attribute_Reference
(Loc
,
4756 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4757 Attribute_Name
=> Name_Last
)))),
4760 Suppress
=> All_Checks
);
4762 -- Only remaining possibility is that the source is signed and
4763 -- the target is unsigned
4766 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
4767 and then Is_Unsigned_Type
(Target_Base_Type
));
4769 -- If the source is signed and the target is unsigned, then we
4770 -- know that the target is not shorter than the source (otherwise
4771 -- the target base type would be in the source base type range).
4773 -- In other words, the unsigned type is either the same size as
4774 -- the target, or it is larger. It cannot be smaller.
4776 -- Clearly we have an error if the source value is negative since
4777 -- no unsigned type can have negative values. If the source type
4778 -- is non-negative, then the check can be done using the target
4781 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4783 -- [constraint_error
4784 -- when N < 0 or else Tnn not in Target_Type];
4786 -- We turn off all checks for the conversion of N to the target
4787 -- base type, since we generate the explicit check to ensure that
4788 -- the value is non-negative
4791 Tnn
: constant Entity_Id
:=
4792 Make_Defining_Identifier
(Loc
,
4793 Chars
=> New_Internal_Name
('T'));
4796 Insert_Actions
(N
, New_List
(
4797 Make_Object_Declaration
(Loc
,
4798 Defining_Identifier
=> Tnn
,
4799 Object_Definition
=>
4800 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4801 Constant_Present
=> True,
4803 Make_Type_Conversion
(Loc
,
4805 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4806 Expression
=> Duplicate_Subexpr
(N
))),
4808 Make_Raise_Constraint_Error
(Loc
,
4813 Left_Opnd
=> Duplicate_Subexpr
(N
),
4814 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4818 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4820 New_Occurrence_Of
(Target_Type
, Loc
))),
4823 Suppress
=> All_Checks
);
4825 -- Set the Etype explicitly, because Insert_Actions may have
4826 -- placed the declaration in the freeze list for an enclosing
4827 -- construct, and thus it is not analyzed yet.
4829 Set_Etype
(Tnn
, Target_Base_Type
);
4830 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4834 end Generate_Range_Check
;
4840 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
4842 -- For standard check name, we can do a direct computation
4844 if N
in First_Check_Name
.. Last_Check_Name
then
4845 return Check_Id
(N
- (First_Check_Name
- 1));
4847 -- For non-standard names added by pragma Check_Name, search table
4850 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
4851 if Check_Names
.Table
(J
) = N
then
4857 -- No matching name found
4862 ---------------------
4863 -- Get_Discriminal --
4864 ---------------------
4866 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
4867 Loc
: constant Source_Ptr
:= Sloc
(E
);
4872 -- The bound can be a bona fide parameter of a protected operation,
4873 -- rather than a prival encoded as an in-parameter.
4875 if No
(Discriminal_Link
(Entity
(Bound
))) then
4879 -- Climb the scope stack looking for an enclosing protected type. If
4880 -- we run out of scopes, return the bound itself.
4883 while Present
(Sc
) loop
4884 if Sc
= Standard_Standard
then
4887 elsif Ekind
(Sc
) = E_Protected_Type
then
4894 D
:= First_Discriminant
(Sc
);
4895 while Present
(D
) loop
4896 if Chars
(D
) = Chars
(Bound
) then
4897 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
4900 Next_Discriminant
(D
);
4904 end Get_Discriminal
;
4906 ----------------------
4907 -- Get_Range_Checks --
4908 ----------------------
4910 function Get_Range_Checks
4912 Target_Typ
: Entity_Id
;
4913 Source_Typ
: Entity_Id
:= Empty
;
4914 Warn_Node
: Node_Id
:= Empty
) return Check_Result
4917 return Selected_Range_Checks
4918 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
4919 end Get_Range_Checks
;
4925 function Guard_Access
4928 Ck_Node
: Node_Id
) return Node_Id
4931 if Nkind
(Cond
) = N_Or_Else
then
4932 Set_Paren_Count
(Cond
, 1);
4935 if Nkind
(Ck_Node
) = N_Allocator
then
4942 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
4943 Right_Opnd
=> Make_Null
(Loc
)),
4944 Right_Opnd
=> Cond
);
4948 -----------------------------
4949 -- Index_Checks_Suppressed --
4950 -----------------------------
4952 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4954 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4955 return Is_Check_Suppressed
(E
, Index_Check
);
4957 return Scope_Suppress
(Index_Check
);
4959 end Index_Checks_Suppressed
;
4965 procedure Initialize
is
4967 for J
in Determine_Range_Cache_N
'Range loop
4968 Determine_Range_Cache_N
(J
) := Empty
;
4973 for J
in Int
range 1 .. All_Checks
loop
4974 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
4978 -------------------------
4979 -- Insert_Range_Checks --
4980 -------------------------
4982 procedure Insert_Range_Checks
4983 (Checks
: Check_Result
;
4985 Suppress_Typ
: Entity_Id
;
4986 Static_Sloc
: Source_Ptr
:= No_Location
;
4987 Flag_Node
: Node_Id
:= Empty
;
4988 Do_Before
: Boolean := False)
4990 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
4991 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
4993 Check_Node
: Node_Id
;
4994 Checks_On
: constant Boolean :=
4995 (not Index_Checks_Suppressed
(Suppress_Typ
))
4997 (not Range_Checks_Suppressed
(Suppress_Typ
));
5000 -- For now we just return if Checks_On is false, however this should be
5001 -- enhanced to check for an always True value in the condition and to
5002 -- generate a compilation warning???
5004 if not Expander_Active
or else not Checks_On
then
5008 if Static_Sloc
= No_Location
then
5009 Internal_Static_Sloc
:= Sloc
(Node
);
5012 if No
(Flag_Node
) then
5013 Internal_Flag_Node
:= Node
;
5016 for J
in 1 .. 2 loop
5017 exit when No
(Checks
(J
));
5019 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
5020 and then Present
(Condition
(Checks
(J
)))
5022 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
5023 Check_Node
:= Checks
(J
);
5024 Mark_Rewrite_Insertion
(Check_Node
);
5027 Insert_Before_And_Analyze
(Node
, Check_Node
);
5029 Insert_After_And_Analyze
(Node
, Check_Node
);
5032 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
5037 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
5038 Reason
=> CE_Range_Check_Failed
);
5039 Mark_Rewrite_Insertion
(Check_Node
);
5042 Insert_Before_And_Analyze
(Node
, Check_Node
);
5044 Insert_After_And_Analyze
(Node
, Check_Node
);
5048 end Insert_Range_Checks
;
5050 ------------------------
5051 -- Insert_Valid_Check --
5052 ------------------------
5054 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
5055 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5059 -- Do not insert if checks off, or if not checking validity
5061 if not Validity_Checks_On
5062 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
5067 -- If we have a checked conversion, then validity check applies to
5068 -- the expression inside the conversion, not the result, since if
5069 -- the expression inside is valid, then so is the conversion result.
5072 while Nkind
(Exp
) = N_Type_Conversion
loop
5073 Exp
:= Expression
(Exp
);
5076 -- We are about to insert the validity check for Exp. We save and
5077 -- reset the Do_Range_Check flag over this validity check, and then
5078 -- put it back for the final original reference (Exp may be rewritten).
5081 DRC
: constant Boolean := Do_Range_Check
(Exp
);
5084 Set_Do_Range_Check
(Exp
, False);
5086 -- Insert the validity check. Note that we do this with validity
5087 -- checks turned off, to avoid recursion, we do not want validity
5088 -- checks on the validity checking code itself!
5092 Make_Raise_Constraint_Error
(Loc
,
5096 Make_Attribute_Reference
(Loc
,
5098 Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True),
5099 Attribute_Name
=> Name_Valid
)),
5100 Reason
=> CE_Invalid_Data
),
5101 Suppress
=> Validity_Check
);
5103 -- If the expression is a a reference to an element of a bit-packed
5104 -- array, then it is rewritten as a renaming declaration. If the
5105 -- expression is an actual in a call, it has not been expanded,
5106 -- waiting for the proper point at which to do it. The same happens
5107 -- with renamings, so that we have to force the expansion now. This
5108 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
5111 if Is_Entity_Name
(Exp
)
5112 and then Nkind
(Parent
(Entity
(Exp
))) =
5113 N_Object_Renaming_Declaration
5116 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
5118 if Nkind
(Old_Exp
) = N_Indexed_Component
5119 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
5121 Expand_Packed_Element_Reference
(Old_Exp
);
5126 -- Put back the Do_Range_Check flag on the resulting (possibly
5127 -- rewritten) expression.
5129 -- Note: it might be thought that a validity check is not required
5130 -- when a range check is present, but that's not the case, because
5131 -- the back end is allowed to assume for the range check that the
5132 -- operand is within its declared range (an assumption that validity
5133 -- checking is all about NOT assuming!)
5135 -- Note: no need to worry about Possible_Local_Raise here, it will
5136 -- already have been called if original node has Do_Range_Check set.
5138 Set_Do_Range_Check
(Exp
, DRC
);
5140 end Insert_Valid_Check
;
5142 ----------------------------------
5143 -- Install_Null_Excluding_Check --
5144 ----------------------------------
5146 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
5147 Loc
: constant Source_Ptr
:= Sloc
(N
);
5148 Typ
: constant Entity_Id
:= Etype
(N
);
5150 function In_Declarative_Region_Of_Subprogram_Body
return Boolean;
5151 -- Determine whether node N, a reference to an *in* parameter, is
5152 -- inside the declarative region of the current subprogram body.
5154 procedure Mark_Non_Null
;
5155 -- After installation of check, if the node in question is an entity
5156 -- name, then mark this entity as non-null if possible.
5158 ----------------------------------------------
5159 -- In_Declarative_Region_Of_Subprogram_Body --
5160 ----------------------------------------------
5162 function In_Declarative_Region_Of_Subprogram_Body
return Boolean is
5163 E
: constant Entity_Id
:= Entity
(N
);
5164 S
: constant Entity_Id
:= Current_Scope
;
5168 pragma Assert
(Ekind
(E
) = E_In_Parameter
);
5170 -- Two initial context checks. We must be inside a subprogram body
5171 -- with declarations and reference must not appear in nested scopes.
5173 if (Ekind
(S
) /= E_Function
5174 and then Ekind
(S
) /= E_Procedure
)
5175 or else Scope
(E
) /= S
5180 S_Par
:= Parent
(Parent
(S
));
5182 if Nkind
(S_Par
) /= N_Subprogram_Body
5183 or else No
(Declarations
(S_Par
))
5193 -- Retrieve the declaration node of N (if any). Note that N
5194 -- may be a part of a complex initialization expression.
5198 while Present
(P
) loop
5200 -- While traversing the parent chain, we find that N
5201 -- belongs to a statement, thus it may never appear in
5202 -- a declarative region.
5204 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
5205 or else Nkind
(P
) = N_Procedure_Call_Statement
5210 if Nkind
(P
) in N_Declaration
5211 and then Nkind
(P
) not in N_Subprogram_Specification
5224 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
5226 end In_Declarative_Region_Of_Subprogram_Body
;
5232 procedure Mark_Non_Null
is
5234 -- Only case of interest is if node N is an entity name
5236 if Is_Entity_Name
(N
) then
5238 -- For sure, we want to clear an indication that this is known to
5239 -- be null, since if we get past this check, it definitely is not!
5241 Set_Is_Known_Null
(Entity
(N
), False);
5243 -- We can mark the entity as known to be non-null if either it is
5244 -- safe to capture the value, or in the case of an IN parameter,
5245 -- which is a constant, if the check we just installed is in the
5246 -- declarative region of the subprogram body. In this latter case,
5247 -- a check is decisive for the rest of the body, since we know we
5248 -- must complete all declarations before executing the body.
5250 if Safe_To_Capture_Value
(N
, Entity
(N
))
5252 (Ekind
(Entity
(N
)) = E_In_Parameter
5253 and then In_Declarative_Region_Of_Subprogram_Body
)
5255 Set_Is_Known_Non_Null
(Entity
(N
));
5260 -- Start of processing for Install_Null_Excluding_Check
5263 pragma Assert
(Is_Access_Type
(Typ
));
5265 -- No check inside a generic (why not???)
5267 if Inside_A_Generic
then
5271 -- No check needed if known to be non-null
5273 if Known_Non_Null
(N
) then
5277 -- If known to be null, here is where we generate a compile time check
5279 if Known_Null
(N
) then
5280 Apply_Compile_Time_Constraint_Error
5282 "null value not allowed here?",
5283 CE_Access_Check_Failed
);
5288 -- If entity is never assigned, for sure a warning is appropriate
5290 if Is_Entity_Name
(N
) then
5291 Check_Unset_Reference
(N
);
5294 -- No check needed if checks are suppressed on the range. Note that we
5295 -- don't set Is_Known_Non_Null in this case (we could legitimately do
5296 -- so, since the program is erroneous, but we don't like to casually
5297 -- propagate such conclusions from erroneosity).
5299 if Access_Checks_Suppressed
(Typ
) then
5303 -- No check needed for access to concurrent record types generated by
5304 -- the expander. This is not just an optimization (though it does indeed
5305 -- remove junk checks). It also avoids generation of junk warnings.
5307 if Nkind
(N
) in N_Has_Chars
5308 and then Chars
(N
) = Name_uObject
5309 and then Is_Concurrent_Record_Type
5310 (Directly_Designated_Type
(Etype
(N
)))
5315 -- Otherwise install access check
5318 Make_Raise_Constraint_Error
(Loc
,
5321 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
5322 Right_Opnd
=> Make_Null
(Loc
)),
5323 Reason
=> CE_Access_Check_Failed
));
5326 end Install_Null_Excluding_Check
;
5328 --------------------------
5329 -- Install_Static_Check --
5330 --------------------------
5332 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
5333 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
5334 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
5338 Make_Raise_Constraint_Error
(Loc
,
5339 Reason
=> CE_Range_Check_Failed
));
5340 Set_Analyzed
(R_Cno
);
5341 Set_Etype
(R_Cno
, Typ
);
5342 Set_Raises_Constraint_Error
(R_Cno
);
5343 Set_Is_Static_Expression
(R_Cno
, Stat
);
5344 end Install_Static_Check
;
5346 ---------------------
5347 -- Kill_All_Checks --
5348 ---------------------
5350 procedure Kill_All_Checks
is
5352 if Debug_Flag_CC
then
5353 w
("Kill_All_Checks");
5356 -- We reset the number of saved checks to zero, and also modify all
5357 -- stack entries for statement ranges to indicate that the number of
5358 -- checks at each level is now zero.
5360 Num_Saved_Checks
:= 0;
5362 -- Note: the Int'Min here avoids any possibility of J being out of
5363 -- range when called from e.g. Conditional_Statements_Begin.
5365 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
5366 Saved_Checks_Stack
(J
) := 0;
5368 end Kill_All_Checks
;
5374 procedure Kill_Checks
(V
: Entity_Id
) is
5376 if Debug_Flag_CC
then
5377 w
("Kill_Checks for entity", Int
(V
));
5380 for J
in 1 .. Num_Saved_Checks
loop
5381 if Saved_Checks
(J
).Entity
= V
then
5382 if Debug_Flag_CC
then
5383 w
(" Checks killed for saved check ", J
);
5386 Saved_Checks
(J
).Killed
:= True;
5391 ------------------------------
5392 -- Length_Checks_Suppressed --
5393 ------------------------------
5395 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5397 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5398 return Is_Check_Suppressed
(E
, Length_Check
);
5400 return Scope_Suppress
(Length_Check
);
5402 end Length_Checks_Suppressed
;
5404 --------------------------------
5405 -- Overflow_Checks_Suppressed --
5406 --------------------------------
5408 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5410 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5411 return Is_Check_Suppressed
(E
, Overflow_Check
);
5413 return Scope_Suppress
(Overflow_Check
);
5415 end Overflow_Checks_Suppressed
;
5416 -----------------------------
5417 -- Range_Checks_Suppressed --
5418 -----------------------------
5420 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5424 -- Note: for now we always suppress range checks on Vax float types,
5425 -- since Gigi does not know how to generate these checks.
5427 if Vax_Float
(E
) then
5429 elsif Kill_Range_Checks
(E
) then
5431 elsif Checks_May_Be_Suppressed
(E
) then
5432 return Is_Check_Suppressed
(E
, Range_Check
);
5436 return Scope_Suppress
(Range_Check
);
5437 end Range_Checks_Suppressed
;
5439 -----------------------------------------
5440 -- Range_Or_Validity_Checks_Suppressed --
5441 -----------------------------------------
5443 -- Note: the coding would be simpler here if we simply made appropriate
5444 -- calls to Range/Validity_Checks_Suppressed, but that would result in
5445 -- duplicated checks which we prefer to avoid.
5447 function Range_Or_Validity_Checks_Suppressed
5448 (Expr
: Node_Id
) return Boolean
5451 -- Immediate return if scope checks suppressed for either check
5453 if Scope_Suppress
(Range_Check
) or Scope_Suppress
(Validity_Check
) then
5457 -- If no expression, that's odd, decide that checks are suppressed,
5458 -- since we don't want anyone trying to do checks in this case, which
5459 -- is most likely the result of some other error.
5465 -- Expression is present, so perform suppress checks on type
5468 Typ
: constant Entity_Id
:= Etype
(Expr
);
5470 if Vax_Float
(Typ
) then
5472 elsif Checks_May_Be_Suppressed
(Typ
)
5473 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
5475 Is_Check_Suppressed
(Typ
, Validity_Check
))
5481 -- If expression is an entity name, perform checks on this entity
5483 if Is_Entity_Name
(Expr
) then
5485 Ent
: constant Entity_Id
:= Entity
(Expr
);
5487 if Checks_May_Be_Suppressed
(Ent
) then
5488 return Is_Check_Suppressed
(Ent
, Range_Check
)
5489 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
5494 -- If we fall through, no checks suppressed
5497 end Range_Or_Validity_Checks_Suppressed
;
5503 procedure Remove_Checks
(Expr
: Node_Id
) is
5504 function Process
(N
: Node_Id
) return Traverse_Result
;
5505 -- Process a single node during the traversal
5507 procedure Traverse
is new Traverse_Proc
(Process
);
5508 -- The traversal procedure itself
5514 function Process
(N
: Node_Id
) return Traverse_Result
is
5516 if Nkind
(N
) not in N_Subexpr
then
5520 Set_Do_Range_Check
(N
, False);
5524 Traverse
(Left_Opnd
(N
));
5527 when N_Attribute_Reference
=>
5528 Set_Do_Overflow_Check
(N
, False);
5530 when N_Function_Call
=>
5531 Set_Do_Tag_Check
(N
, False);
5534 Set_Do_Overflow_Check
(N
, False);
5538 Set_Do_Division_Check
(N
, False);
5541 Set_Do_Length_Check
(N
, False);
5544 Set_Do_Division_Check
(N
, False);
5547 Set_Do_Length_Check
(N
, False);
5550 Set_Do_Division_Check
(N
, False);
5553 Set_Do_Length_Check
(N
, False);
5560 Traverse
(Left_Opnd
(N
));
5563 when N_Selected_Component
=>
5564 Set_Do_Discriminant_Check
(N
, False);
5566 when N_Type_Conversion
=>
5567 Set_Do_Length_Check
(N
, False);
5568 Set_Do_Tag_Check
(N
, False);
5569 Set_Do_Overflow_Check
(N
, False);
5578 -- Start of processing for Remove_Checks
5584 ----------------------------
5585 -- Selected_Length_Checks --
5586 ----------------------------
5588 function Selected_Length_Checks
5590 Target_Typ
: Entity_Id
;
5591 Source_Typ
: Entity_Id
;
5592 Warn_Node
: Node_Id
) return Check_Result
5594 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
5597 Expr_Actual
: Node_Id
;
5599 Cond
: Node_Id
:= Empty
;
5600 Do_Access
: Boolean := False;
5601 Wnode
: Node_Id
:= Warn_Node
;
5602 Ret_Result
: Check_Result
:= (Empty
, Empty
);
5603 Num_Checks
: Natural := 0;
5605 procedure Add_Check
(N
: Node_Id
);
5606 -- Adds the action given to Ret_Result if N is non-Empty
5608 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
5609 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5610 -- Comments required ???
5612 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
5613 -- True for equal literals and for nodes that denote the same constant
5614 -- entity, even if its value is not a static constant. This includes the
5615 -- case of a discriminal reference within an init proc. Removes some
5616 -- obviously superfluous checks.
5618 function Length_E_Cond
5619 (Exptyp
: Entity_Id
;
5621 Indx
: Nat
) return Node_Id
;
5622 -- Returns expression to compute:
5623 -- Typ'Length /= Exptyp'Length
5625 function Length_N_Cond
5628 Indx
: Nat
) return Node_Id
;
5629 -- Returns expression to compute:
5630 -- Typ'Length /= Expr'Length
5636 procedure Add_Check
(N
: Node_Id
) is
5640 -- For now, ignore attempt to place more than 2 checks ???
5642 if Num_Checks
= 2 then
5646 pragma Assert
(Num_Checks
<= 1);
5647 Num_Checks
:= Num_Checks
+ 1;
5648 Ret_Result
(Num_Checks
) := N
;
5656 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
5657 SE
: constant Entity_Id
:= Scope
(E
);
5659 E1
: Entity_Id
:= E
;
5662 if Ekind
(Scope
(E
)) = E_Record_Type
5663 and then Has_Discriminants
(Scope
(E
))
5665 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
5668 Insert_Action
(Ck_Node
, N
);
5669 E1
:= Defining_Identifier
(N
);
5673 if Ekind
(E1
) = E_String_Literal_Subtype
then
5675 Make_Integer_Literal
(Loc
,
5676 Intval
=> String_Literal_Length
(E1
));
5678 elsif SE
/= Standard_Standard
5679 and then Ekind
(Scope
(SE
)) = E_Protected_Type
5680 and then Has_Discriminants
(Scope
(SE
))
5681 and then Has_Completion
(Scope
(SE
))
5682 and then not Inside_Init_Proc
5684 -- If the type whose length is needed is a private component
5685 -- constrained by a discriminant, we must expand the 'Length
5686 -- attribute into an explicit computation, using the discriminal
5687 -- of the current protected operation. This is because the actual
5688 -- type of the prival is constructed after the protected opera-
5689 -- tion has been fully expanded.
5692 Indx_Type
: Node_Id
;
5695 Do_Expand
: Boolean := False;
5698 Indx_Type
:= First_Index
(E
);
5700 for J
in 1 .. Indx
- 1 loop
5701 Next_Index
(Indx_Type
);
5704 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
5706 if Nkind
(Lo
) = N_Identifier
5707 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
5709 Lo
:= Get_Discriminal
(E
, Lo
);
5713 if Nkind
(Hi
) = N_Identifier
5714 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
5716 Hi
:= Get_Discriminal
(E
, Hi
);
5721 if not Is_Entity_Name
(Lo
) then
5722 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
5725 if not Is_Entity_Name
(Hi
) then
5726 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
5732 Make_Op_Subtract
(Loc
,
5736 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
5741 Make_Attribute_Reference
(Loc
,
5742 Attribute_Name
=> Name_Length
,
5744 New_Occurrence_Of
(E1
, Loc
));
5747 Set_Expressions
(N
, New_List
(
5748 Make_Integer_Literal
(Loc
, Indx
)));
5757 Make_Attribute_Reference
(Loc
,
5758 Attribute_Name
=> Name_Length
,
5760 New_Occurrence_Of
(E1
, Loc
));
5763 Set_Expressions
(N
, New_List
(
5764 Make_Integer_Literal
(Loc
, Indx
)));
5775 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5778 Make_Attribute_Reference
(Loc
,
5779 Attribute_Name
=> Name_Length
,
5781 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5782 Expressions
=> New_List
(
5783 Make_Integer_Literal
(Loc
, Indx
)));
5790 function Length_E_Cond
5791 (Exptyp
: Entity_Id
;
5793 Indx
: Nat
) return Node_Id
5798 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5799 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
5806 function Length_N_Cond
5809 Indx
: Nat
) return Node_Id
5814 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5815 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
5822 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
5825 (Nkind
(L
) = N_Integer_Literal
5826 and then Nkind
(R
) = N_Integer_Literal
5827 and then Intval
(L
) = Intval
(R
))
5831 and then Ekind
(Entity
(L
)) = E_Constant
5832 and then ((Is_Entity_Name
(R
)
5833 and then Entity
(L
) = Entity
(R
))
5835 (Nkind
(R
) = N_Type_Conversion
5836 and then Is_Entity_Name
(Expression
(R
))
5837 and then Entity
(L
) = Entity
(Expression
(R
)))))
5841 and then Ekind
(Entity
(R
)) = E_Constant
5842 and then Nkind
(L
) = N_Type_Conversion
5843 and then Is_Entity_Name
(Expression
(L
))
5844 and then Entity
(R
) = Entity
(Expression
(L
)))
5848 and then Is_Entity_Name
(R
)
5849 and then Entity
(L
) = Entity
(R
)
5850 and then Ekind
(Entity
(L
)) = E_In_Parameter
5851 and then Inside_Init_Proc
);
5854 -- Start of processing for Selected_Length_Checks
5857 if not Expander_Active
then
5861 if Target_Typ
= Any_Type
5862 or else Target_Typ
= Any_Composite
5863 or else Raises_Constraint_Error
(Ck_Node
)
5872 T_Typ
:= Target_Typ
;
5874 if No
(Source_Typ
) then
5875 S_Typ
:= Etype
(Ck_Node
);
5877 S_Typ
:= Source_Typ
;
5880 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
5884 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
5885 S_Typ
:= Designated_Type
(S_Typ
);
5886 T_Typ
:= Designated_Type
(T_Typ
);
5889 -- A simple optimization for the null case
5891 if Known_Null
(Ck_Node
) then
5896 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
5897 if Is_Constrained
(T_Typ
) then
5899 -- The checking code to be generated will freeze the
5900 -- corresponding array type. However, we must freeze the
5901 -- type now, so that the freeze node does not appear within
5902 -- the generated condional expression, but ahead of it.
5904 Freeze_Before
(Ck_Node
, T_Typ
);
5906 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
5907 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
5909 if Is_Access_Type
(Exptyp
) then
5910 Exptyp
:= Designated_Type
(Exptyp
);
5913 -- String_Literal case. This needs to be handled specially be-
5914 -- cause no index types are available for string literals. The
5915 -- condition is simply:
5917 -- T_Typ'Length = string-literal-length
5919 if Nkind
(Expr_Actual
) = N_String_Literal
5920 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
5924 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
5926 Make_Integer_Literal
(Loc
,
5928 String_Literal_Length
(Etype
(Expr_Actual
))));
5930 -- General array case. Here we have a usable actual subtype for
5931 -- the expression, and the condition is built from the two types
5934 -- T_Typ'Length /= Exptyp'Length or else
5935 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5936 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5939 elsif Is_Constrained
(Exptyp
) then
5941 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5954 -- At the library level, we need to ensure that the type of
5955 -- the object is elaborated before the check itself is
5956 -- emitted. This is only done if the object is in the
5957 -- current compilation unit, otherwise the type is frozen
5958 -- and elaborated in its unit.
5960 if Is_Itype
(Exptyp
)
5962 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
5964 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
5965 and then In_Open_Scopes
(Scope
(Exptyp
))
5967 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
5968 Set_Itype
(Ref_Node
, Exptyp
);
5969 Insert_Action
(Ck_Node
, Ref_Node
);
5972 L_Index
:= First_Index
(T_Typ
);
5973 R_Index
:= First_Index
(Exptyp
);
5975 for Indx
in 1 .. Ndims
loop
5976 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
5978 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
5980 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
5981 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
5983 -- Deal with compile time length check. Note that we
5984 -- skip this in the access case, because the access
5985 -- value may be null, so we cannot know statically.
5988 and then Compile_Time_Known_Value
(L_Low
)
5989 and then Compile_Time_Known_Value
(L_High
)
5990 and then Compile_Time_Known_Value
(R_Low
)
5991 and then Compile_Time_Known_Value
(R_High
)
5993 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
5994 L_Length
:= Expr_Value
(L_High
) -
5995 Expr_Value
(L_Low
) + 1;
5997 L_Length
:= UI_From_Int
(0);
6000 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
6001 R_Length
:= Expr_Value
(R_High
) -
6002 Expr_Value
(R_Low
) + 1;
6004 R_Length
:= UI_From_Int
(0);
6007 if L_Length
> R_Length
then
6009 (Compile_Time_Constraint_Error
6010 (Wnode
, "too few elements for}?", T_Typ
));
6012 elsif L_Length
< R_Length
then
6014 (Compile_Time_Constraint_Error
6015 (Wnode
, "too many elements for}?", T_Typ
));
6018 -- The comparison for an individual index subtype
6019 -- is omitted if the corresponding index subtypes
6020 -- statically match, since the result is known to
6021 -- be true. Note that this test is worth while even
6022 -- though we do static evaluation, because non-static
6023 -- subtypes can statically match.
6026 Subtypes_Statically_Match
6027 (Etype
(L_Index
), Etype
(R_Index
))
6030 (Same_Bounds
(L_Low
, R_Low
)
6031 and then Same_Bounds
(L_High
, R_High
))
6034 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
6043 -- Handle cases where we do not get a usable actual subtype that
6044 -- is constrained. This happens for example in the function call
6045 -- and explicit dereference cases. In these cases, we have to get
6046 -- the length or range from the expression itself, making sure we
6047 -- do not evaluate it more than once.
6049 -- Here Ck_Node is the original expression, or more properly the
6050 -- result of applying Duplicate_Expr to the original tree, forcing
6051 -- the result to be a name.
6055 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6058 -- Build the condition for the explicit dereference case
6060 for Indx
in 1 .. Ndims
loop
6062 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
6069 -- Construct the test and insert into the tree
6071 if Present
(Cond
) then
6073 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
6077 (Make_Raise_Constraint_Error
(Loc
,
6079 Reason
=> CE_Length_Check_Failed
));
6083 end Selected_Length_Checks
;
6085 ---------------------------
6086 -- Selected_Range_Checks --
6087 ---------------------------
6089 function Selected_Range_Checks
6091 Target_Typ
: Entity_Id
;
6092 Source_Typ
: Entity_Id
;
6093 Warn_Node
: Node_Id
) return Check_Result
6095 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
6098 Expr_Actual
: Node_Id
;
6100 Cond
: Node_Id
:= Empty
;
6101 Do_Access
: Boolean := False;
6102 Wnode
: Node_Id
:= Warn_Node
;
6103 Ret_Result
: Check_Result
:= (Empty
, Empty
);
6104 Num_Checks
: Integer := 0;
6106 procedure Add_Check
(N
: Node_Id
);
6107 -- Adds the action given to Ret_Result if N is non-Empty
6109 function Discrete_Range_Cond
6111 Typ
: Entity_Id
) return Node_Id
;
6112 -- Returns expression to compute:
6113 -- Low_Bound (Expr) < Typ'First
6115 -- High_Bound (Expr) > Typ'Last
6117 function Discrete_Expr_Cond
6119 Typ
: Entity_Id
) return Node_Id
;
6120 -- Returns expression to compute:
6125 function Get_E_First_Or_Last
6128 Nam
: Name_Id
) return Node_Id
;
6129 -- Returns expression to compute:
6130 -- E'First or E'Last
6132 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
6133 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
6134 -- Returns expression to compute:
6135 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
6137 function Range_E_Cond
6138 (Exptyp
: Entity_Id
;
6142 -- Returns expression to compute:
6143 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
6145 function Range_Equal_E_Cond
6146 (Exptyp
: Entity_Id
;
6148 Indx
: Nat
) return Node_Id
;
6149 -- Returns expression to compute:
6150 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
6152 function Range_N_Cond
6155 Indx
: Nat
) return Node_Id
;
6156 -- Return expression to compute:
6157 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
6163 procedure Add_Check
(N
: Node_Id
) is
6167 -- For now, ignore attempt to place more than 2 checks ???
6169 if Num_Checks
= 2 then
6173 pragma Assert
(Num_Checks
<= 1);
6174 Num_Checks
:= Num_Checks
+ 1;
6175 Ret_Result
(Num_Checks
) := N
;
6179 -------------------------
6180 -- Discrete_Expr_Cond --
6181 -------------------------
6183 function Discrete_Expr_Cond
6185 Typ
: Entity_Id
) return Node_Id
6193 Convert_To
(Base_Type
(Typ
),
6194 Duplicate_Subexpr_No_Checks
(Expr
)),
6196 Convert_To
(Base_Type
(Typ
),
6197 Get_E_First_Or_Last
(Typ
, 0, Name_First
))),
6202 Convert_To
(Base_Type
(Typ
),
6203 Duplicate_Subexpr_No_Checks
(Expr
)),
6207 Get_E_First_Or_Last
(Typ
, 0, Name_Last
))));
6208 end Discrete_Expr_Cond
;
6210 -------------------------
6211 -- Discrete_Range_Cond --
6212 -------------------------
6214 function Discrete_Range_Cond
6216 Typ
: Entity_Id
) return Node_Id
6218 LB
: Node_Id
:= Low_Bound
(Expr
);
6219 HB
: Node_Id
:= High_Bound
(Expr
);
6221 Left_Opnd
: Node_Id
;
6222 Right_Opnd
: Node_Id
;
6225 if Nkind
(LB
) = N_Identifier
6226 and then Ekind
(Entity
(LB
)) = E_Discriminant
6228 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
6231 if Nkind
(HB
) = N_Identifier
6232 and then Ekind
(Entity
(HB
)) = E_Discriminant
6234 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
6241 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
6245 (Base_Type
(Typ
), Get_E_First_Or_Last
(Typ
, 0, Name_First
)));
6247 if Base_Type
(Typ
) = Typ
then
6250 elsif Compile_Time_Known_Value
(High_Bound
(Scalar_Range
(Typ
)))
6252 Compile_Time_Known_Value
(High_Bound
(Scalar_Range
6255 if Is_Floating_Point_Type
(Typ
) then
6256 if Expr_Value_R
(High_Bound
(Scalar_Range
(Typ
))) =
6257 Expr_Value_R
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
6263 if Expr_Value
(High_Bound
(Scalar_Range
(Typ
))) =
6264 Expr_Value
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
6275 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
6280 Get_E_First_Or_Last
(Typ
, 0, Name_Last
)));
6282 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
6283 end Discrete_Range_Cond
;
6285 -------------------------
6286 -- Get_E_First_Or_Last --
6287 -------------------------
6289 function Get_E_First_Or_Last
6292 Nam
: Name_Id
) return Node_Id
6300 if Is_Array_Type
(E
) then
6301 N
:= First_Index
(E
);
6303 for J
in 2 .. Indx
loop
6308 N
:= Scalar_Range
(E
);
6311 if Nkind
(N
) = N_Subtype_Indication
then
6312 LB
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
6313 HB
:= High_Bound
(Range_Expression
(Constraint
(N
)));
6315 elsif Is_Entity_Name
(N
) then
6316 LB
:= Type_Low_Bound
(Etype
(N
));
6317 HB
:= Type_High_Bound
(Etype
(N
));
6320 LB
:= Low_Bound
(N
);
6321 HB
:= High_Bound
(N
);
6324 if Nam
= Name_First
then
6330 if Nkind
(Bound
) = N_Identifier
6331 and then Ekind
(Entity
(Bound
)) = E_Discriminant
6333 -- If this is a task discriminant, and we are the body, we must
6334 -- retrieve the corresponding body discriminal. This is another
6335 -- consequence of the early creation of discriminals, and the
6336 -- need to generate constraint checks before their declarations
6337 -- are made visible.
6339 if Is_Concurrent_Record_Type
(Scope
(Entity
(Bound
))) then
6341 Tsk
: constant Entity_Id
:=
6342 Corresponding_Concurrent_Type
6343 (Scope
(Entity
(Bound
)));
6347 if In_Open_Scopes
(Tsk
)
6348 and then Has_Completion
(Tsk
)
6350 -- Find discriminant of original task, and use its
6351 -- current discriminal, which is the renaming within
6354 Disc
:= First_Discriminant
(Tsk
);
6355 while Present
(Disc
) loop
6356 if Chars
(Disc
) = Chars
(Entity
(Bound
)) then
6357 Set_Scope
(Discriminal
(Disc
), Tsk
);
6358 return New_Occurrence_Of
(Discriminal
(Disc
), Loc
);
6361 Next_Discriminant
(Disc
);
6364 -- That loop should always succeed in finding a matching
6365 -- entry and returning. Fatal error if not.
6367 raise Program_Error
;
6371 New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
6375 return New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
6378 elsif Nkind
(Bound
) = N_Identifier
6379 and then Ekind
(Entity
(Bound
)) = E_In_Parameter
6380 and then not Inside_Init_Proc
6382 return Get_Discriminal
(E
, Bound
);
6384 elsif Nkind
(Bound
) = N_Integer_Literal
then
6385 return Make_Integer_Literal
(Loc
, Intval
(Bound
));
6387 -- Case of a bound rewritten to an N_Raise_Constraint_Error node
6388 -- because it is an out-of-range value. Duplicate_Subexpr cannot be
6389 -- called on this node because an N_Raise_Constraint_Error is not
6390 -- side effect free, and we may not assume that we are in the proper
6391 -- context to remove side effects on it at the point of reference.
6393 elsif Nkind
(Bound
) = N_Raise_Constraint_Error
then
6394 return New_Copy_Tree
(Bound
);
6397 return Duplicate_Subexpr_No_Checks
(Bound
);
6399 end Get_E_First_Or_Last
;
6405 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
6408 Make_Attribute_Reference
(Loc
,
6409 Attribute_Name
=> Name_First
,
6411 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
6412 Expressions
=> New_List
(
6413 Make_Integer_Literal
(Loc
, Indx
)));
6420 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
6423 Make_Attribute_Reference
(Loc
,
6424 Attribute_Name
=> Name_Last
,
6426 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
6427 Expressions
=> New_List
(
6428 Make_Integer_Literal
(Loc
, Indx
)));
6435 function Range_E_Cond
6436 (Exptyp
: Entity_Id
;
6438 Indx
: Nat
) return Node_Id
6445 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
6446 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
6450 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
6451 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
6454 ------------------------
6455 -- Range_Equal_E_Cond --
6456 ------------------------
6458 function Range_Equal_E_Cond
6459 (Exptyp
: Entity_Id
;
6461 Indx
: Nat
) return Node_Id
6468 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
6469 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
6472 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
6473 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
6474 end Range_Equal_E_Cond
;
6480 function Range_N_Cond
6483 Indx
: Nat
) return Node_Id
6490 Left_Opnd
=> Get_N_First
(Expr
, Indx
),
6491 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
6495 Left_Opnd
=> Get_N_Last
(Expr
, Indx
),
6496 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
6499 -- Start of processing for Selected_Range_Checks
6502 if not Expander_Active
then
6506 if Target_Typ
= Any_Type
6507 or else Target_Typ
= Any_Composite
6508 or else Raises_Constraint_Error
(Ck_Node
)
6517 T_Typ
:= Target_Typ
;
6519 if No
(Source_Typ
) then
6520 S_Typ
:= Etype
(Ck_Node
);
6522 S_Typ
:= Source_Typ
;
6525 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
6529 -- The order of evaluating T_Typ before S_Typ seems to be critical
6530 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
6531 -- in, and since Node can be an N_Range node, it might be invalid.
6532 -- Should there be an assert check somewhere for taking the Etype of
6533 -- an N_Range node ???
6535 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
6536 S_Typ
:= Designated_Type
(S_Typ
);
6537 T_Typ
:= Designated_Type
(T_Typ
);
6540 -- A simple optimization for the null case
6542 if Known_Null
(Ck_Node
) then
6547 -- For an N_Range Node, check for a null range and then if not
6548 -- null generate a range check action.
6550 if Nkind
(Ck_Node
) = N_Range
then
6552 -- There's no point in checking a range against itself
6554 if Ck_Node
= Scalar_Range
(T_Typ
) then
6559 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6560 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6561 LB
: constant Node_Id
:= Low_Bound
(Ck_Node
);
6562 HB
: constant Node_Id
:= High_Bound
(Ck_Node
);
6563 Null_Range
: Boolean;
6565 Out_Of_Range_L
: Boolean;
6566 Out_Of_Range_H
: Boolean;
6569 -- Check for case where everything is static and we can
6570 -- do the check at compile time. This is skipped if we
6571 -- have an access type, since the access value may be null.
6573 -- ??? This code can be improved since you only need to know
6574 -- that the two respective bounds (LB & T_LB or HB & T_HB)
6575 -- are known at compile time to emit pertinent messages.
6577 if Compile_Time_Known_Value
(LB
)
6578 and then Compile_Time_Known_Value
(HB
)
6579 and then Compile_Time_Known_Value
(T_LB
)
6580 and then Compile_Time_Known_Value
(T_HB
)
6581 and then not Do_Access
6583 -- Floating-point case
6585 if Is_Floating_Point_Type
(S_Typ
) then
6586 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
6588 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
6590 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
6593 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
6595 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
6597 -- Fixed or discrete type case
6600 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
6602 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
6604 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
6607 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
6609 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
6612 if not Null_Range
then
6613 if Out_Of_Range_L
then
6614 if No
(Warn_Node
) then
6616 (Compile_Time_Constraint_Error
6617 (Low_Bound
(Ck_Node
),
6618 "static value out of range of}?", T_Typ
));
6622 (Compile_Time_Constraint_Error
6624 "static range out of bounds of}?", T_Typ
));
6628 if Out_Of_Range_H
then
6629 if No
(Warn_Node
) then
6631 (Compile_Time_Constraint_Error
6632 (High_Bound
(Ck_Node
),
6633 "static value out of range of}?", T_Typ
));
6637 (Compile_Time_Constraint_Error
6639 "static range out of bounds of}?", T_Typ
));
6647 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
6648 HB
: Node_Id
:= High_Bound
(Ck_Node
);
6651 -- If either bound is a discriminant and we are within the
6652 -- record declaration, it is a use of the discriminant in a
6653 -- constraint of a component, and nothing can be checked
6654 -- here. The check will be emitted within the init proc.
6655 -- Before then, the discriminal has no real meaning.
6656 -- Similarly, if the entity is a discriminal, there is no
6657 -- check to perform yet.
6659 -- The same holds within a discriminated synchronized type,
6660 -- where the discriminant may constrain a component or an
6663 if Nkind
(LB
) = N_Identifier
6664 and then Denotes_Discriminant
(LB
, True)
6666 if Current_Scope
= Scope
(Entity
(LB
))
6667 or else Is_Concurrent_Type
(Current_Scope
)
6668 or else Ekind
(Entity
(LB
)) /= E_Discriminant
6673 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
6677 if Nkind
(HB
) = N_Identifier
6678 and then Denotes_Discriminant
(HB
, True)
6680 if Current_Scope
= Scope
(Entity
(HB
))
6681 or else Is_Concurrent_Type
(Current_Scope
)
6682 or else Ekind
(Entity
(HB
)) /= E_Discriminant
6687 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
6691 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
6692 Set_Paren_Count
(Cond
, 1);
6698 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
6699 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
6700 Right_Opnd
=> Cond
);
6705 elsif Is_Scalar_Type
(S_Typ
) then
6707 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6708 -- except the above simply sets a flag in the node and lets
6709 -- gigi generate the check base on the Etype of the expression.
6710 -- Sometimes, however we want to do a dynamic check against an
6711 -- arbitrary target type, so we do that here.
6713 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
6714 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6716 -- For literals, we can tell if the constraint error will be
6717 -- raised at compile time, so we never need a dynamic check, but
6718 -- if the exception will be raised, then post the usual warning,
6719 -- and replace the literal with a raise constraint error
6720 -- expression. As usual, skip this for access types
6722 elsif Compile_Time_Known_Value
(Ck_Node
)
6723 and then not Do_Access
6726 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6727 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6729 Out_Of_Range
: Boolean;
6730 Static_Bounds
: constant Boolean :=
6731 Compile_Time_Known_Value
(LB
)
6732 and Compile_Time_Known_Value
(UB
);
6735 -- Following range tests should use Sem_Eval routine ???
6737 if Static_Bounds
then
6738 if Is_Floating_Point_Type
(S_Typ
) then
6740 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
6742 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
6744 else -- fixed or discrete type
6746 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
6748 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
6751 -- Bounds of the type are static and the literal is
6752 -- out of range so make a warning message.
6754 if Out_Of_Range
then
6755 if No
(Warn_Node
) then
6757 (Compile_Time_Constraint_Error
6759 "static value out of range of}?", T_Typ
));
6763 (Compile_Time_Constraint_Error
6765 "static value out of range of}?", T_Typ
));
6770 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6774 -- Here for the case of a non-static expression, we need a runtime
6775 -- check unless the source type range is guaranteed to be in the
6776 -- range of the target type.
6779 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
6780 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6785 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
6786 if Is_Constrained
(T_Typ
) then
6788 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
6789 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
6791 if Is_Access_Type
(Exptyp
) then
6792 Exptyp
:= Designated_Type
(Exptyp
);
6795 -- String_Literal case. This needs to be handled specially be-
6796 -- cause no index types are available for string literals. The
6797 -- condition is simply:
6799 -- T_Typ'Length = string-literal-length
6801 if Nkind
(Expr_Actual
) = N_String_Literal
then
6804 -- General array case. Here we have a usable actual subtype for
6805 -- the expression, and the condition is built from the two types
6807 -- T_Typ'First < Exptyp'First or else
6808 -- T_Typ'Last > Exptyp'Last or else
6809 -- T_Typ'First(1) < Exptyp'First(1) or else
6810 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6813 elsif Is_Constrained
(Exptyp
) then
6815 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6821 L_Index
:= First_Index
(T_Typ
);
6822 R_Index
:= First_Index
(Exptyp
);
6824 for Indx
in 1 .. Ndims
loop
6825 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
6827 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
6829 -- Deal with compile time length check. Note that we
6830 -- skip this in the access case, because the access
6831 -- value may be null, so we cannot know statically.
6834 Subtypes_Statically_Match
6835 (Etype
(L_Index
), Etype
(R_Index
))
6837 -- If the target type is constrained then we
6838 -- have to check for exact equality of bounds
6839 -- (required for qualified expressions).
6841 if Is_Constrained
(T_Typ
) then
6844 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
6847 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
6858 -- Handle cases where we do not get a usable actual subtype that
6859 -- is constrained. This happens for example in the function call
6860 -- and explicit dereference cases. In these cases, we have to get
6861 -- the length or range from the expression itself, making sure we
6862 -- do not evaluate it more than once.
6864 -- Here Ck_Node is the original expression, or more properly the
6865 -- result of applying Duplicate_Expr to the original tree,
6866 -- forcing the result to be a name.
6870 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6873 -- Build the condition for the explicit dereference case
6875 for Indx
in 1 .. Ndims
loop
6877 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
6884 -- For a conversion to an unconstrained array type, generate an
6885 -- Action to check that the bounds of the source value are within
6886 -- the constraints imposed by the target type (RM 4.6(38)). No
6887 -- check is needed for a conversion to an access to unconstrained
6888 -- array type, as 4.6(24.15/2) requires the designated subtypes
6889 -- of the two access types to statically match.
6891 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
6892 and then not Do_Access
6895 Opnd_Index
: Node_Id
;
6896 Targ_Index
: Node_Id
;
6897 Opnd_Range
: Node_Id
;
6900 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
6901 Targ_Index
:= First_Index
(T_Typ
);
6903 while Present
(Opnd_Index
) loop
6905 -- If the index is a range, use its bounds. If it is an
6906 -- entity (as will be the case if it is a named subtype
6907 -- or an itype created for a slice) retrieve its range.
6909 if Is_Entity_Name
(Opnd_Index
)
6910 and then Is_Type
(Entity
(Opnd_Index
))
6912 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
6914 Opnd_Range
:= Opnd_Index
;
6917 if Nkind
(Opnd_Range
) = N_Range
then
6919 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
))
6922 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
))
6926 -- If null range, no check needed
6929 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
6931 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
6933 Expr_Value
(High_Bound
(Opnd_Range
)) <
6934 Expr_Value
(Low_Bound
(Opnd_Range
))
6938 elsif Is_Out_Of_Range
6939 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
))
6942 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
))
6945 (Compile_Time_Constraint_Error
6946 (Wnode
, "value out of range of}?", T_Typ
));
6952 (Opnd_Range
, Etype
(Targ_Index
)));
6956 Next_Index
(Opnd_Index
);
6957 Next_Index
(Targ_Index
);
6964 -- Construct the test and insert into the tree
6966 if Present
(Cond
) then
6968 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
6972 (Make_Raise_Constraint_Error
(Loc
,
6974 Reason
=> CE_Range_Check_Failed
));
6978 end Selected_Range_Checks
;
6980 -------------------------------
6981 -- Storage_Checks_Suppressed --
6982 -------------------------------
6984 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6986 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6987 return Is_Check_Suppressed
(E
, Storage_Check
);
6989 return Scope_Suppress
(Storage_Check
);
6991 end Storage_Checks_Suppressed
;
6993 ---------------------------
6994 -- Tag_Checks_Suppressed --
6995 ---------------------------
6997 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7000 if Kill_Tag_Checks
(E
) then
7002 elsif Checks_May_Be_Suppressed
(E
) then
7003 return Is_Check_Suppressed
(E
, Tag_Check
);
7007 return Scope_Suppress
(Tag_Check
);
7008 end Tag_Checks_Suppressed
;
7010 --------------------------
7011 -- Validity_Check_Range --
7012 --------------------------
7014 procedure Validity_Check_Range
(N
: Node_Id
) is
7016 if Validity_Checks_On
and Validity_Check_Operands
then
7017 if Nkind
(N
) = N_Range
then
7018 Ensure_Valid
(Low_Bound
(N
));
7019 Ensure_Valid
(High_Bound
(N
));
7022 end Validity_Check_Range
;
7024 --------------------------------
7025 -- Validity_Checks_Suppressed --
7026 --------------------------------
7028 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7030 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7031 return Is_Check_Suppressed
(E
, Validity_Check
);
7033 return Scope_Suppress
(Validity_Check
);
7035 end Validity_Checks_Suppressed
;