* config/alpha/alpha.c, config/alpha/alpha.md,
[official-gcc.git] / gcc / ada / checks.adb
blobb5b30f79180c41a9a4db3a654a95047c5c18cec9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- C H E C K S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
10 -- --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch2; use Exp_Ch2;
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;
37 with Lib; use Lib;
38 with Nlists; use Nlists;
39 with Nmake; use Nmake;
40 with Opt; use Opt;
41 with Output; use Output;
42 with Restrict; use Restrict;
43 with Rident; use Rident;
44 with Rtsfind; use Rtsfind;
45 with Sem; use Sem;
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
69 -- execution anyway.
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
140 Killed : Boolean;
141 -- Set True if entry is killed by Kill_Checks
143 Entity : Entity_Id;
144 -- The entity involved in the expression that is checked
146 Offset : Uint;
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
162 -- saved check).
163 end record;
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
194 (Ck_Node : Node_Id;
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
202 (Ck_Node : Node_Id;
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
212 (Ck_Node : Node_Id;
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
219 -- to be done.
221 type Check_Type is (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
234 -- ...
235 -- end if;
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,
239 -- such as:
241 -- if Var = 0 or Q / Var > 12 then
242 -- ...
243 -- end if;
245 procedure Find_Check
246 (Expr : Node_Id;
247 Check_Type : Character;
248 Target_Type : Entity_Id;
249 Entry_OK : out Boolean;
250 Check_Num : out Nat;
251 Ent : out Entity_Id;
252 Ofs : out Uint);
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
263 -- is located.
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
274 -- bound itself.
275 -- To be cleaned up???
277 function Guard_Access
278 (Cond : Node_Id;
279 Loc : Source_Ptr;
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
296 (Ck_Node : Node_Id;
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
305 (Ck_Node : Node_Id;
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
318 begin
319 if Present (E) and then Checks_May_Be_Suppressed (E) then
320 return Is_Check_Suppressed (E, Access_Check);
321 else
322 return Scope_Suppress (Access_Check);
323 end if;
324 end Access_Checks_Suppressed;
326 -------------------------------------
327 -- Accessibility_Checks_Suppressed --
328 -------------------------------------
330 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
331 begin
332 if Present (E) and then Checks_May_Be_Suppressed (E) then
333 return Is_Check_Suppressed (E, Accessibility_Check);
334 else
335 return Scope_Suppress (Accessibility_Check);
336 end if;
337 end Accessibility_Checks_Suppressed;
339 ---------------------------------
340 -- Alignment_Checks_Suppressed --
341 ---------------------------------
343 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
344 begin
345 if Present (E) and then Checks_May_Be_Suppressed (E) then
346 return Is_Check_Suppressed (E, Alignment_Check);
347 else
348 return Scope_Suppress (Alignment_Check);
349 end if;
350 end Alignment_Checks_Suppressed;
352 -------------------------
353 -- Append_Range_Checks --
354 -------------------------
356 procedure Append_Range_Checks
357 (Checks : Check_Result;
358 Stmts : List_Id;
359 Suppress_Typ : Entity_Id;
360 Static_Sloc : Source_Ptr;
361 Flag_Node : Node_Id)
363 Internal_Flag_Node : constant Node_Id := Flag_Node;
364 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
366 Checks_On : constant Boolean :=
367 (not Index_Checks_Suppressed (Suppress_Typ))
368 or else
369 (not Range_Checks_Suppressed (Suppress_Typ));
371 begin
372 -- For now we just return if Checks_On is false, however this should
373 -- be enhanced to check for an always True value in the condition
374 -- and to generate a compilation warning???
376 if not Checks_On then
377 return;
378 end if;
380 for J in 1 .. 2 loop
381 exit when No (Checks (J));
383 if Nkind (Checks (J)) = N_Raise_Constraint_Error
384 and then Present (Condition (Checks (J)))
385 then
386 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
387 Append_To (Stmts, Checks (J));
388 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
389 end if;
391 else
392 Append_To
393 (Stmts,
394 Make_Raise_Constraint_Error (Internal_Static_Sloc,
395 Reason => CE_Range_Check_Failed));
396 end if;
397 end loop;
398 end Append_Range_Checks;
400 ------------------------
401 -- Apply_Access_Check --
402 ------------------------
404 procedure Apply_Access_Check (N : Node_Id) is
405 P : constant Node_Id := Prefix (N);
407 begin
408 -- We do not need checks if we are not generating code (i.e. the
409 -- expander is not active). This is not just an optimization, there
410 -- are cases (e.g. with pragma Debug) where generating the checks
411 -- can cause real trouble).
413 if not Expander_Active then
414 return;
415 end if;
417 -- No check if short circuiting makes check unnecessary
419 if not Check_Needed (P, Access_Check) then
420 return;
421 end if;
423 -- Otherwise go ahead and install the check
425 Install_Null_Excluding_Check (P);
426 end Apply_Access_Check;
428 -------------------------------
429 -- Apply_Accessibility_Check --
430 -------------------------------
432 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
433 Loc : constant Source_Ptr := Sloc (N);
434 Param_Ent : constant Entity_Id := Param_Entity (N);
435 Param_Level : Node_Id;
436 Type_Level : Node_Id;
438 begin
439 if Inside_A_Generic then
440 return;
442 -- Only apply the run-time check if the access parameter
443 -- has an associated extra access level parameter and
444 -- when the level of the type is less deep than the level
445 -- of the access parameter.
447 elsif Present (Param_Ent)
448 and then Present (Extra_Accessibility (Param_Ent))
449 and then UI_Gt (Object_Access_Level (N),
450 Type_Access_Level (Typ))
451 and then not Accessibility_Checks_Suppressed (Param_Ent)
452 and then not Accessibility_Checks_Suppressed (Typ)
453 then
454 Param_Level :=
455 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
457 Type_Level :=
458 Make_Integer_Literal (Loc, Type_Access_Level (Typ));
460 -- Raise Program_Error if the accessibility level of the the access
461 -- parameter is deeper than the level of the target access type.
463 Insert_Action (N,
464 Make_Raise_Program_Error (Loc,
465 Condition =>
466 Make_Op_Gt (Loc,
467 Left_Opnd => Param_Level,
468 Right_Opnd => Type_Level),
469 Reason => PE_Accessibility_Check_Failed));
471 Analyze_And_Resolve (N);
472 end if;
473 end Apply_Accessibility_Check;
475 --------------------------------
476 -- Apply_Address_Clause_Check --
477 --------------------------------
479 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
480 AC : constant Node_Id := Address_Clause (E);
481 Loc : constant Source_Ptr := Sloc (AC);
482 Typ : constant Entity_Id := Etype (E);
483 Aexp : constant Node_Id := Expression (AC);
485 Expr : Node_Id;
486 -- Address expression (not necessarily the same as Aexp, for example
487 -- when Aexp is a reference to a constant, in which case Expr gets
488 -- reset to reference the value expression of the constant.
490 Size_Warning_Output : Boolean := False;
491 -- If we output a size warning we set this True, to stop generating
492 -- what is likely to be an unuseful redundant alignment warning.
494 procedure Compile_Time_Bad_Alignment;
495 -- Post error warnings when alignment is known to be incompatible. Note
496 -- that we do not go as far as inserting a raise of Program_Error since
497 -- this is an erroneous case, and it may happen that we are lucky and an
498 -- underaligned address turns out to be OK after all. Also this warning
499 -- is suppressed if we already complained about the size.
501 --------------------------------
502 -- Compile_Time_Bad_Alignment --
503 --------------------------------
505 procedure Compile_Time_Bad_Alignment is
506 begin
507 if not Size_Warning_Output
508 and then Address_Clause_Overlay_Warnings
509 then
510 Error_Msg_FE
511 ("?specified address for& may be inconsistent with alignment ",
512 Aexp, E);
513 Error_Msg_FE
514 ("\?program execution may be erroneous ('R'M 13.3(27))",
515 Aexp, E);
516 end if;
517 end Compile_Time_Bad_Alignment;
519 -- Start of processing for Apply_Address_Check
521 begin
522 -- First obtain expression from address clause
524 Expr := Expression (AC);
526 -- The following loop digs for the real expression to use in the check
528 loop
529 -- For constant, get constant expression
531 if Is_Entity_Name (Expr)
532 and then Ekind (Entity (Expr)) = E_Constant
533 then
534 Expr := Constant_Value (Entity (Expr));
536 -- For unchecked conversion, get result to convert
538 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
539 Expr := Expression (Expr);
541 -- For (common case) of To_Address call, get argument
543 elsif Nkind (Expr) = N_Function_Call
544 and then Is_Entity_Name (Name (Expr))
545 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
546 then
547 Expr := First (Parameter_Associations (Expr));
549 if Nkind (Expr) = N_Parameter_Association then
550 Expr := Explicit_Actual_Parameter (Expr);
551 end if;
553 -- We finally have the real expression
555 else
556 exit;
557 end if;
558 end loop;
560 -- Output a warning if we have the situation of
562 -- for X'Address use Y'Address
564 -- and X and Y both have known object sizes, and Y is smaller than X
566 if Nkind (Expr) = N_Attribute_Reference
567 and then Attribute_Name (Expr) = Name_Address
568 and then Is_Entity_Name (Prefix (Expr))
569 then
570 declare
571 Exp_Ent : constant Entity_Id := Entity (Prefix (Expr));
572 Obj_Size : Uint := No_Uint;
573 Exp_Size : Uint := No_Uint;
575 begin
576 if Known_Esize (E) then
577 Obj_Size := Esize (E);
578 elsif Known_Esize (Etype (E)) then
579 Obj_Size := Esize (Etype (E));
580 end if;
582 if Known_Esize (Exp_Ent) then
583 Exp_Size := Esize (Exp_Ent);
584 elsif Known_Esize (Etype (Exp_Ent)) then
585 Exp_Size := Esize (Etype (Exp_Ent));
586 end if;
588 if Obj_Size /= No_Uint
589 and then Exp_Size /= No_Uint
590 and then Obj_Size > Exp_Size
591 and then not Warnings_Off (E)
592 then
593 if Address_Clause_Overlay_Warnings then
594 Error_Msg_FE
595 ("?& overlays smaller object", Aexp, E);
596 Error_Msg_FE
597 ("\?program execution may be erroneous", Aexp, E);
598 Size_Warning_Output := True;
599 end if;
600 end if;
601 end;
602 end if;
604 -- See if alignment check needed. Note that we never need a check if the
605 -- maximum alignment is one, since the check will always succeed.
607 -- Note: we do not check for checks suppressed here, since that check
608 -- was done in Sem_Ch13 when the address clause was proceeds. We are
609 -- only called if checks were not suppressed. The reason for this is
610 -- that we have to delay the call to Apply_Alignment_Check till freeze
611 -- time (so that all types etc are elaborated), but we have to check
612 -- the status of check suppressing at the point of the address clause.
614 if No (AC)
615 or else not Check_Address_Alignment (AC)
616 or else Maximum_Alignment = 1
617 then
618 return;
619 end if;
621 -- See if we know that Expr is a bad alignment at compile time
623 if Compile_Time_Known_Value (Expr)
624 and then (Known_Alignment (E) or else Known_Alignment (Typ))
625 then
626 declare
627 AL : Uint := Alignment (Typ);
629 begin
630 -- The object alignment might be more restrictive than the
631 -- type alignment.
633 if Known_Alignment (E) then
634 AL := Alignment (E);
635 end if;
637 if Expr_Value (Expr) mod AL /= 0 then
638 Compile_Time_Bad_Alignment;
639 else
640 return;
641 end if;
642 end;
644 -- If the expression has the form X'Address, then we can find out if
645 -- the object X has an alignment that is compatible with the object E.
647 elsif Nkind (Expr) = N_Attribute_Reference
648 and then Attribute_Name (Expr) = Name_Address
649 then
650 declare
651 AR : constant Alignment_Result :=
652 Has_Compatible_Alignment (E, Prefix (Expr));
653 begin
654 if AR = Known_Compatible then
655 return;
656 elsif AR = Known_Incompatible then
657 Compile_Time_Bad_Alignment;
658 end if;
659 end;
660 end if;
662 -- Here we do not know if the value is acceptable. Stricly we don't have
663 -- to do anything, since if the alignment is bad, we have an erroneous
664 -- program. However we are allowed to check for erroneous conditions and
665 -- we decide to do this by default if the check is not suppressed.
667 -- However, don't do the check if elaboration code is unwanted
669 if Restriction_Active (No_Elaboration_Code) then
670 return;
672 -- Generate a check to raise PE if alignment may be inappropriate
674 else
675 -- If the original expression is a non-static constant, use the
676 -- name of the constant itself rather than duplicating its
677 -- defining expression, which was extracted above..
679 if Is_Entity_Name (Expression (AC))
680 and then Ekind (Entity (Expression (AC))) = E_Constant
681 and then
682 Nkind (Parent (Entity (Expression (AC)))) = N_Object_Declaration
683 then
684 Expr := New_Copy_Tree (Expression (AC));
685 else
686 Remove_Side_Effects (Expr);
687 end if;
689 Insert_After_And_Analyze (N,
690 Make_Raise_Program_Error (Loc,
691 Condition =>
692 Make_Op_Ne (Loc,
693 Left_Opnd =>
694 Make_Op_Mod (Loc,
695 Left_Opnd =>
696 Unchecked_Convert_To
697 (RTE (RE_Integer_Address), Expr),
698 Right_Opnd =>
699 Make_Attribute_Reference (Loc,
700 Prefix => New_Occurrence_Of (E, Loc),
701 Attribute_Name => Name_Alignment)),
702 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
703 Reason => PE_Misaligned_Address_Value),
704 Suppress => All_Checks);
705 return;
706 end if;
708 exception
709 -- If we have some missing run time component in configurable run time
710 -- mode then just skip the check (it is not required in any case).
712 when RE_Not_Available =>
713 return;
714 end Apply_Address_Clause_Check;
716 -------------------------------------
717 -- Apply_Arithmetic_Overflow_Check --
718 -------------------------------------
720 -- This routine is called only if the type is an integer type, and
721 -- a software arithmetic overflow check must be performed for op
722 -- (add, subtract, multiply). The check is performed only if
723 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
724 -- is set. In this case we expand the operation into a more complex
725 -- sequence of tests that ensures that overflow is properly caught.
727 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
728 Loc : constant Source_Ptr := Sloc (N);
729 Typ : constant Entity_Id := Etype (N);
730 Rtyp : constant Entity_Id := Root_Type (Typ);
731 Siz : constant Int := UI_To_Int (Esize (Rtyp));
732 Dsiz : constant Int := Siz * 2;
733 Opnod : Node_Id;
734 Ctyp : Entity_Id;
735 Opnd : Node_Id;
736 Cent : RE_Id;
738 begin
739 -- Skip this if overflow checks are done in back end, or the overflow
740 -- flag is not set anyway, or we are not doing code expansion.
742 if Backend_Overflow_Checks_On_Target
743 or else not Do_Overflow_Check (N)
744 or else not Expander_Active
745 then
746 return;
747 end if;
749 -- Otherwise, we generate the full general code for front end overflow
750 -- detection, which works by doing arithmetic in a larger type:
752 -- x op y
754 -- is expanded into
756 -- Typ (Checktyp (x) op Checktyp (y));
758 -- where Typ is the type of the original expression, and Checktyp is
759 -- an integer type of sufficient length to hold the largest possible
760 -- result.
762 -- In the case where check type exceeds the size of Long_Long_Integer,
763 -- we use a different approach, expanding to:
765 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
767 -- where xxx is Add, Multiply or Subtract as appropriate
769 -- Find check type if one exists
771 if Dsiz <= Standard_Integer_Size then
772 Ctyp := Standard_Integer;
774 elsif Dsiz <= Standard_Long_Long_Integer_Size then
775 Ctyp := Standard_Long_Long_Integer;
777 -- No check type exists, use runtime call
779 else
780 if Nkind (N) = N_Op_Add then
781 Cent := RE_Add_With_Ovflo_Check;
783 elsif Nkind (N) = N_Op_Multiply then
784 Cent := RE_Multiply_With_Ovflo_Check;
786 else
787 pragma Assert (Nkind (N) = N_Op_Subtract);
788 Cent := RE_Subtract_With_Ovflo_Check;
789 end if;
791 Rewrite (N,
792 OK_Convert_To (Typ,
793 Make_Function_Call (Loc,
794 Name => New_Reference_To (RTE (Cent), Loc),
795 Parameter_Associations => New_List (
796 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
797 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
799 Analyze_And_Resolve (N, Typ);
800 return;
801 end if;
803 -- If we fall through, we have the case where we do the arithmetic in
804 -- the next higher type and get the check by conversion. In these cases
805 -- Ctyp is set to the type to be used as the check type.
807 Opnod := Relocate_Node (N);
809 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
811 Analyze (Opnd);
812 Set_Etype (Opnd, Ctyp);
813 Set_Analyzed (Opnd, True);
814 Set_Left_Opnd (Opnod, Opnd);
816 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
818 Analyze (Opnd);
819 Set_Etype (Opnd, Ctyp);
820 Set_Analyzed (Opnd, True);
821 Set_Right_Opnd (Opnod, Opnd);
823 -- The type of the operation changes to the base type of the check
824 -- type, and we reset the overflow check indication, since clearly
825 -- no overflow is possible now that we are using a double length
826 -- type. We also set the Analyzed flag to avoid a recursive attempt
827 -- to expand the node.
829 Set_Etype (Opnod, Base_Type (Ctyp));
830 Set_Do_Overflow_Check (Opnod, False);
831 Set_Analyzed (Opnod, True);
833 -- Now build the outer conversion
835 Opnd := OK_Convert_To (Typ, Opnod);
836 Analyze (Opnd);
837 Set_Etype (Opnd, Typ);
839 -- In the discrete type case, we directly generate the range check
840 -- for the outer operand. This range check will implement the required
841 -- overflow check.
843 if Is_Discrete_Type (Typ) then
844 Rewrite (N, Opnd);
845 Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
847 -- For other types, we enable overflow checking on the conversion,
848 -- after setting the node as analyzed to prevent recursive attempts
849 -- to expand the conversion node.
851 else
852 Set_Analyzed (Opnd, True);
853 Enable_Overflow_Check (Opnd);
854 Rewrite (N, Opnd);
855 end if;
857 exception
858 when RE_Not_Available =>
859 return;
860 end Apply_Arithmetic_Overflow_Check;
862 ----------------------------
863 -- Apply_Array_Size_Check --
864 ----------------------------
866 -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
867 -- is computed in 32 bits without an overflow check. That's a real
868 -- problem for Ada. So what we do in GNAT 3 is to approximate the
869 -- size of an array by manually multiplying the element size by the
870 -- number of elements, and comparing that against the allowed limits.
872 -- In GNAT 5, the size in byte is still computed in 32 bits without
873 -- an overflow check in the dynamic case, but the size in bits is
874 -- computed in 64 bits. We assume that's good enough, and we do not
875 -- bother to generate any front end test.
877 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
878 Loc : constant Source_Ptr := Sloc (N);
879 Ctyp : constant Entity_Id := Component_Type (Typ);
880 Ent : constant Entity_Id := Defining_Identifier (N);
881 Decl : Node_Id;
882 Lo : Node_Id;
883 Hi : Node_Id;
884 Lob : Uint;
885 Hib : Uint;
886 Siz : Uint;
887 Xtyp : Entity_Id;
888 Indx : Node_Id;
889 Sizx : Node_Id;
890 Code : Node_Id;
892 Static : Boolean := True;
893 -- Set false if any index subtye bound is non-static
895 Umark : constant Uintp.Save_Mark := Uintp.Mark;
896 -- We can throw away all the Uint computations here, since they are
897 -- done only to generate boolean test results.
899 Check_Siz : Uint;
900 -- Size to check against
902 function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
903 -- Determines if Decl is an address clause or Import/Interface pragma
904 -- that references the defining identifier of the current declaration.
906 --------------------------
907 -- Is_Address_Or_Import --
908 --------------------------
910 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
911 begin
912 if Nkind (Decl) = N_At_Clause then
913 return Chars (Identifier (Decl)) = Chars (Ent);
915 elsif Nkind (Decl) = N_Attribute_Definition_Clause then
916 return
917 Chars (Decl) = Name_Address
918 and then
919 Nkind (Name (Decl)) = N_Identifier
920 and then
921 Chars (Name (Decl)) = Chars (Ent);
923 elsif Nkind (Decl) = N_Pragma then
924 if (Chars (Decl) = Name_Import
925 or else
926 Chars (Decl) = Name_Interface)
927 and then Present (Pragma_Argument_Associations (Decl))
928 then
929 declare
930 F : constant Node_Id :=
931 First (Pragma_Argument_Associations (Decl));
933 begin
934 return
935 Present (F)
936 and then
937 Present (Next (F))
938 and then
939 Nkind (Expression (Next (F))) = N_Identifier
940 and then
941 Chars (Expression (Next (F))) = Chars (Ent);
942 end;
944 else
945 return False;
946 end if;
948 else
949 return False;
950 end if;
951 end Is_Address_Or_Import;
953 -- Start of processing for Apply_Array_Size_Check
955 begin
956 -- Do size check on local arrays. We only need this in the GCC 2
957 -- case, since in GCC 3, we expect the back end to properly handle
958 -- things. This routine can be removed when we baseline GNAT 3.
960 if Opt.GCC_Version >= 3 then
961 return;
962 end if;
964 -- No need for a check if not expanding
966 if not Expander_Active then
967 return;
968 end if;
970 -- No need for a check if checks are suppressed
972 if Storage_Checks_Suppressed (Typ) then
973 return;
974 end if;
976 -- It is pointless to insert this check inside an init proc, because
977 -- that's too late, we have already built the object to be the right
978 -- size, and if it's too large, too bad!
980 if Inside_Init_Proc then
981 return;
982 end if;
984 -- Look head for pragma interface/import or address clause applying
985 -- to this entity. If found, we suppress the check entirely. For now
986 -- we only look ahead 20 declarations to stop this becoming too slow
987 -- Note that eventually this whole routine gets moved to gigi.
989 Decl := N;
990 for Ctr in 1 .. 20 loop
991 Next (Decl);
992 exit when No (Decl);
994 if Is_Address_Or_Import (Decl) then
995 return;
996 end if;
997 end loop;
999 -- First step is to calculate the maximum number of elements. For
1000 -- this calculation, we use the actual size of the subtype if it is
1001 -- static, and if a bound of a subtype is non-static, we go to the
1002 -- bound of the base type.
1004 Siz := Uint_1;
1005 Indx := First_Index (Typ);
1006 while Present (Indx) loop
1007 Xtyp := Etype (Indx);
1008 Lo := Type_Low_Bound (Xtyp);
1009 Hi := Type_High_Bound (Xtyp);
1011 -- If any bound raises constraint error, we will never get this
1012 -- far, so there is no need to generate any kind of check.
1014 if Raises_Constraint_Error (Lo)
1015 or else
1016 Raises_Constraint_Error (Hi)
1017 then
1018 Uintp.Release (Umark);
1019 return;
1020 end if;
1022 -- Otherwise get bounds values
1024 if Is_Static_Expression (Lo) then
1025 Lob := Expr_Value (Lo);
1026 else
1027 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
1028 Static := False;
1029 end if;
1031 if Is_Static_Expression (Hi) then
1032 Hib := Expr_Value (Hi);
1033 else
1034 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
1035 Static := False;
1036 end if;
1038 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
1039 Next_Index (Indx);
1040 end loop;
1042 -- Compute the limit against which we want to check. For subprograms,
1043 -- where the array will go on the stack, we use 8*2**24, which (in
1044 -- bits) is the size of a 16 megabyte array.
1046 if Is_Subprogram (Scope (Ent)) then
1047 Check_Siz := Uint_2 ** 27;
1048 else
1049 Check_Siz := Uint_2 ** 31;
1050 end if;
1052 -- If we have all static bounds and Siz is too large, then we know
1053 -- we know we have a storage error right now, so generate message
1055 if Static and then Siz >= Check_Siz then
1056 Insert_Action (N,
1057 Make_Raise_Storage_Error (Loc,
1058 Reason => SE_Object_Too_Large));
1059 Error_Msg_N ("?Storage_Error will be raised at run-time", N);
1060 Uintp.Release (Umark);
1061 return;
1062 end if;
1064 -- Case of component size known at compile time. If the array
1065 -- size is definitely in range, then we do not need a check.
1067 if Known_Esize (Ctyp)
1068 and then Siz * Esize (Ctyp) < Check_Siz
1069 then
1070 Uintp.Release (Umark);
1071 return;
1072 end if;
1074 -- Here if a dynamic check is required
1076 -- What we do is to build an expression for the size of the array,
1077 -- which is computed as the 'Size of the array component, times
1078 -- the size of each dimension.
1080 Uintp.Release (Umark);
1082 Sizx :=
1083 Make_Attribute_Reference (Loc,
1084 Prefix => New_Occurrence_Of (Ctyp, Loc),
1085 Attribute_Name => Name_Size);
1087 Indx := First_Index (Typ);
1088 for J in 1 .. Number_Dimensions (Typ) loop
1089 if Sloc (Etype (Indx)) = Sloc (N) then
1090 Ensure_Defined (Etype (Indx), N);
1091 end if;
1093 Sizx :=
1094 Make_Op_Multiply (Loc,
1095 Left_Opnd => Sizx,
1096 Right_Opnd =>
1097 Make_Attribute_Reference (Loc,
1098 Prefix => New_Occurrence_Of (Typ, Loc),
1099 Attribute_Name => Name_Length,
1100 Expressions => New_List (
1101 Make_Integer_Literal (Loc, J))));
1102 Next_Index (Indx);
1103 end loop;
1105 -- Emit the check
1107 Code :=
1108 Make_Raise_Storage_Error (Loc,
1109 Condition =>
1110 Make_Op_Ge (Loc,
1111 Left_Opnd => Sizx,
1112 Right_Opnd =>
1113 Make_Integer_Literal (Loc,
1114 Intval => Check_Siz)),
1115 Reason => SE_Object_Too_Large);
1117 Set_Size_Check_Code (Defining_Identifier (N), Code);
1118 Insert_Action (N, Code, Suppress => All_Checks);
1119 end Apply_Array_Size_Check;
1121 ----------------------------
1122 -- Apply_Constraint_Check --
1123 ----------------------------
1125 procedure Apply_Constraint_Check
1126 (N : Node_Id;
1127 Typ : Entity_Id;
1128 No_Sliding : Boolean := False)
1130 Desig_Typ : Entity_Id;
1132 begin
1133 if Inside_A_Generic then
1134 return;
1136 elsif Is_Scalar_Type (Typ) then
1137 Apply_Scalar_Range_Check (N, Typ);
1139 elsif Is_Array_Type (Typ) then
1141 -- A useful optimization: an aggregate with only an others clause
1142 -- always has the right bounds.
1144 if Nkind (N) = N_Aggregate
1145 and then No (Expressions (N))
1146 and then Nkind
1147 (First (Choices (First (Component_Associations (N)))))
1148 = N_Others_Choice
1149 then
1150 return;
1151 end if;
1153 if Is_Constrained (Typ) then
1154 Apply_Length_Check (N, Typ);
1156 if No_Sliding then
1157 Apply_Range_Check (N, Typ);
1158 end if;
1159 else
1160 Apply_Range_Check (N, Typ);
1161 end if;
1163 elsif (Is_Record_Type (Typ)
1164 or else Is_Private_Type (Typ))
1165 and then Has_Discriminants (Base_Type (Typ))
1166 and then Is_Constrained (Typ)
1167 then
1168 Apply_Discriminant_Check (N, Typ);
1170 elsif Is_Access_Type (Typ) then
1172 Desig_Typ := Designated_Type (Typ);
1174 -- No checks necessary if expression statically null
1176 if Nkind (N) = N_Null then
1177 null;
1179 -- No sliding possible on access to arrays
1181 elsif Is_Array_Type (Desig_Typ) then
1182 if Is_Constrained (Desig_Typ) then
1183 Apply_Length_Check (N, Typ);
1184 end if;
1186 Apply_Range_Check (N, Typ);
1188 elsif Has_Discriminants (Base_Type (Desig_Typ))
1189 and then Is_Constrained (Desig_Typ)
1190 then
1191 Apply_Discriminant_Check (N, Typ);
1192 end if;
1194 if Can_Never_Be_Null (Typ)
1195 and then not Can_Never_Be_Null (Etype (N))
1196 then
1197 Install_Null_Excluding_Check (N);
1198 end if;
1199 end if;
1200 end Apply_Constraint_Check;
1202 ------------------------------
1203 -- Apply_Discriminant_Check --
1204 ------------------------------
1206 procedure Apply_Discriminant_Check
1207 (N : Node_Id;
1208 Typ : Entity_Id;
1209 Lhs : Node_Id := Empty)
1211 Loc : constant Source_Ptr := Sloc (N);
1212 Do_Access : constant Boolean := Is_Access_Type (Typ);
1213 S_Typ : Entity_Id := Etype (N);
1214 Cond : Node_Id;
1215 T_Typ : Entity_Id;
1217 function Is_Aliased_Unconstrained_Component return Boolean;
1218 -- It is possible for an aliased component to have a nominal
1219 -- unconstrained subtype (through instantiation). If this is a
1220 -- discriminated component assigned in the expansion of an aggregate
1221 -- in an initialization, the check must be suppressed. This unusual
1222 -- situation requires a predicate of its own (see 7503-008).
1224 ----------------------------------------
1225 -- Is_Aliased_Unconstrained_Component --
1226 ----------------------------------------
1228 function Is_Aliased_Unconstrained_Component return Boolean is
1229 Comp : Entity_Id;
1230 Pref : Node_Id;
1232 begin
1233 if Nkind (Lhs) /= N_Selected_Component then
1234 return False;
1235 else
1236 Comp := Entity (Selector_Name (Lhs));
1237 Pref := Prefix (Lhs);
1238 end if;
1240 if Ekind (Comp) /= E_Component
1241 or else not Is_Aliased (Comp)
1242 then
1243 return False;
1244 end if;
1246 return not Comes_From_Source (Pref)
1247 and then In_Instance
1248 and then not Is_Constrained (Etype (Comp));
1249 end Is_Aliased_Unconstrained_Component;
1251 -- Start of processing for Apply_Discriminant_Check
1253 begin
1254 if Do_Access then
1255 T_Typ := Designated_Type (Typ);
1256 else
1257 T_Typ := Typ;
1258 end if;
1260 -- Nothing to do if discriminant checks are suppressed or else no code
1261 -- is to be generated
1263 if not Expander_Active
1264 or else Discriminant_Checks_Suppressed (T_Typ)
1265 then
1266 return;
1267 end if;
1269 -- No discriminant checks necessary for an access when expression
1270 -- is statically Null. This is not only an optimization, this is
1271 -- fundamental because otherwise discriminant checks may be generated
1272 -- in init procs for types containing an access to a not-yet-frozen
1273 -- record, causing a deadly forward reference.
1275 -- Also, if the expression is of an access type whose designated
1276 -- type is incomplete, then the access value must be null and
1277 -- we suppress the check.
1279 if Nkind (N) = N_Null then
1280 return;
1282 elsif Is_Access_Type (S_Typ) then
1283 S_Typ := Designated_Type (S_Typ);
1285 if Ekind (S_Typ) = E_Incomplete_Type then
1286 return;
1287 end if;
1288 end if;
1290 -- If an assignment target is present, then we need to generate the
1291 -- actual subtype if the target is a parameter or aliased object with
1292 -- an unconstrained nominal subtype.
1294 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1295 -- subtype to the parameter and dereference cases, since other aliased
1296 -- objects are unconstrained (unless the nominal subtype is explicitly
1297 -- constrained). (But we also need to test for renamings???)
1299 if Present (Lhs)
1300 and then (Present (Param_Entity (Lhs))
1301 or else (Ada_Version < Ada_05
1302 and then not Is_Constrained (T_Typ)
1303 and then Is_Aliased_View (Lhs)
1304 and then not Is_Aliased_Unconstrained_Component)
1305 or else (Ada_Version >= Ada_05
1306 and then not Is_Constrained (T_Typ)
1307 and then Nkind (Lhs) = N_Explicit_Dereference
1308 and then Nkind (Original_Node (Lhs)) /=
1309 N_Function_Call))
1310 then
1311 T_Typ := Get_Actual_Subtype (Lhs);
1312 end if;
1314 -- Nothing to do if the type is unconstrained (this is the case
1315 -- where the actual subtype in the RM sense of N is unconstrained
1316 -- and no check is required).
1318 if not Is_Constrained (T_Typ) then
1319 return;
1321 -- Ada 2005: nothing to do if the type is one for which there is a
1322 -- partial view that is constrained.
1324 elsif Ada_Version >= Ada_05
1325 and then Has_Constrained_Partial_View (Base_Type (T_Typ))
1326 then
1327 return;
1328 end if;
1330 -- Nothing to do if the type is an Unchecked_Union
1332 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1333 return;
1334 end if;
1336 -- Suppress checks if the subtypes are the same.
1337 -- the check must be preserved in an assignment to a formal, because
1338 -- the constraint is given by the actual.
1340 if Nkind (Original_Node (N)) /= N_Allocator
1341 and then (No (Lhs)
1342 or else not Is_Entity_Name (Lhs)
1343 or else No (Param_Entity (Lhs)))
1344 then
1345 if (Etype (N) = Typ
1346 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1347 and then not Is_Aliased_View (Lhs)
1348 then
1349 return;
1350 end if;
1352 -- We can also eliminate checks on allocators with a subtype mark
1353 -- that coincides with the context type. The context type may be a
1354 -- subtype without a constraint (common case, a generic actual).
1356 elsif Nkind (Original_Node (N)) = N_Allocator
1357 and then Is_Entity_Name (Expression (Original_Node (N)))
1358 then
1359 declare
1360 Alloc_Typ : constant Entity_Id :=
1361 Entity (Expression (Original_Node (N)));
1363 begin
1364 if Alloc_Typ = T_Typ
1365 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1366 and then Is_Entity_Name (
1367 Subtype_Indication (Parent (T_Typ)))
1368 and then Alloc_Typ = Base_Type (T_Typ))
1370 then
1371 return;
1372 end if;
1373 end;
1374 end if;
1376 -- See if we have a case where the types are both constrained, and
1377 -- all the constraints are constants. In this case, we can do the
1378 -- check successfully at compile time.
1380 -- We skip this check for the case where the node is a rewritten`
1381 -- allocator, because it already carries the context subtype, and
1382 -- extracting the discriminants from the aggregate is messy.
1384 if Is_Constrained (S_Typ)
1385 and then Nkind (Original_Node (N)) /= N_Allocator
1386 then
1387 declare
1388 DconT : Elmt_Id;
1389 Discr : Entity_Id;
1390 DconS : Elmt_Id;
1391 ItemS : Node_Id;
1392 ItemT : Node_Id;
1394 begin
1395 -- S_Typ may not have discriminants in the case where it is a
1396 -- private type completed by a default discriminated type. In
1397 -- that case, we need to get the constraints from the
1398 -- underlying_type. If the underlying type is unconstrained (i.e.
1399 -- has no default discriminants) no check is needed.
1401 if Has_Discriminants (S_Typ) then
1402 Discr := First_Discriminant (S_Typ);
1403 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1405 else
1406 Discr := First_Discriminant (Underlying_Type (S_Typ));
1407 DconS :=
1408 First_Elmt
1409 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1411 if No (DconS) then
1412 return;
1413 end if;
1415 -- A further optimization: if T_Typ is derived from S_Typ
1416 -- without imposing a constraint, no check is needed.
1418 if Nkind (Original_Node (Parent (T_Typ))) =
1419 N_Full_Type_Declaration
1420 then
1421 declare
1422 Type_Def : constant Node_Id :=
1423 Type_Definition
1424 (Original_Node (Parent (T_Typ)));
1425 begin
1426 if Nkind (Type_Def) = N_Derived_Type_Definition
1427 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1428 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1429 then
1430 return;
1431 end if;
1432 end;
1433 end if;
1434 end if;
1436 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
1438 while Present (Discr) loop
1439 ItemS := Node (DconS);
1440 ItemT := Node (DconT);
1442 exit when
1443 not Is_OK_Static_Expression (ItemS)
1444 or else
1445 not Is_OK_Static_Expression (ItemT);
1447 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1448 if Do_Access then -- needs run-time check.
1449 exit;
1450 else
1451 Apply_Compile_Time_Constraint_Error
1452 (N, "incorrect value for discriminant&?",
1453 CE_Discriminant_Check_Failed, Ent => Discr);
1454 return;
1455 end if;
1456 end if;
1458 Next_Elmt (DconS);
1459 Next_Elmt (DconT);
1460 Next_Discriminant (Discr);
1461 end loop;
1463 if No (Discr) then
1464 return;
1465 end if;
1466 end;
1467 end if;
1469 -- Here we need a discriminant check. First build the expression
1470 -- for the comparisons of the discriminants:
1472 -- (n.disc1 /= typ.disc1) or else
1473 -- (n.disc2 /= typ.disc2) or else
1474 -- ...
1475 -- (n.discn /= typ.discn)
1477 Cond := Build_Discriminant_Checks (N, T_Typ);
1479 -- If Lhs is set and is a parameter, then the condition is
1480 -- guarded by: lhs'constrained and then (condition built above)
1482 if Present (Param_Entity (Lhs)) then
1483 Cond :=
1484 Make_And_Then (Loc,
1485 Left_Opnd =>
1486 Make_Attribute_Reference (Loc,
1487 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1488 Attribute_Name => Name_Constrained),
1489 Right_Opnd => Cond);
1490 end if;
1492 if Do_Access then
1493 Cond := Guard_Access (Cond, Loc, N);
1494 end if;
1496 Insert_Action (N,
1497 Make_Raise_Constraint_Error (Loc,
1498 Condition => Cond,
1499 Reason => CE_Discriminant_Check_Failed));
1500 end Apply_Discriminant_Check;
1502 ------------------------
1503 -- Apply_Divide_Check --
1504 ------------------------
1506 procedure Apply_Divide_Check (N : Node_Id) is
1507 Loc : constant Source_Ptr := Sloc (N);
1508 Typ : constant Entity_Id := Etype (N);
1509 Left : constant Node_Id := Left_Opnd (N);
1510 Right : constant Node_Id := Right_Opnd (N);
1512 LLB : Uint;
1513 Llo : Uint;
1514 Lhi : Uint;
1515 LOK : Boolean;
1516 Rlo : Uint;
1517 Rhi : Uint;
1518 ROK : Boolean;
1520 begin
1521 if Expander_Active
1522 and then not Backend_Divide_Checks_On_Target
1523 and then Check_Needed (Right, Division_Check)
1524 then
1525 Determine_Range (Right, ROK, Rlo, Rhi);
1527 -- See if division by zero possible, and if so generate test. This
1528 -- part of the test is not controlled by the -gnato switch.
1530 if Do_Division_Check (N) then
1531 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1532 Insert_Action (N,
1533 Make_Raise_Constraint_Error (Loc,
1534 Condition =>
1535 Make_Op_Eq (Loc,
1536 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1537 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1538 Reason => CE_Divide_By_Zero));
1539 end if;
1540 end if;
1542 -- Test for extremely annoying case of xxx'First divided by -1
1544 if Do_Overflow_Check (N) then
1545 if Nkind (N) = N_Op_Divide
1546 and then Is_Signed_Integer_Type (Typ)
1547 then
1548 Determine_Range (Left, LOK, Llo, Lhi);
1549 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1551 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1552 and then
1553 ((not LOK) or else (Llo = LLB))
1554 then
1555 Insert_Action (N,
1556 Make_Raise_Constraint_Error (Loc,
1557 Condition =>
1558 Make_And_Then (Loc,
1560 Make_Op_Eq (Loc,
1561 Left_Opnd =>
1562 Duplicate_Subexpr_Move_Checks (Left),
1563 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1565 Make_Op_Eq (Loc,
1566 Left_Opnd =>
1567 Duplicate_Subexpr (Right),
1568 Right_Opnd =>
1569 Make_Integer_Literal (Loc, -1))),
1570 Reason => CE_Overflow_Check_Failed));
1571 end if;
1572 end if;
1573 end if;
1574 end if;
1575 end Apply_Divide_Check;
1577 ----------------------------------
1578 -- Apply_Float_Conversion_Check --
1579 ----------------------------------
1581 -- Let F and I be the source and target types of the conversion.
1582 -- The Ada standard specifies that a floating-point value X is rounded
1583 -- to the nearest integer, with halfway cases being rounded away from
1584 -- zero. The rounded value of X is checked against I'Range.
1586 -- The catch in the above paragraph is that there is no good way
1587 -- to know whether the round-to-integer operation resulted in
1588 -- overflow. A remedy is to perform a range check in the floating-point
1589 -- domain instead, however:
1590 -- (1) The bounds may not be known at compile time
1591 -- (2) The check must take into account possible rounding.
1592 -- (3) The range of type I may not be exactly representable in F.
1593 -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
1594 -- not be in range, depending on the sign of I'First and I'Last.
1595 -- (5) X may be a NaN, which will fail any comparison
1597 -- The following steps take care of these issues converting X:
1598 -- (1) If either I'First or I'Last is not known at compile time, use
1599 -- I'Base instead of I in the next three steps and perform a
1600 -- regular range check against I'Range after conversion.
1601 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1602 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1603 -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
1604 -- take one of the closest floating-point numbers to T, and see if
1605 -- it is in range or not.
1606 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1607 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1608 -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
1609 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1610 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1612 procedure Apply_Float_Conversion_Check
1613 (Ck_Node : Node_Id;
1614 Target_Typ : Entity_Id)
1616 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1617 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1618 Loc : constant Source_Ptr := Sloc (Ck_Node);
1619 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1620 Target_Base : constant Entity_Id := Implementation_Base_Type
1621 (Target_Typ);
1622 Max_Bound : constant Uint := UI_Expon
1623 (Machine_Radix (Expr_Type),
1624 Machine_Mantissa (Expr_Type) - 1) - 1;
1625 -- Largest bound, so bound plus or minus half is a machine number of F
1627 Ifirst,
1628 Ilast : Uint; -- Bounds of integer type
1629 Lo, Hi : Ureal; -- Bounds to check in floating-point domain
1630 Lo_OK,
1631 Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
1633 Lo_Chk,
1634 Hi_Chk : Node_Id; -- Expressions that are False iff check fails
1636 Reason : RT_Exception_Code;
1638 begin
1639 if not Compile_Time_Known_Value (LB)
1640 or not Compile_Time_Known_Value (HB)
1641 then
1642 declare
1643 -- First check that the value falls in the range of the base
1644 -- type, to prevent overflow during conversion and then
1645 -- perform a regular range check against the (dynamic) bounds.
1647 Par : constant Node_Id := Parent (Ck_Node);
1649 pragma Assert (Target_Base /= Target_Typ);
1650 pragma Assert (Nkind (Par) = N_Type_Conversion);
1652 Temp : constant Entity_Id :=
1653 Make_Defining_Identifier (Loc,
1654 Chars => New_Internal_Name ('T'));
1656 begin
1657 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
1658 Set_Etype (Temp, Target_Base);
1660 Insert_Action (Parent (Par),
1661 Make_Object_Declaration (Loc,
1662 Defining_Identifier => Temp,
1663 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
1664 Expression => New_Copy_Tree (Par)),
1665 Suppress => All_Checks);
1667 Insert_Action (Par,
1668 Make_Raise_Constraint_Error (Loc,
1669 Condition =>
1670 Make_Not_In (Loc,
1671 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1672 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
1673 Reason => CE_Range_Check_Failed));
1674 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
1676 return;
1677 end;
1678 end if;
1680 -- Get the bounds of the target type
1682 Ifirst := Expr_Value (LB);
1683 Ilast := Expr_Value (HB);
1685 -- Check against lower bound
1687 if abs (Ifirst) < Max_Bound then
1688 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
1689 Lo_OK := (Ifirst > 0);
1690 else
1691 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
1692 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
1693 end if;
1695 if Lo_OK then
1697 -- Lo_Chk := (X >= Lo)
1699 Lo_Chk := Make_Op_Ge (Loc,
1700 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1701 Right_Opnd => Make_Real_Literal (Loc, Lo));
1703 else
1704 -- Lo_Chk := (X > Lo)
1706 Lo_Chk := Make_Op_Gt (Loc,
1707 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1708 Right_Opnd => Make_Real_Literal (Loc, Lo));
1709 end if;
1711 -- Check against higher bound
1713 if abs (Ilast) < Max_Bound then
1714 Hi := UR_From_Uint (Ilast) + Ureal_Half;
1715 Hi_OK := (Ilast < 0);
1716 else
1717 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
1718 Hi_OK := (Hi <= UR_From_Uint (Ilast));
1719 end if;
1721 if Hi_OK then
1723 -- Hi_Chk := (X <= Hi)
1725 Hi_Chk := Make_Op_Le (Loc,
1726 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1727 Right_Opnd => Make_Real_Literal (Loc, Hi));
1729 else
1730 -- Hi_Chk := (X < Hi)
1732 Hi_Chk := Make_Op_Lt (Loc,
1733 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1734 Right_Opnd => Make_Real_Literal (Loc, Hi));
1735 end if;
1737 -- If the bounds of the target type are the same as those of the
1738 -- base type, the check is an overflow check as a range check is
1739 -- not performed in these cases.
1741 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
1742 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
1743 then
1744 Reason := CE_Overflow_Check_Failed;
1745 else
1746 Reason := CE_Range_Check_Failed;
1747 end if;
1749 -- Raise CE if either conditions does not hold
1751 Insert_Action (Ck_Node,
1752 Make_Raise_Constraint_Error (Loc,
1753 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
1754 Reason => Reason));
1755 end Apply_Float_Conversion_Check;
1757 ------------------------
1758 -- Apply_Length_Check --
1759 ------------------------
1761 procedure Apply_Length_Check
1762 (Ck_Node : Node_Id;
1763 Target_Typ : Entity_Id;
1764 Source_Typ : Entity_Id := Empty)
1766 begin
1767 Apply_Selected_Length_Checks
1768 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1769 end Apply_Length_Check;
1771 -----------------------
1772 -- Apply_Range_Check --
1773 -----------------------
1775 procedure Apply_Range_Check
1776 (Ck_Node : Node_Id;
1777 Target_Typ : Entity_Id;
1778 Source_Typ : Entity_Id := Empty)
1780 begin
1781 Apply_Selected_Range_Checks
1782 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1783 end Apply_Range_Check;
1785 ------------------------------
1786 -- Apply_Scalar_Range_Check --
1787 ------------------------------
1789 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1790 -- flag off if it is already set on.
1792 procedure Apply_Scalar_Range_Check
1793 (Expr : Node_Id;
1794 Target_Typ : Entity_Id;
1795 Source_Typ : Entity_Id := Empty;
1796 Fixed_Int : Boolean := False)
1798 Parnt : constant Node_Id := Parent (Expr);
1799 S_Typ : Entity_Id;
1800 Arr : Node_Id := Empty; -- initialize to prevent warning
1801 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1802 OK : Boolean;
1804 Is_Subscr_Ref : Boolean;
1805 -- Set true if Expr is a subscript
1807 Is_Unconstrained_Subscr_Ref : Boolean;
1808 -- Set true if Expr is a subscript of an unconstrained array. In this
1809 -- case we do not attempt to do an analysis of the value against the
1810 -- range of the subscript, since we don't know the actual subtype.
1812 Int_Real : Boolean;
1813 -- Set to True if Expr should be regarded as a real value
1814 -- even though the type of Expr might be discrete.
1816 procedure Bad_Value;
1817 -- Procedure called if value is determined to be out of range
1819 ---------------
1820 -- Bad_Value --
1821 ---------------
1823 procedure Bad_Value is
1824 begin
1825 Apply_Compile_Time_Constraint_Error
1826 (Expr, "value not in range of}?", CE_Range_Check_Failed,
1827 Ent => Target_Typ,
1828 Typ => Target_Typ);
1829 end Bad_Value;
1831 -- Start of processing for Apply_Scalar_Range_Check
1833 begin
1834 if Inside_A_Generic then
1835 return;
1837 -- Return if check obviously not needed. Note that we do not check
1838 -- for the expander being inactive, since this routine does not
1839 -- insert any code, but it does generate useful warnings sometimes,
1840 -- which we would like even if we are in semantics only mode.
1842 elsif Target_Typ = Any_Type
1843 or else not Is_Scalar_Type (Target_Typ)
1844 or else Raises_Constraint_Error (Expr)
1845 then
1846 return;
1847 end if;
1849 -- Now, see if checks are suppressed
1851 Is_Subscr_Ref :=
1852 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1854 if Is_Subscr_Ref then
1855 Arr := Prefix (Parnt);
1856 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1857 end if;
1859 if not Do_Range_Check (Expr) then
1861 -- Subscript reference. Check for Index_Checks suppressed
1863 if Is_Subscr_Ref then
1865 -- Check array type and its base type
1867 if Index_Checks_Suppressed (Arr_Typ)
1868 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
1869 then
1870 return;
1872 -- Check array itself if it is an entity name
1874 elsif Is_Entity_Name (Arr)
1875 and then Index_Checks_Suppressed (Entity (Arr))
1876 then
1877 return;
1879 -- Check expression itself if it is an entity name
1881 elsif Is_Entity_Name (Expr)
1882 and then Index_Checks_Suppressed (Entity (Expr))
1883 then
1884 return;
1885 end if;
1887 -- All other cases, check for Range_Checks suppressed
1889 else
1890 -- Check target type and its base type
1892 if Range_Checks_Suppressed (Target_Typ)
1893 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
1894 then
1895 return;
1897 -- Check expression itself if it is an entity name
1899 elsif Is_Entity_Name (Expr)
1900 and then Range_Checks_Suppressed (Entity (Expr))
1901 then
1902 return;
1904 -- If Expr is part of an assignment statement, then check
1905 -- left side of assignment if it is an entity name.
1907 elsif Nkind (Parnt) = N_Assignment_Statement
1908 and then Is_Entity_Name (Name (Parnt))
1909 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
1910 then
1911 return;
1912 end if;
1913 end if;
1914 end if;
1916 -- Do not set range checks if they are killed
1918 if Nkind (Expr) = N_Unchecked_Type_Conversion
1919 and then Kill_Range_Check (Expr)
1920 then
1921 return;
1922 end if;
1924 -- Do not set range checks for any values from System.Scalar_Values
1925 -- since the whole idea of such values is to avoid checking them!
1927 if Is_Entity_Name (Expr)
1928 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
1929 then
1930 return;
1931 end if;
1933 -- Now see if we need a check
1935 if No (Source_Typ) then
1936 S_Typ := Etype (Expr);
1937 else
1938 S_Typ := Source_Typ;
1939 end if;
1941 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1942 return;
1943 end if;
1945 Is_Unconstrained_Subscr_Ref :=
1946 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1948 -- Always do a range check if the source type includes infinities
1949 -- and the target type does not include infinities. We do not do
1950 -- this if range checks are killed.
1952 if Is_Floating_Point_Type (S_Typ)
1953 and then Has_Infinities (S_Typ)
1954 and then not Has_Infinities (Target_Typ)
1955 then
1956 Enable_Range_Check (Expr);
1957 end if;
1959 -- Return if we know expression is definitely in the range of
1960 -- the target type as determined by Determine_Range. Right now
1961 -- we only do this for discrete types, and not fixed-point or
1962 -- floating-point types.
1964 -- The additional less-precise tests below catch these cases
1966 -- Note: skip this if we are given a source_typ, since the point
1967 -- of supplying a Source_Typ is to stop us looking at the expression.
1968 -- could sharpen this test to be out parameters only ???
1970 if Is_Discrete_Type (Target_Typ)
1971 and then Is_Discrete_Type (Etype (Expr))
1972 and then not Is_Unconstrained_Subscr_Ref
1973 and then No (Source_Typ)
1974 then
1975 declare
1976 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1977 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1978 Lo : Uint;
1979 Hi : Uint;
1981 begin
1982 if Compile_Time_Known_Value (Tlo)
1983 and then Compile_Time_Known_Value (Thi)
1984 then
1985 declare
1986 Lov : constant Uint := Expr_Value (Tlo);
1987 Hiv : constant Uint := Expr_Value (Thi);
1989 begin
1990 -- If range is null, we for sure have a constraint error
1991 -- (we don't even need to look at the value involved,
1992 -- since all possible values will raise CE).
1994 if Lov > Hiv then
1995 Bad_Value;
1996 return;
1997 end if;
1999 -- Otherwise determine range of value
2001 Determine_Range (Expr, OK, Lo, Hi);
2003 if OK then
2005 -- If definitely in range, all OK
2007 if Lo >= Lov and then Hi <= Hiv then
2008 return;
2010 -- If definitely not in range, warn
2012 elsif Lov > Hi or else Hiv < Lo then
2013 Bad_Value;
2014 return;
2016 -- Otherwise we don't know
2018 else
2019 null;
2020 end if;
2021 end if;
2022 end;
2023 end if;
2024 end;
2025 end if;
2027 Int_Real :=
2028 Is_Floating_Point_Type (S_Typ)
2029 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
2031 -- Check if we can determine at compile time whether Expr is in the
2032 -- range of the target type. Note that if S_Typ is within the bounds
2033 -- of Target_Typ then this must be the case. This check is meaningful
2034 -- only if this is not a conversion between integer and real types.
2036 if not Is_Unconstrained_Subscr_Ref
2037 and then
2038 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
2039 and then
2040 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
2041 or else
2042 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
2043 then
2044 return;
2046 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
2047 Bad_Value;
2048 return;
2050 -- In the floating-point case, we only do range checks if the
2051 -- type is constrained. We definitely do NOT want range checks
2052 -- for unconstrained types, since we want to have infinities
2054 elsif Is_Floating_Point_Type (S_Typ) then
2055 if Is_Constrained (S_Typ) then
2056 Enable_Range_Check (Expr);
2057 end if;
2059 -- For all other cases we enable a range check unconditionally
2061 else
2062 Enable_Range_Check (Expr);
2063 return;
2064 end if;
2065 end Apply_Scalar_Range_Check;
2067 ----------------------------------
2068 -- Apply_Selected_Length_Checks --
2069 ----------------------------------
2071 procedure Apply_Selected_Length_Checks
2072 (Ck_Node : Node_Id;
2073 Target_Typ : Entity_Id;
2074 Source_Typ : Entity_Id;
2075 Do_Static : Boolean)
2077 Cond : Node_Id;
2078 R_Result : Check_Result;
2079 R_Cno : Node_Id;
2081 Loc : constant Source_Ptr := Sloc (Ck_Node);
2082 Checks_On : constant Boolean :=
2083 (not Index_Checks_Suppressed (Target_Typ))
2084 or else
2085 (not Length_Checks_Suppressed (Target_Typ));
2087 begin
2088 if not Expander_Active then
2089 return;
2090 end if;
2092 R_Result :=
2093 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
2095 for J in 1 .. 2 loop
2096 R_Cno := R_Result (J);
2097 exit when No (R_Cno);
2099 -- A length check may mention an Itype which is attached to a
2100 -- subsequent node. At the top level in a package this can cause
2101 -- an order-of-elaboration problem, so we make sure that the itype
2102 -- is referenced now.
2104 if Ekind (Current_Scope) = E_Package
2105 and then Is_Compilation_Unit (Current_Scope)
2106 then
2107 Ensure_Defined (Target_Typ, Ck_Node);
2109 if Present (Source_Typ) then
2110 Ensure_Defined (Source_Typ, Ck_Node);
2112 elsif Is_Itype (Etype (Ck_Node)) then
2113 Ensure_Defined (Etype (Ck_Node), Ck_Node);
2114 end if;
2115 end if;
2117 -- If the item is a conditional raise of constraint error,
2118 -- then have a look at what check is being performed and
2119 -- ???
2121 if Nkind (R_Cno) = N_Raise_Constraint_Error
2122 and then Present (Condition (R_Cno))
2123 then
2124 Cond := Condition (R_Cno);
2126 -- Case where node does not now have a dynamic check
2128 if not Has_Dynamic_Length_Check (Ck_Node) then
2130 -- If checks are on, just insert the check
2132 if Checks_On then
2133 Insert_Action (Ck_Node, R_Cno);
2135 if not Do_Static then
2136 Set_Has_Dynamic_Length_Check (Ck_Node);
2137 end if;
2139 -- If checks are off, then analyze the length check after
2140 -- temporarily attaching it to the tree in case the relevant
2141 -- condition can be evaluted at compile time. We still want a
2142 -- compile time warning in this case.
2144 else
2145 Set_Parent (R_Cno, Ck_Node);
2146 Analyze (R_Cno);
2147 end if;
2148 end if;
2150 -- Output a warning if the condition is known to be True
2152 if Is_Entity_Name (Cond)
2153 and then Entity (Cond) = Standard_True
2154 then
2155 Apply_Compile_Time_Constraint_Error
2156 (Ck_Node, "wrong length for array of}?",
2157 CE_Length_Check_Failed,
2158 Ent => Target_Typ,
2159 Typ => Target_Typ);
2161 -- If we were only doing a static check, or if checks are not
2162 -- on, then we want to delete the check, since it is not needed.
2163 -- We do this by replacing the if statement by a null statement
2165 elsif Do_Static or else not Checks_On then
2166 Rewrite (R_Cno, Make_Null_Statement (Loc));
2167 end if;
2169 else
2170 Install_Static_Check (R_Cno, Loc);
2171 end if;
2173 end loop;
2175 end Apply_Selected_Length_Checks;
2177 ---------------------------------
2178 -- Apply_Selected_Range_Checks --
2179 ---------------------------------
2181 procedure Apply_Selected_Range_Checks
2182 (Ck_Node : Node_Id;
2183 Target_Typ : Entity_Id;
2184 Source_Typ : Entity_Id;
2185 Do_Static : Boolean)
2187 Cond : Node_Id;
2188 R_Result : Check_Result;
2189 R_Cno : Node_Id;
2191 Loc : constant Source_Ptr := Sloc (Ck_Node);
2192 Checks_On : constant Boolean :=
2193 (not Index_Checks_Suppressed (Target_Typ))
2194 or else
2195 (not Range_Checks_Suppressed (Target_Typ));
2197 begin
2198 if not Expander_Active or else not Checks_On then
2199 return;
2200 end if;
2202 R_Result :=
2203 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
2205 for J in 1 .. 2 loop
2207 R_Cno := R_Result (J);
2208 exit when No (R_Cno);
2210 -- If the item is a conditional raise of constraint error,
2211 -- then have a look at what check is being performed and
2212 -- ???
2214 if Nkind (R_Cno) = N_Raise_Constraint_Error
2215 and then Present (Condition (R_Cno))
2216 then
2217 Cond := Condition (R_Cno);
2219 if not Has_Dynamic_Range_Check (Ck_Node) then
2220 Insert_Action (Ck_Node, R_Cno);
2222 if not Do_Static then
2223 Set_Has_Dynamic_Range_Check (Ck_Node);
2224 end if;
2225 end if;
2227 -- Output a warning if the condition is known to be True
2229 if Is_Entity_Name (Cond)
2230 and then Entity (Cond) = Standard_True
2231 then
2232 -- Since an N_Range is technically not an expression, we
2233 -- have to set one of the bounds to C_E and then just flag
2234 -- the N_Range. The warning message will point to the
2235 -- lower bound and complain about a range, which seems OK.
2237 if Nkind (Ck_Node) = N_Range then
2238 Apply_Compile_Time_Constraint_Error
2239 (Low_Bound (Ck_Node), "static range out of bounds of}?",
2240 CE_Range_Check_Failed,
2241 Ent => Target_Typ,
2242 Typ => Target_Typ);
2244 Set_Raises_Constraint_Error (Ck_Node);
2246 else
2247 Apply_Compile_Time_Constraint_Error
2248 (Ck_Node, "static value out of range of}?",
2249 CE_Range_Check_Failed,
2250 Ent => Target_Typ,
2251 Typ => Target_Typ);
2252 end if;
2254 -- If we were only doing a static check, or if checks are not
2255 -- on, then we want to delete the check, since it is not needed.
2256 -- We do this by replacing the if statement by a null statement
2258 elsif Do_Static or else not Checks_On then
2259 Rewrite (R_Cno, Make_Null_Statement (Loc));
2260 end if;
2262 else
2263 Install_Static_Check (R_Cno, Loc);
2264 end if;
2265 end loop;
2266 end Apply_Selected_Range_Checks;
2268 -------------------------------
2269 -- Apply_Static_Length_Check --
2270 -------------------------------
2272 procedure Apply_Static_Length_Check
2273 (Expr : Node_Id;
2274 Target_Typ : Entity_Id;
2275 Source_Typ : Entity_Id := Empty)
2277 begin
2278 Apply_Selected_Length_Checks
2279 (Expr, Target_Typ, Source_Typ, Do_Static => True);
2280 end Apply_Static_Length_Check;
2282 -------------------------------------
2283 -- Apply_Subscript_Validity_Checks --
2284 -------------------------------------
2286 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
2287 Sub : Node_Id;
2289 begin
2290 pragma Assert (Nkind (Expr) = N_Indexed_Component);
2292 -- Loop through subscripts
2294 Sub := First (Expressions (Expr));
2295 while Present (Sub) loop
2297 -- Check one subscript. Note that we do not worry about
2298 -- enumeration type with holes, since we will convert the
2299 -- value to a Pos value for the subscript, and that convert
2300 -- will do the necessary validity check.
2302 Ensure_Valid (Sub, Holes_OK => True);
2304 -- Move to next subscript
2306 Sub := Next (Sub);
2307 end loop;
2308 end Apply_Subscript_Validity_Checks;
2310 ----------------------------------
2311 -- Apply_Type_Conversion_Checks --
2312 ----------------------------------
2314 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
2315 Target_Type : constant Entity_Id := Etype (N);
2316 Target_Base : constant Entity_Id := Base_Type (Target_Type);
2317 Expr : constant Node_Id := Expression (N);
2318 Expr_Type : constant Entity_Id := Etype (Expr);
2320 begin
2321 if Inside_A_Generic then
2322 return;
2324 -- Skip these checks if serious errors detected, there are some nasty
2325 -- situations of incomplete trees that blow things up.
2327 elsif Serious_Errors_Detected > 0 then
2328 return;
2330 -- Scalar type conversions of the form Target_Type (Expr) require
2331 -- a range check if we cannot be sure that Expr is in the base type
2332 -- of Target_Typ and also that Expr is in the range of Target_Typ.
2333 -- These are not quite the same condition from an implementation
2334 -- point of view, but clearly the second includes the first.
2336 elsif Is_Scalar_Type (Target_Type) then
2337 declare
2338 Conv_OK : constant Boolean := Conversion_OK (N);
2339 -- If the Conversion_OK flag on the type conversion is set
2340 -- and no floating point type is involved in the type conversion
2341 -- then fixed point values must be read as integral values.
2343 Float_To_Int : constant Boolean :=
2344 Is_Floating_Point_Type (Expr_Type)
2345 and then Is_Integer_Type (Target_Type);
2347 begin
2348 if not Overflow_Checks_Suppressed (Target_Base)
2349 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
2350 and then not Float_To_Int
2351 then
2352 Set_Do_Overflow_Check (N);
2353 end if;
2355 if not Range_Checks_Suppressed (Target_Type)
2356 and then not Range_Checks_Suppressed (Expr_Type)
2357 then
2358 if Float_To_Int then
2359 Apply_Float_Conversion_Check (Expr, Target_Type);
2360 else
2361 Apply_Scalar_Range_Check
2362 (Expr, Target_Type, Fixed_Int => Conv_OK);
2363 end if;
2364 end if;
2365 end;
2367 elsif Comes_From_Source (N)
2368 and then Is_Record_Type (Target_Type)
2369 and then Is_Derived_Type (Target_Type)
2370 and then not Is_Tagged_Type (Target_Type)
2371 and then not Is_Constrained (Target_Type)
2372 and then Present (Stored_Constraint (Target_Type))
2373 then
2374 -- An unconstrained derived type may have inherited discriminant
2375 -- Build an actual discriminant constraint list using the stored
2376 -- constraint, to verify that the expression of the parent type
2377 -- satisfies the constraints imposed by the (unconstrained!)
2378 -- derived type. This applies to value conversions, not to view
2379 -- conversions of tagged types.
2381 declare
2382 Loc : constant Source_Ptr := Sloc (N);
2383 Cond : Node_Id;
2384 Constraint : Elmt_Id;
2385 Discr_Value : Node_Id;
2386 Discr : Entity_Id;
2388 New_Constraints : constant Elist_Id := New_Elmt_List;
2389 Old_Constraints : constant Elist_Id :=
2390 Discriminant_Constraint (Expr_Type);
2392 begin
2393 Constraint := First_Elmt (Stored_Constraint (Target_Type));
2395 while Present (Constraint) loop
2396 Discr_Value := Node (Constraint);
2398 if Is_Entity_Name (Discr_Value)
2399 and then Ekind (Entity (Discr_Value)) = E_Discriminant
2400 then
2401 Discr := Corresponding_Discriminant (Entity (Discr_Value));
2403 if Present (Discr)
2404 and then Scope (Discr) = Base_Type (Expr_Type)
2405 then
2406 -- Parent is constrained by new discriminant. Obtain
2407 -- Value of original discriminant in expression. If
2408 -- the new discriminant has been used to constrain more
2409 -- than one of the stored discriminants, this will
2410 -- provide the required consistency check.
2412 Append_Elmt (
2413 Make_Selected_Component (Loc,
2414 Prefix =>
2415 Duplicate_Subexpr_No_Checks
2416 (Expr, Name_Req => True),
2417 Selector_Name =>
2418 Make_Identifier (Loc, Chars (Discr))),
2419 New_Constraints);
2421 else
2422 -- Discriminant of more remote ancestor ???
2424 return;
2425 end if;
2427 -- Derived type definition has an explicit value for
2428 -- this stored discriminant.
2430 else
2431 Append_Elmt
2432 (Duplicate_Subexpr_No_Checks (Discr_Value),
2433 New_Constraints);
2434 end if;
2436 Next_Elmt (Constraint);
2437 end loop;
2439 -- Use the unconstrained expression type to retrieve the
2440 -- discriminants of the parent, and apply momentarily the
2441 -- discriminant constraint synthesized above.
2443 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
2444 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
2445 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
2447 Insert_Action (N,
2448 Make_Raise_Constraint_Error (Loc,
2449 Condition => Cond,
2450 Reason => CE_Discriminant_Check_Failed));
2451 end;
2453 -- For arrays, conversions are applied during expansion, to take
2454 -- into accounts changes of representation. The checks become range
2455 -- checks on the base type or length checks on the subtype, depending
2456 -- on whether the target type is unconstrained or constrained.
2458 else
2459 null;
2460 end if;
2461 end Apply_Type_Conversion_Checks;
2463 ----------------------------------------------
2464 -- Apply_Universal_Integer_Attribute_Checks --
2465 ----------------------------------------------
2467 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
2468 Loc : constant Source_Ptr := Sloc (N);
2469 Typ : constant Entity_Id := Etype (N);
2471 begin
2472 if Inside_A_Generic then
2473 return;
2475 -- Nothing to do if checks are suppressed
2477 elsif Range_Checks_Suppressed (Typ)
2478 and then Overflow_Checks_Suppressed (Typ)
2479 then
2480 return;
2482 -- Nothing to do if the attribute does not come from source. The
2483 -- internal attributes we generate of this type do not need checks,
2484 -- and furthermore the attempt to check them causes some circular
2485 -- elaboration orders when dealing with packed types.
2487 elsif not Comes_From_Source (N) then
2488 return;
2490 -- If the prefix is a selected component that depends on a discriminant
2491 -- the check may improperly expose a discriminant instead of using
2492 -- the bounds of the object itself. Set the type of the attribute to
2493 -- the base type of the context, so that a check will be imposed when
2494 -- needed (e.g. if the node appears as an index).
2496 elsif Nkind (Prefix (N)) = N_Selected_Component
2497 and then Ekind (Typ) = E_Signed_Integer_Subtype
2498 and then Depends_On_Discriminant (Scalar_Range (Typ))
2499 then
2500 Set_Etype (N, Base_Type (Typ));
2502 -- Otherwise, replace the attribute node with a type conversion
2503 -- node whose expression is the attribute, retyped to universal
2504 -- integer, and whose subtype mark is the target type. The call
2505 -- to analyze this conversion will set range and overflow checks
2506 -- as required for proper detection of an out of range value.
2508 else
2509 Set_Etype (N, Universal_Integer);
2510 Set_Analyzed (N, True);
2512 Rewrite (N,
2513 Make_Type_Conversion (Loc,
2514 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
2515 Expression => Relocate_Node (N)));
2517 Analyze_And_Resolve (N, Typ);
2518 return;
2519 end if;
2521 end Apply_Universal_Integer_Attribute_Checks;
2523 -------------------------------
2524 -- Build_Discriminant_Checks --
2525 -------------------------------
2527 function Build_Discriminant_Checks
2528 (N : Node_Id;
2529 T_Typ : Entity_Id) return Node_Id
2531 Loc : constant Source_Ptr := Sloc (N);
2532 Cond : Node_Id;
2533 Disc : Elmt_Id;
2534 Disc_Ent : Entity_Id;
2535 Dref : Node_Id;
2536 Dval : Node_Id;
2538 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
2540 ----------------------------------
2541 -- Aggregate_Discriminant_Value --
2542 ----------------------------------
2544 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
2545 Assoc : Node_Id;
2547 begin
2548 -- The aggregate has been normalized with named associations. We
2549 -- use the Chars field to locate the discriminant to take into
2550 -- account discriminants in derived types, which carry the same
2551 -- name as those in the parent.
2553 Assoc := First (Component_Associations (N));
2554 while Present (Assoc) loop
2555 if Chars (First (Choices (Assoc))) = Chars (Disc) then
2556 return Expression (Assoc);
2557 else
2558 Next (Assoc);
2559 end if;
2560 end loop;
2562 -- Discriminant must have been found in the loop above
2564 raise Program_Error;
2565 end Aggregate_Discriminant_Val;
2567 -- Start of processing for Build_Discriminant_Checks
2569 begin
2570 -- Loop through discriminants evolving the condition
2572 Cond := Empty;
2573 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
2575 -- For a fully private type, use the discriminants of the parent type
2577 if Is_Private_Type (T_Typ)
2578 and then No (Full_View (T_Typ))
2579 then
2580 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
2581 else
2582 Disc_Ent := First_Discriminant (T_Typ);
2583 end if;
2585 while Present (Disc) loop
2586 Dval := Node (Disc);
2588 if Nkind (Dval) = N_Identifier
2589 and then Ekind (Entity (Dval)) = E_Discriminant
2590 then
2591 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
2592 else
2593 Dval := Duplicate_Subexpr_No_Checks (Dval);
2594 end if;
2596 -- If we have an Unchecked_Union node, we can infer the discriminants
2597 -- of the node.
2599 if Is_Unchecked_Union (Base_Type (T_Typ)) then
2600 Dref := New_Copy (
2601 Get_Discriminant_Value (
2602 First_Discriminant (T_Typ),
2603 T_Typ,
2604 Stored_Constraint (T_Typ)));
2606 elsif Nkind (N) = N_Aggregate then
2607 Dref :=
2608 Duplicate_Subexpr_No_Checks
2609 (Aggregate_Discriminant_Val (Disc_Ent));
2611 else
2612 Dref :=
2613 Make_Selected_Component (Loc,
2614 Prefix =>
2615 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
2616 Selector_Name =>
2617 Make_Identifier (Loc, Chars (Disc_Ent)));
2619 Set_Is_In_Discriminant_Check (Dref);
2620 end if;
2622 Evolve_Or_Else (Cond,
2623 Make_Op_Ne (Loc,
2624 Left_Opnd => Dref,
2625 Right_Opnd => Dval));
2627 Next_Elmt (Disc);
2628 Next_Discriminant (Disc_Ent);
2629 end loop;
2631 return Cond;
2632 end Build_Discriminant_Checks;
2634 ------------------
2635 -- Check_Needed --
2636 ------------------
2638 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
2639 N : Node_Id;
2640 P : Node_Id;
2641 K : Node_Kind;
2642 L : Node_Id;
2643 R : Node_Id;
2645 begin
2646 -- Always check if not simple entity
2648 if Nkind (Nod) not in N_Has_Entity
2649 or else not Comes_From_Source (Nod)
2650 then
2651 return True;
2652 end if;
2654 -- Look up tree for short circuit
2656 N := Nod;
2657 loop
2658 P := Parent (N);
2659 K := Nkind (P);
2661 if K not in N_Subexpr then
2662 return True;
2664 -- Or/Or Else case, left operand must be equality test
2666 elsif K = N_Op_Or or else K = N_Or_Else then
2667 exit when N = Right_Opnd (P)
2668 and then Nkind (Left_Opnd (P)) = N_Op_Eq;
2670 -- And/And then case, left operand must be inequality test
2672 elsif K = N_Op_And or else K = N_And_Then then
2673 exit when N = Right_Opnd (P)
2674 and then Nkind (Left_Opnd (P)) = N_Op_Ne;
2675 end if;
2677 N := P;
2678 end loop;
2680 -- If we fall through the loop, then we have a conditional with an
2681 -- appropriate test as its left operand. So test further.
2683 L := Left_Opnd (P);
2685 if Nkind (L) = N_Op_Not then
2686 L := Right_Opnd (L);
2687 end if;
2689 R := Right_Opnd (L);
2690 L := Left_Opnd (L);
2692 -- Left operand of test must match original variable
2694 if Nkind (L) not in N_Has_Entity
2695 or else Entity (L) /= Entity (Nod)
2696 then
2697 return True;
2698 end if;
2700 -- Right operand of test mus be key value (zero or null)
2702 case Check is
2703 when Access_Check =>
2704 if Nkind (R) /= N_Null then
2705 return True;
2706 end if;
2708 when Division_Check =>
2709 if not Compile_Time_Known_Value (R)
2710 or else Expr_Value (R) /= Uint_0
2711 then
2712 return True;
2713 end if;
2714 end case;
2716 -- Here we have the optimizable case, warn if not short-circuited
2718 if K = N_Op_And or else K = N_Op_Or then
2719 case Check is
2720 when Access_Check =>
2721 Error_Msg_N
2722 ("Constraint_Error may be raised (access check)?",
2723 Parent (Nod));
2724 when Division_Check =>
2725 Error_Msg_N
2726 ("Constraint_Error may be raised (zero divide)?",
2727 Parent (Nod));
2728 end case;
2730 if K = N_Op_And then
2731 Error_Msg_N ("use `AND THEN` instead of AND?", P);
2732 else
2733 Error_Msg_N ("use `OR ELSE` instead of OR?", P);
2734 end if;
2736 -- If not short-circuited, we need the ckeck
2738 return True;
2740 -- If short-circuited, we can omit the check
2742 else
2743 return False;
2744 end if;
2745 end Check_Needed;
2747 -----------------------------------
2748 -- Check_Valid_Lvalue_Subscripts --
2749 -----------------------------------
2751 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
2752 begin
2753 -- Skip this if range checks are suppressed
2755 if Range_Checks_Suppressed (Etype (Expr)) then
2756 return;
2758 -- Only do this check for expressions that come from source. We
2759 -- assume that expander generated assignments explicitly include
2760 -- any necessary checks. Note that this is not just an optimization,
2761 -- it avoids infinite recursions!
2763 elsif not Comes_From_Source (Expr) then
2764 return;
2766 -- For a selected component, check the prefix
2768 elsif Nkind (Expr) = N_Selected_Component then
2769 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2770 return;
2772 -- Case of indexed component
2774 elsif Nkind (Expr) = N_Indexed_Component then
2775 Apply_Subscript_Validity_Checks (Expr);
2777 -- Prefix may itself be or contain an indexed component, and
2778 -- these subscripts need checking as well
2780 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2781 end if;
2782 end Check_Valid_Lvalue_Subscripts;
2784 ----------------------------------
2785 -- Null_Exclusion_Static_Checks --
2786 ----------------------------------
2788 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
2789 Error_Node : Node_Id;
2790 Expr : Node_Id;
2791 Has_Null : constant Boolean := Has_Null_Exclusion (N);
2792 K : constant Node_Kind := Nkind (N);
2793 Typ : Entity_Id;
2795 begin
2796 pragma Assert
2797 (K = N_Component_Declaration
2798 or else K = N_Discriminant_Specification
2799 or else K = N_Function_Specification
2800 or else K = N_Object_Declaration
2801 or else K = N_Parameter_Specification);
2803 if K = N_Function_Specification then
2804 Typ := Etype (Defining_Entity (N));
2805 else
2806 Typ := Etype (Defining_Identifier (N));
2807 end if;
2809 case K is
2810 when N_Component_Declaration =>
2811 if Present (Access_Definition (Component_Definition (N))) then
2812 Error_Node := Component_Definition (N);
2813 else
2814 Error_Node := Subtype_Indication (Component_Definition (N));
2815 end if;
2817 when N_Discriminant_Specification =>
2818 Error_Node := Discriminant_Type (N);
2820 when N_Function_Specification =>
2821 Error_Node := Result_Definition (N);
2823 when N_Object_Declaration =>
2824 Error_Node := Object_Definition (N);
2826 when N_Parameter_Specification =>
2827 Error_Node := Parameter_Type (N);
2829 when others =>
2830 raise Program_Error;
2831 end case;
2833 if Has_Null then
2835 -- Enforce legality rule 3.10 (13): A null exclusion can only be
2836 -- applied to an access [sub]type.
2838 if not Is_Access_Type (Typ) then
2839 Error_Msg_N
2840 ("null-exclusion must be applied to an access type",
2841 Error_Node);
2843 -- Enforce legality rule 3.10 (14/1): A null exclusion can only
2844 -- be applied to a [sub]type that does not exclude null already.
2846 elsif Can_Never_Be_Null (Typ)
2848 -- No need to check itypes that have a null exclusion because
2849 -- they are already examined at their point of creation.
2851 and then not Is_Itype (Typ)
2852 then
2853 Error_Msg_N
2854 ("null-exclusion cannot be applied to a null excluding type",
2855 Error_Node);
2856 end if;
2857 end if;
2859 -- Check that null-excluding objects are always initialized
2861 if K = N_Object_Declaration
2862 and then No (Expression (N))
2863 then
2864 -- Add a an expression that assignates null. This node is needed
2865 -- by Apply_Compile_Time_Constraint_Error, that will replace this
2866 -- node by a Constraint_Error node.
2868 Set_Expression (N, Make_Null (Sloc (N)));
2869 Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
2871 Apply_Compile_Time_Constraint_Error
2872 (N => Expression (N),
2873 Msg => "(Ada 2005) null-excluding objects must be initialized?",
2874 Reason => CE_Null_Not_Allowed);
2875 end if;
2877 -- Check that a null-excluding component, formal or object is not
2878 -- being assigned a null value. Otherwise generate a warning message
2879 -- and replace Expression (N) by a N_Contraint_Error node.
2881 if K /= N_Function_Specification then
2882 Expr := Expression (N);
2884 if Present (Expr)
2885 and then Nkind (Expr) = N_Null
2886 then
2887 case K is
2888 when N_Component_Declaration |
2889 N_Discriminant_Specification =>
2890 Apply_Compile_Time_Constraint_Error
2891 (N => Expr,
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
2898 (N => Expr,
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
2905 (N => Expr,
2906 Msg => "(Ada 2005) NULL not allowed " &
2907 "in null-excluding formals?",
2908 Reason => CE_Null_Not_Allowed);
2910 when others =>
2911 null;
2912 end case;
2913 end if;
2914 end if;
2915 end Null_Exclusion_Static_Checks;
2917 ----------------------------------
2918 -- Conditional_Statements_Begin --
2919 ----------------------------------
2921 procedure Conditional_Statements_Begin is
2922 begin
2923 Saved_Checks_TOS := Saved_Checks_TOS + 1;
2925 -- If stack overflows, kill all checks, that way we know to
2926 -- simply reset the number of saved checks to zero on return.
2927 -- This should never occur in practice.
2929 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2930 Kill_All_Checks;
2932 -- In the normal case, we just make a new stack entry saving
2933 -- the current number of saved checks for a later restore.
2935 else
2936 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
2938 if Debug_Flag_CC then
2939 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
2940 Num_Saved_Checks);
2941 end if;
2942 end if;
2943 end Conditional_Statements_Begin;
2945 --------------------------------
2946 -- Conditional_Statements_End --
2947 --------------------------------
2949 procedure Conditional_Statements_End is
2950 begin
2951 pragma Assert (Saved_Checks_TOS > 0);
2953 -- If the saved checks stack overflowed, then we killed all
2954 -- checks, so setting the number of saved checks back to
2955 -- zero is correct. This 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
2961 -- from the top stack entry.
2963 else
2964 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
2965 if Debug_Flag_CC then
2966 w ("Conditional_Statements_End: Num_Saved_Checks = ",
2967 Num_Saved_Checks);
2968 end if;
2969 end if;
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
2986 -- for Determine_Range calls. Because of the way Determine_Range
2987 -- recursively traces subexpressions, and because overflow checking
2988 -- calls the routine on the way up the tree, a quadratic behavior
2989 -- can otherwise be encountered in large expressions. The cache
2990 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2991 -- can be validated by checking the actual node value stored there.
2993 procedure Determine_Range
2994 (N : Node_Id;
2995 OK : out Boolean;
2996 Lo : out Uint;
2997 Hi : out Uint)
2999 Typ : constant Entity_Id := Etype (N);
3001 Lo_Left : Uint;
3002 Hi_Left : Uint;
3003 -- Lo and Hi bounds of left operand
3005 Lo_Right : Uint;
3006 Hi_Right : Uint;
3007 -- Lo and Hi bounds of right (or only) operand
3009 Bound : Node_Id;
3010 -- Temp variable used to hold a bound node
3012 Hbound : Uint;
3013 -- High bound of base type of expression
3015 Lor : Uint;
3016 Hir : Uint;
3017 -- Refined values for low and high bounds, after tightening
3019 OK1 : Boolean;
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
3030 -----------------
3031 -- OK_Operands --
3032 -----------------
3034 function OK_Operands return Boolean is
3035 begin
3036 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
3038 if not OK1 then
3039 return False;
3040 end if;
3042 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
3043 return OK1;
3044 end OK_Operands;
3046 -- Start of processing for Determine_Range
3048 begin
3049 -- Prevent junk warnings by initializing range variables
3051 Lo := No_Uint;
3052 Hi := No_Uint;
3053 Lor := No_Uint;
3054 Hir := No_Uint;
3056 -- If the type is not discrete, or is undefined, then we can't
3057 -- do anything about determining the range.
3059 if No (Typ) or else not Is_Discrete_Type (Typ)
3060 or else Error_Posted (N)
3061 then
3062 OK := False;
3063 return;
3064 end if;
3066 -- For all other cases, we can determine the range
3068 OK := True;
3070 -- If value is compile time known, then the possible range is the
3071 -- one value that we know this expression definitely has!
3073 if Compile_Time_Known_Value (N) then
3074 Lo := Expr_Value (N);
3075 Hi := Lo;
3076 return;
3077 end if;
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);
3086 return;
3087 end if;
3089 -- Otherwise, start by finding the bounds of the type of the
3090 -- expression, the value cannot be outside this range (if it
3091 -- is, then we have an overflow situation, which is a separate
3092 -- check, we are talking here only about the expression value).
3094 -- We use the actual bound unless it is dynamic, in which case
3095 -- use the corresponding base type bound if possible. If we can't
3096 -- get a bound then we figure we can't determine the range (a
3097 -- peculiar case, that perhaps cannot happen, but there is no
3098 -- point in bombing in this 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)));
3110 else
3111 OK := False;
3112 return;
3113 end if;
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)));
3125 Hi := Hbound;
3127 else
3128 OK := False;
3129 return;
3130 end if;
3132 -- If we have a static subtype, then that may have a tighter bound
3133 -- so use the upper bound of the subtype instead in this case.
3135 if Compile_Time_Known_Value (Bound) then
3136 Hi := Expr_Value (Bound);
3137 end if;
3139 -- We may be able to refine this value in certain situations. If
3140 -- refinement is possible, then Lor and Hir are set to possibly
3141 -- tighter bounds, and OK1 is set to True.
3143 case Nkind (N) is
3145 -- For unary plus, result is limited by range of operand
3147 when N_Op_Plus =>
3148 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
3150 -- For unary minus, determine range of operand, and negate it
3152 when N_Op_Minus =>
3153 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
3155 if OK1 then
3156 Lor := -Hi_Right;
3157 Hir := -Lo_Right;
3158 end if;
3160 -- For binary addition, get range of each operand and do the
3161 -- addition to get the result range.
3163 when N_Op_Add =>
3164 if OK_Operands then
3165 Lor := Lo_Left + Lo_Right;
3166 Hir := Hi_Left + Hi_Right;
3167 end if;
3169 -- Division is tricky. The only case we consider is where the
3170 -- right operand is a positive constant, and in this case we
3171 -- simply divide the bounds of the left operand
3173 when N_Op_Divide =>
3174 if OK_Operands then
3175 if Lo_Right = Hi_Right
3176 and then Lo_Right > 0
3177 then
3178 Lor := Lo_Left / Lo_Right;
3179 Hir := Hi_Left / Lo_Right;
3181 else
3182 OK1 := False;
3183 end if;
3184 end if;
3186 -- For binary subtraction, get range of each operand and do
3187 -- the worst case subtraction to get the result range.
3189 when N_Op_Subtract =>
3190 if OK_Operands then
3191 Lor := Lo_Left - Hi_Right;
3192 Hir := Hi_Left - Lo_Right;
3193 end if;
3195 -- For MOD, if right operand is a positive constant, then
3196 -- result must be in the allowable range of mod results.
3198 when N_Op_Mod =>
3199 if OK_Operands then
3200 if Lo_Right = Hi_Right
3201 and then Lo_Right /= 0
3202 then
3203 if Lo_Right > 0 then
3204 Lor := Uint_0;
3205 Hir := Lo_Right - 1;
3207 else -- Lo_Right < 0
3208 Lor := Lo_Right + 1;
3209 Hir := Uint_0;
3210 end if;
3212 else
3213 OK1 := False;
3214 end if;
3215 end if;
3217 -- For REM, if right operand is a positive constant, then
3218 -- result must be in the allowable range of mod results.
3220 when N_Op_Rem =>
3221 if OK_Operands then
3222 if Lo_Right = Hi_Right
3223 and then Lo_Right /= 0
3224 then
3225 declare
3226 Dval : constant Uint := (abs Lo_Right) - 1;
3228 begin
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).
3233 if Lo_Left < 0 then
3234 Lor := -Dval;
3235 else
3236 Lor := Uint_0;
3237 end if;
3239 if Hi_Left < 0 then
3240 Hir := Uint_0;
3241 else
3242 Hir := Dval;
3243 end if;
3244 end;
3246 else
3247 OK1 := False;
3248 end if;
3249 end if;
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.
3265 when Name_Length =>
3266 declare
3267 Atyp : Entity_Id := Etype (Prefix (N));
3268 Inum : Nat;
3269 Indx : Node_Id;
3271 LL, LU : Uint;
3272 UL, UU : Uint;
3274 begin
3275 if Is_Access_Type (Atyp) then
3276 Atyp := Designated_Type (Atyp);
3277 end if;
3279 -- For string literal, we know exact value
3281 if Ekind (Atyp) = E_String_Literal_Subtype then
3282 OK := True;
3283 Lo := String_Literal_Length (Atyp);
3284 Hi := String_Literal_Length (Atyp);
3285 return;
3286 end if;
3288 -- Otherwise check for expression given
3290 if No (Expressions (N)) then
3291 Inum := 1;
3292 else
3293 Inum :=
3294 UI_To_Int (Expr_Value (First (Expressions (N))));
3295 end if;
3297 Indx := First_Index (Atyp);
3298 for J in 2 .. Inum loop
3299 Indx := Next_Index (Indx);
3300 end loop;
3302 Determine_Range
3303 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
3305 if OK1 then
3306 Determine_Range
3307 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
3309 if OK1 then
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
3320 -- this subtype.
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.
3328 else
3329 Lor := Uint_0;
3330 end if;
3331 end if;
3332 end if;
3333 end;
3335 -- No special handling for other attributes
3336 -- Probably more opportunities exist here ???
3338 when others =>
3339 OK1 := False;
3341 end case;
3343 -- For type conversion from one discrete type to another, we
3344 -- can 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
3351 when others =>
3352 OK1 := False;
3353 Lor := No_Uint;
3354 Hir := No_Uint;
3355 end case;
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.
3361 if OK1 then
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.
3369 if Lor > Lo
3370 and then not (Is_Modular_Integer_Type (Typ)
3371 and then Hir > Hbound)
3372 then
3373 Lo := Lor;
3374 end if;
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.
3381 if Hir < Hi
3382 and then not (Is_Modular_Integer_Type (Typ)
3383 and then Lor < Uint_0)
3384 then
3385 Hi := Hir;
3386 end if;
3387 end if;
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;
3394 return;
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.
3402 exception
3403 when others =>
3405 -- Debug flag K disables this behavior (useful for debugging)
3407 if Debug_Flag_K then
3408 raise;
3409 else
3410 OK := False;
3411 Lo := No_Uint;
3412 Hi := No_Uint;
3413 return;
3414 end if;
3415 end Determine_Range;
3417 ------------------------------------
3418 -- Discriminant_Checks_Suppressed --
3419 ------------------------------------
3421 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
3422 begin
3423 if Present (E) then
3424 if Is_Unchecked_Union (E) then
3425 return True;
3426 elsif Checks_May_Be_Suppressed (E) then
3427 return Is_Check_Suppressed (E, Discriminant_Check);
3428 end if;
3429 end if;
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
3439 begin
3440 if Present (E) and then Checks_May_Be_Suppressed (E) then
3441 return Is_Check_Suppressed (E, Division_Check);
3442 else
3443 return Scope_Suppress (Division_Check);
3444 end if;
3445 end Division_Checks_Suppressed;
3447 -----------------------------------
3448 -- Elaboration_Checks_Suppressed --
3449 -----------------------------------
3451 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
3452 begin
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.
3457 if Present (E) then
3458 if Kill_Elaboration_Checks (E) then
3459 return True;
3461 elsif Checks_May_Be_Suppressed (E) then
3462 if Is_Check_Suppressed (E, Elaboration_Check) then
3463 return True;
3464 elsif Dynamic_Elaboration_Checks then
3465 return Is_Check_Suppressed (E, All_Checks);
3466 else
3467 return False;
3468 end if;
3469 end if;
3470 end if;
3472 if Scope_Suppress (Elaboration_Check) then
3473 return True;
3474 elsif Dynamic_Elaboration_Checks then
3475 return Scope_Suppress (All_Checks);
3476 else
3477 return False;
3478 end if;
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));
3487 Chk : Nat;
3488 OK : Boolean;
3489 Ent : Entity_Id;
3490 Ofs : Uint;
3491 Lo : Uint;
3492 Hi : Uint;
3494 begin
3495 if Debug_Flag_CC then
3496 w ("Enable_Overflow_Check for node ", Int (N));
3497 Write_Str (" Source location = ");
3498 wl (Sloc (N));
3499 pg (N);
3500 end if;
3502 -- Nothing to do if the range of the result is known OK. We skip
3503 -- this for conversions, since the caller already did the check,
3504 -- and in any case the condition for deleting the check for a
3505 -- type conversion is different in any case.
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 if a bound of the
3511 -- range is equal to that of the type. That's not quite accurate
3512 -- 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.
3527 if OK
3528 and then Lo > Expr_Value (Type_Low_Bound (Typ))
3529 and then Hi < Expr_Value (Type_High_Bound (Typ))
3530 then
3531 if Debug_Flag_CC then
3532 w ("No overflow check required");
3533 end if;
3535 return;
3536 end if;
3537 end if;
3539 -- If not in optimizing mode, set flag and we are done. We are also
3540 -- done (and just set the flag) if the type is not a discrete type,
3541 -- since it is not worth the effort to eliminate checks for other
3542 -- than discrete types. In addition, we take this same path if we
3543 -- have stored the maximum number of checks possible already (a
3544 -- very unlikely situation, 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
3549 then
3550 Set_Do_Overflow_Check (N, True);
3552 if Debug_Flag_CC then
3553 w ("Optimization off");
3554 end if;
3556 return;
3557 end if;
3559 -- Otherwise evaluate and check the expression
3561 Find_Check
3562 (Expr => N,
3563 Check_Type => 'O',
3564 Target_Type => Empty,
3565 Entry_OK => OK,
3566 Check_Num => Chk,
3567 Ent => Ent,
3568 Ofs => Ofs);
3570 if Debug_Flag_CC then
3571 w ("Called Find_Check");
3572 w (" OK = ", OK);
3574 if OK then
3575 w (" Check_Num = ", Chk);
3576 w (" Ent = ", Int (Ent));
3577 Write_Str (" Ofs = ");
3578 pid (Ofs);
3579 end if;
3580 end if;
3582 -- If check is not of form to optimize, then set flag and we are done
3584 if not OK then
3585 Set_Do_Overflow_Check (N, True);
3586 return;
3587 end if;
3589 -- If check is already performed, then return without setting flag
3591 if Chk /= 0 then
3592 if Debug_Flag_CC then
3593 w ("Check suppressed!");
3594 end if;
3596 return;
3597 end if;
3599 -- Here we will make a new entry for the new check
3601 Set_Do_Overflow_Check (N, True);
3602 Num_Saved_Checks := Num_Saved_Checks + 1;
3603 Saved_Checks (Num_Saved_Checks) :=
3604 (Killed => False,
3605 Entity => Ent,
3606 Offset => Ofs,
3607 Check_Type => 'O',
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 = ");
3614 pid (Ofs);
3615 w (" Check_Type = O");
3616 w (" Target_Type = Empty");
3617 end if;
3619 -- If we get an exception, then something went wrong, probably because
3620 -- of an error in the structure of the tree due to an incorrect program.
3621 -- Or it may be a bug in the optimization circuit. In either case the
3622 -- safest thing is simply to set the check flag unconditionally.
3624 exception
3625 when others =>
3626 Set_Do_Overflow_Check (N, True);
3628 if Debug_Flag_CC then
3629 w (" exception occurred, overflow flag set");
3630 end if;
3632 return;
3633 end Enable_Overflow_Check;
3635 ------------------------
3636 -- Enable_Range_Check --
3637 ------------------------
3639 procedure Enable_Range_Check (N : Node_Id) is
3640 Chk : Nat;
3641 OK : Boolean;
3642 Ent : Entity_Id;
3643 Ofs : Uint;
3644 Ttyp : Entity_Id;
3645 P : Node_Id;
3647 begin
3648 -- Return if unchecked type conversion with range check killed.
3649 -- In this case we never set the flag (that's what Kill_Range_Check
3650 -- is all about!)
3652 if Nkind (N) = N_Unchecked_Type_Conversion
3653 and then Kill_Range_Check (N)
3654 then
3655 return;
3656 end if;
3658 -- Check for various cases where we should suppress the range check
3660 -- No check if range checks suppressed for type of node
3662 if Present (Etype (N))
3663 and then Range_Checks_Suppressed (Etype (N))
3664 then
3665 return;
3667 -- No check if node is an entity name, and range checks are suppressed
3668 -- for this entity, or for the type of this entity.
3670 elsif Is_Entity_Name (N)
3671 and then (Range_Checks_Suppressed (Entity (N))
3672 or else Range_Checks_Suppressed (Etype (Entity (N))))
3673 then
3674 return;
3676 -- No checks if index of array, and index checks are suppressed for
3677 -- the array object or the type of the array.
3679 elsif Nkind (Parent (N)) = N_Indexed_Component then
3680 declare
3681 Pref : constant Node_Id := Prefix (Parent (N));
3682 begin
3683 if Is_Entity_Name (Pref)
3684 and then Index_Checks_Suppressed (Entity (Pref))
3685 then
3686 return;
3687 elsif Index_Checks_Suppressed (Etype (Pref)) then
3688 return;
3689 end if;
3690 end;
3691 end if;
3693 -- Debug trace output
3695 if Debug_Flag_CC then
3696 w ("Enable_Range_Check for node ", Int (N));
3697 Write_Str (" Source location = ");
3698 wl (Sloc (N));
3699 pg (N);
3700 end if;
3702 -- If not in optimizing mode, set flag and we are done. We are also
3703 -- done (and just set the flag) if the type is not a discrete type,
3704 -- since it is not worth the effort to eliminate checks for other
3705 -- than discrete types. In addition, we take this same path if we
3706 -- have stored the maximum number of checks possible already (a
3707 -- very unlikely situation, but we do not want to blow up!)
3709 if Optimization_Level = 0
3710 or else No (Etype (N))
3711 or else not Is_Discrete_Type (Etype (N))
3712 or else Num_Saved_Checks = Saved_Checks'Last
3713 then
3714 Set_Do_Range_Check (N, True);
3716 if Debug_Flag_CC then
3717 w ("Optimization off");
3718 end if;
3720 return;
3721 end if;
3723 -- Otherwise find out the target type
3725 P := Parent (N);
3727 -- For assignment, use left side subtype
3729 if Nkind (P) = N_Assignment_Statement
3730 and then Expression (P) = N
3731 then
3732 Ttyp := Etype (Name (P));
3734 -- For indexed component, use subscript subtype
3736 elsif Nkind (P) = N_Indexed_Component then
3737 declare
3738 Atyp : Entity_Id;
3739 Indx : Node_Id;
3740 Subs : Node_Id;
3742 begin
3743 Atyp := Etype (Prefix (P));
3745 if Is_Access_Type (Atyp) then
3746 Atyp := Designated_Type (Atyp);
3748 -- If the prefix is an access to an unconstrained array,
3749 -- perform check unconditionally: it depends on the bounds
3750 -- of an object and we cannot currently recognize whether
3751 -- the test may be redundant.
3753 if not Is_Constrained (Atyp) then
3754 Set_Do_Range_Check (N, True);
3755 return;
3756 end if;
3758 -- Ditto if the prefix is an explicit dereference whose
3759 -- designated type is unconstrained.
3761 elsif Nkind (Prefix (P)) = N_Explicit_Dereference
3762 and then not Is_Constrained (Atyp)
3763 then
3764 Set_Do_Range_Check (N, True);
3765 return;
3766 end if;
3768 Indx := First_Index (Atyp);
3769 Subs := First (Expressions (P));
3770 loop
3771 if Subs = N then
3772 Ttyp := Etype (Indx);
3773 exit;
3774 end if;
3776 Next_Index (Indx);
3777 Next (Subs);
3778 end loop;
3779 end;
3781 -- For now, ignore all other cases, they are not so interesting
3783 else
3784 if Debug_Flag_CC then
3785 w (" target type not found, flag set");
3786 end if;
3788 Set_Do_Range_Check (N, True);
3789 return;
3790 end if;
3792 -- Evaluate and check the expression
3794 Find_Check
3795 (Expr => N,
3796 Check_Type => 'R',
3797 Target_Type => Ttyp,
3798 Entry_OK => OK,
3799 Check_Num => Chk,
3800 Ent => Ent,
3801 Ofs => Ofs);
3803 if Debug_Flag_CC then
3804 w ("Called Find_Check");
3805 w ("Target_Typ = ", Int (Ttyp));
3806 w (" OK = ", OK);
3808 if OK then
3809 w (" Check_Num = ", Chk);
3810 w (" Ent = ", Int (Ent));
3811 Write_Str (" Ofs = ");
3812 pid (Ofs);
3813 end if;
3814 end if;
3816 -- If check is not of form to optimize, then set flag and we are done
3818 if not OK then
3819 if Debug_Flag_CC then
3820 w (" expression not of optimizable type, flag set");
3821 end if;
3823 Set_Do_Range_Check (N, True);
3824 return;
3825 end if;
3827 -- If check is already performed, then return without setting flag
3829 if Chk /= 0 then
3830 if Debug_Flag_CC then
3831 w ("Check suppressed!");
3832 end if;
3834 return;
3835 end if;
3837 -- Here we will make a new entry for the new check
3839 Set_Do_Range_Check (N, True);
3840 Num_Saved_Checks := Num_Saved_Checks + 1;
3841 Saved_Checks (Num_Saved_Checks) :=
3842 (Killed => False,
3843 Entity => Ent,
3844 Offset => Ofs,
3845 Check_Type => 'R',
3846 Target_Type => Ttyp);
3848 if Debug_Flag_CC then
3849 w ("Make new entry, check number = ", Num_Saved_Checks);
3850 w (" Entity = ", Int (Ent));
3851 Write_Str (" Offset = ");
3852 pid (Ofs);
3853 w (" Check_Type = R");
3854 w (" Target_Type = ", Int (Ttyp));
3855 pg (Ttyp);
3856 end if;
3858 -- If we get an exception, then something went wrong, probably because
3859 -- of an error in the structure of the tree due to an incorrect program.
3860 -- Or it may be a bug in the optimization circuit. In either case the
3861 -- safest thing is simply to set the check flag unconditionally.
3863 exception
3864 when others =>
3865 Set_Do_Range_Check (N, True);
3867 if Debug_Flag_CC then
3868 w (" exception occurred, range flag set");
3869 end if;
3871 return;
3872 end Enable_Range_Check;
3874 ------------------
3875 -- Ensure_Valid --
3876 ------------------
3878 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
3879 Typ : constant Entity_Id := Etype (Expr);
3881 begin
3882 -- Ignore call if we are not doing any validity checking
3884 if not Validity_Checks_On then
3885 return;
3887 -- Ignore call if range or validity checks suppressed on entity or type
3889 elsif Range_Or_Validity_Checks_Suppressed (Expr) then
3890 return;
3892 -- No check required if expression is from the expander, we assume
3893 -- the expander will generate whatever checks are needed. Note that
3894 -- this is not just an optimization, it avoids infinite recursions!
3896 -- Unchecked conversions must be checked, unless they are initialized
3897 -- scalar values, as in a component assignment in an init proc.
3899 -- In addition, we force a check if Force_Validity_Checks is set
3901 elsif not Comes_From_Source (Expr)
3902 and then not Force_Validity_Checks
3903 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
3904 or else Kill_Range_Check (Expr))
3905 then
3906 return;
3908 -- No check required if expression is known to have valid value
3910 elsif Expr_Known_Valid (Expr) then
3911 return;
3913 -- Ignore case of enumeration with holes where the flag is set not
3914 -- to worry about holes, since no special validity check is needed
3916 elsif Is_Enumeration_Type (Typ)
3917 and then Has_Non_Standard_Rep (Typ)
3918 and then Holes_OK
3919 then
3920 return;
3922 -- No check required on the left-hand side of an assignment
3924 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
3925 and then Expr = Name (Parent (Expr))
3926 then
3927 return;
3929 -- No check on a univeral real constant. The context will eventually
3930 -- convert it to a machine number for some target type, or report an
3931 -- illegality.
3933 elsif Nkind (Expr) = N_Real_Literal
3934 and then Etype (Expr) = Universal_Real
3935 then
3936 return;
3938 -- If the expression denotes a component of a packed boolean arrray,
3939 -- no possible check applies. We ignore the old ACATS chestnuts that
3940 -- involve Boolean range True..True.
3942 -- Note: validity checks are generated for expressions that yield a
3943 -- scalar type, when it is possible to create a value that is outside of
3944 -- the type. If this is a one-bit boolean no such value exists. This is
3945 -- an optimization, and it also prevents compiler blowing up during the
3946 -- elaboration of improperly expanded packed array references.
3948 elsif Nkind (Expr) = N_Indexed_Component
3949 and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
3950 and then Root_Type (Etype (Expr)) = Standard_Boolean
3951 then
3952 return;
3954 -- An annoying special case. If this is an out parameter of a scalar
3955 -- type, then the value is not going to be accessed, therefore it is
3956 -- inappropriate to do any validity check at the call site.
3958 else
3959 -- Only need to worry about scalar types
3961 if Is_Scalar_Type (Typ) then
3962 declare
3963 P : Node_Id;
3964 N : Node_Id;
3965 E : Entity_Id;
3966 F : Entity_Id;
3967 A : Node_Id;
3968 L : List_Id;
3970 begin
3971 -- Find actual argument (which may be a parameter association)
3972 -- and the parent of the actual argument (the call statement)
3974 N := Expr;
3975 P := Parent (Expr);
3977 if Nkind (P) = N_Parameter_Association then
3978 N := P;
3979 P := Parent (N);
3980 end if;
3982 -- Only need to worry if we are argument of a procedure
3983 -- call since functions don't have out parameters. If this
3984 -- is an indirect or dispatching call, get signature from
3985 -- the subprogram type.
3987 if Nkind (P) = N_Procedure_Call_Statement then
3988 L := Parameter_Associations (P);
3990 if Is_Entity_Name (Name (P)) then
3991 E := Entity (Name (P));
3992 else
3993 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
3994 E := Etype (Name (P));
3995 end if;
3997 -- Only need to worry if there are indeed actuals, and
3998 -- if this could be a procedure call, otherwise we cannot
3999 -- get a match (either we are not an argument, or the
4000 -- mode of the formal is not OUT). This test also filters
4001 -- out the generic case.
4003 if Is_Non_Empty_List (L)
4004 and then Is_Subprogram (E)
4005 then
4006 -- This is the loop through parameters, looking to
4007 -- see if there is an OUT parameter for which we are
4008 -- the argument.
4010 F := First_Formal (E);
4011 A := First (L);
4012 while Present (F) loop
4013 if Ekind (F) = E_Out_Parameter and then A = N then
4014 return;
4015 end if;
4017 Next_Formal (F);
4018 Next (A);
4019 end loop;
4020 end if;
4021 end if;
4022 end;
4023 end if;
4024 end if;
4026 -- If we fall through, a validity check is required
4028 Insert_Valid_Check (Expr);
4029 end Ensure_Valid;
4031 ----------------------
4032 -- Expr_Known_Valid --
4033 ----------------------
4035 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
4036 Typ : constant Entity_Id := Etype (Expr);
4038 begin
4039 -- Non-scalar types are always considered valid, since they never
4040 -- give rise to the issues of erroneous or bounded error behavior
4041 -- that are the concern. In formal reference manual terms the
4042 -- notion of validity only applies to scalar types. Note that
4043 -- even when packed arrays are represented using modular types,
4044 -- they are still arrays semantically, so they are also always
4045 -- valid (in particular, the unused bits can be random rubbish
4046 -- without affecting the validity of the array value).
4048 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then
4049 return True;
4051 -- If no validity checking, then everything is considered valid
4053 elsif not Validity_Checks_On then
4054 return True;
4056 -- Floating-point types are considered valid unless floating-point
4057 -- validity checks have been specifically turned on.
4059 elsif Is_Floating_Point_Type (Typ)
4060 and then not Validity_Check_Floating_Point
4061 then
4062 return True;
4064 -- If the expression is the value of an object that is known to
4065 -- be valid, then clearly the expression value itself is valid.
4067 elsif Is_Entity_Name (Expr)
4068 and then Is_Known_Valid (Entity (Expr))
4069 then
4070 return True;
4072 -- References to discriminants are always considered valid. The value
4073 -- of a discriminant gets checked when the object is built. Within the
4074 -- record, we consider it valid, and it is important to do so, since
4075 -- otherwise we can try to generate bogus validity checks which
4076 -- reference discriminants out of scope.
4078 elsif Is_Entity_Name (Expr)
4079 and then Ekind (Entity (Expr)) = E_Discriminant
4080 then
4081 return True;
4083 -- If the type is one for which all values are known valid, then
4084 -- we are sure that the value is valid except in the slightly odd
4085 -- case where the expression is a reference to a variable whose size
4086 -- has been explicitly set to a value greater than the object size.
4088 elsif Is_Known_Valid (Typ) then
4089 if Is_Entity_Name (Expr)
4090 and then Ekind (Entity (Expr)) = E_Variable
4091 and then Esize (Entity (Expr)) > Esize (Typ)
4092 then
4093 return False;
4094 else
4095 return True;
4096 end if;
4098 -- Integer and character literals always have valid values, where
4099 -- appropriate these will be range checked in any case.
4101 elsif Nkind (Expr) = N_Integer_Literal
4102 or else
4103 Nkind (Expr) = N_Character_Literal
4104 then
4105 return True;
4107 -- If we have a type conversion or a qualification of a known valid
4108 -- value, then the result will always be valid.
4110 elsif Nkind (Expr) = N_Type_Conversion
4111 or else
4112 Nkind (Expr) = N_Qualified_Expression
4113 then
4114 return Expr_Known_Valid (Expression (Expr));
4116 -- The result of any operator is always considered valid, since we
4117 -- assume the necessary checks are done by the operator. For operators
4118 -- on floating-point operations, we must also check when the operation
4119 -- is the right-hand side of an assignment, or is an actual in a call.
4121 elsif Nkind (Expr) in N_Op then
4122 if Is_Floating_Point_Type (Typ)
4123 and then Validity_Check_Floating_Point
4124 and then
4125 (Nkind (Parent (Expr)) = N_Assignment_Statement
4126 or else Nkind (Parent (Expr)) = N_Function_Call
4127 or else Nkind (Parent (Expr)) = N_Parameter_Association)
4128 then
4129 return False;
4130 else
4131 return True;
4132 end if;
4134 -- The result of a membership test is always valid, since it is true
4135 -- or false, there are no other possibilities.
4137 elsif Nkind (Expr) in N_Membership_Test then
4138 return True;
4140 -- For all other cases, we do not know the expression is valid
4142 else
4143 return False;
4144 end if;
4145 end Expr_Known_Valid;
4147 ----------------
4148 -- Find_Check --
4149 ----------------
4151 procedure Find_Check
4152 (Expr : Node_Id;
4153 Check_Type : Character;
4154 Target_Type : Entity_Id;
4155 Entry_OK : out Boolean;
4156 Check_Num : out Nat;
4157 Ent : out Entity_Id;
4158 Ofs : out Uint)
4160 function Within_Range_Of
4161 (Target_Type : Entity_Id;
4162 Check_Type : Entity_Id) return Boolean;
4163 -- Given a requirement for checking a range against Target_Type, and
4164 -- and a range Check_Type against which a check has already been made,
4165 -- determines if the check against check type is sufficient to ensure
4166 -- that no check against Target_Type is required.
4168 ---------------------
4169 -- Within_Range_Of --
4170 ---------------------
4172 function Within_Range_Of
4173 (Target_Type : Entity_Id;
4174 Check_Type : Entity_Id) return Boolean
4176 begin
4177 if Target_Type = Check_Type then
4178 return True;
4180 else
4181 declare
4182 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
4183 Thi : constant Node_Id := Type_High_Bound (Target_Type);
4184 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
4185 Chi : constant Node_Id := Type_High_Bound (Check_Type);
4187 begin
4188 if (Tlo = Clo
4189 or else (Compile_Time_Known_Value (Tlo)
4190 and then
4191 Compile_Time_Known_Value (Clo)
4192 and then
4193 Expr_Value (Clo) >= Expr_Value (Tlo)))
4194 and then
4195 (Thi = Chi
4196 or else (Compile_Time_Known_Value (Thi)
4197 and then
4198 Compile_Time_Known_Value (Chi)
4199 and then
4200 Expr_Value (Chi) <= Expr_Value (Clo)))
4201 then
4202 return True;
4203 else
4204 return False;
4205 end if;
4206 end;
4207 end if;
4208 end Within_Range_Of;
4210 -- Start of processing for Find_Check
4212 begin
4213 -- Establish default, to avoid warnings from GCC
4215 Check_Num := 0;
4217 -- Case of expression is simple entity reference
4219 if Is_Entity_Name (Expr) then
4220 Ent := Entity (Expr);
4221 Ofs := Uint_0;
4223 -- Case of expression is entity + known constant
4225 elsif Nkind (Expr) = N_Op_Add
4226 and then Compile_Time_Known_Value (Right_Opnd (Expr))
4227 and then Is_Entity_Name (Left_Opnd (Expr))
4228 then
4229 Ent := Entity (Left_Opnd (Expr));
4230 Ofs := Expr_Value (Right_Opnd (Expr));
4232 -- Case of expression is entity - known constant
4234 elsif Nkind (Expr) = N_Op_Subtract
4235 and then Compile_Time_Known_Value (Right_Opnd (Expr))
4236 and then Is_Entity_Name (Left_Opnd (Expr))
4237 then
4238 Ent := Entity (Left_Opnd (Expr));
4239 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
4241 -- Any other expression is not of the right form
4243 else
4244 Ent := Empty;
4245 Ofs := Uint_0;
4246 Entry_OK := False;
4247 return;
4248 end if;
4250 -- Come here with expression of appropriate form, check if
4251 -- entity is an appropriate one for our purposes.
4253 if (Ekind (Ent) = E_Variable
4254 or else
4255 Ekind (Ent) = E_Constant
4256 or else
4257 Ekind (Ent) = E_Loop_Parameter
4258 or else
4259 Ekind (Ent) = E_In_Parameter)
4260 and then not Is_Library_Level_Entity (Ent)
4261 then
4262 Entry_OK := True;
4263 else
4264 Entry_OK := False;
4265 return;
4266 end if;
4268 -- See if there is matching check already
4270 for J in reverse 1 .. Num_Saved_Checks loop
4271 declare
4272 SC : Saved_Check renames Saved_Checks (J);
4274 begin
4275 if SC.Killed = False
4276 and then SC.Entity = Ent
4277 and then SC.Offset = Ofs
4278 and then SC.Check_Type = Check_Type
4279 and then Within_Range_Of (Target_Type, SC.Target_Type)
4280 then
4281 Check_Num := J;
4282 return;
4283 end if;
4284 end;
4285 end loop;
4287 -- If we fall through entry was not found
4289 Check_Num := 0;
4290 return;
4291 end Find_Check;
4293 ---------------------------------
4294 -- Generate_Discriminant_Check --
4295 ---------------------------------
4297 -- Note: the code for this procedure is derived from the
4298 -- emit_discriminant_check routine a-trans.c v1.659.
4300 procedure Generate_Discriminant_Check (N : Node_Id) is
4301 Loc : constant Source_Ptr := Sloc (N);
4302 Pref : constant Node_Id := Prefix (N);
4303 Sel : constant Node_Id := Selector_Name (N);
4305 Orig_Comp : constant Entity_Id :=
4306 Original_Record_Component (Entity (Sel));
4307 -- The original component to be checked
4309 Discr_Fct : constant Entity_Id :=
4310 Discriminant_Checking_Func (Orig_Comp);
4311 -- The discriminant checking function
4313 Discr : Entity_Id;
4314 -- One discriminant to be checked in the type
4316 Real_Discr : Entity_Id;
4317 -- Actual discriminant in the call
4319 Pref_Type : Entity_Id;
4320 -- Type of relevant prefix (ignoring private/access stuff)
4322 Args : List_Id;
4323 -- List of arguments for function call
4325 Formal : Entity_Id;
4326 -- Keep track of the formal corresponding to the actual we build
4327 -- for each discriminant, in order to be able to perform the
4328 -- necessary type conversions.
4330 Scomp : Node_Id;
4331 -- Selected component reference for checking function argument
4333 begin
4334 Pref_Type := Etype (Pref);
4336 -- Force evaluation of the prefix, so that it does not get evaluated
4337 -- twice (once for the check, once for the actual reference). Such a
4338 -- double evaluation is always a potential source of inefficiency,
4339 -- and is functionally incorrect in the volatile case, or when the
4340 -- prefix may have side-effects. An entity or a component of an
4341 -- entity requires no evaluation.
4343 if Is_Entity_Name (Pref) then
4344 if Treat_As_Volatile (Entity (Pref)) then
4345 Force_Evaluation (Pref, Name_Req => True);
4346 end if;
4348 elsif Treat_As_Volatile (Etype (Pref)) then
4349 Force_Evaluation (Pref, Name_Req => True);
4351 elsif Nkind (Pref) = N_Selected_Component
4352 and then Is_Entity_Name (Prefix (Pref))
4353 then
4354 null;
4356 else
4357 Force_Evaluation (Pref, Name_Req => True);
4358 end if;
4360 -- For a tagged type, use the scope of the original component to
4361 -- obtain the type, because ???
4363 if Is_Tagged_Type (Scope (Orig_Comp)) then
4364 Pref_Type := Scope (Orig_Comp);
4366 -- For an untagged derived type, use the discriminants of the
4367 -- parent which have been renamed in the derivation, possibly
4368 -- by a one-to-many discriminant constraint.
4369 -- For non-tagged type, initially get the Etype of the prefix
4371 else
4372 if Is_Derived_Type (Pref_Type)
4373 and then Number_Discriminants (Pref_Type) /=
4374 Number_Discriminants (Etype (Base_Type (Pref_Type)))
4375 then
4376 Pref_Type := Etype (Base_Type (Pref_Type));
4377 end if;
4378 end if;
4380 -- We definitely should have a checking function, This routine should
4381 -- not be called if no discriminant checking function is present.
4383 pragma Assert (Present (Discr_Fct));
4385 -- Create the list of the actual parameters for the call. This list
4386 -- is the list of the discriminant fields of the record expression to
4387 -- be discriminant checked.
4389 Args := New_List;
4390 Formal := First_Formal (Discr_Fct);
4391 Discr := First_Discriminant (Pref_Type);
4392 while Present (Discr) loop
4394 -- If we have a corresponding discriminant field, and a parent
4395 -- subtype is present, then we want to use the corresponding
4396 -- discriminant since this is the one with the useful value.
4398 if Present (Corresponding_Discriminant (Discr))
4399 and then Ekind (Pref_Type) = E_Record_Type
4400 and then Present (Parent_Subtype (Pref_Type))
4401 then
4402 Real_Discr := Corresponding_Discriminant (Discr);
4403 else
4404 Real_Discr := Discr;
4405 end if;
4407 -- Construct the reference to the discriminant
4409 Scomp :=
4410 Make_Selected_Component (Loc,
4411 Prefix =>
4412 Unchecked_Convert_To (Pref_Type,
4413 Duplicate_Subexpr (Pref)),
4414 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
4416 -- Manually analyze and resolve this selected component. We really
4417 -- want it just as it appears above, and do not want the expander
4418 -- playing discriminal games etc with this reference. Then we
4419 -- append the argument to the list we are gathering.
4421 Set_Etype (Scomp, Etype (Real_Discr));
4422 Set_Analyzed (Scomp, True);
4423 Append_To (Args, Convert_To (Etype (Formal), Scomp));
4425 Next_Formal_With_Extras (Formal);
4426 Next_Discriminant (Discr);
4427 end loop;
4429 -- Now build and insert the call
4431 Insert_Action (N,
4432 Make_Raise_Constraint_Error (Loc,
4433 Condition =>
4434 Make_Function_Call (Loc,
4435 Name => New_Occurrence_Of (Discr_Fct, Loc),
4436 Parameter_Associations => Args),
4437 Reason => CE_Discriminant_Check_Failed));
4438 end Generate_Discriminant_Check;
4440 ---------------------------
4441 -- Generate_Index_Checks --
4442 ---------------------------
4444 procedure Generate_Index_Checks (N : Node_Id) is
4445 Loc : constant Source_Ptr := Sloc (N);
4446 A : constant Node_Id := Prefix (N);
4447 Sub : Node_Id;
4448 Ind : Nat;
4449 Num : List_Id;
4451 begin
4452 -- Ignore call if index checks suppressed for array object or type
4454 if (Is_Entity_Name (A) and then Index_Checks_Suppressed (Entity (A)))
4455 or else Index_Checks_Suppressed (Etype (A))
4456 then
4457 return;
4458 end if;
4460 -- Generate the checks
4462 Sub := First (Expressions (N));
4463 Ind := 1;
4464 while Present (Sub) loop
4465 if Do_Range_Check (Sub) then
4466 Set_Do_Range_Check (Sub, False);
4468 -- Force evaluation except for the case of a simple name of
4469 -- a non-volatile entity.
4471 if not Is_Entity_Name (Sub)
4472 or else Treat_As_Volatile (Entity (Sub))
4473 then
4474 Force_Evaluation (Sub);
4475 end if;
4477 -- Generate a raise of constraint error with the appropriate
4478 -- reason and a condition of the form:
4480 -- Base_Type(Sub) not in array'range (subscript)
4482 -- Note that the reason we generate the conversion to the
4483 -- base type here is that we definitely want the range check
4484 -- to take place, even if it looks like the subtype is OK.
4485 -- Optimization considerations that allow us to omit the
4486 -- check have already been taken into account in the setting
4487 -- of the Do_Range_Check flag earlier on.
4489 if Ind = 1 then
4490 Num := No_List;
4491 else
4492 Num := New_List (Make_Integer_Literal (Loc, Ind));
4493 end if;
4495 Insert_Action (N,
4496 Make_Raise_Constraint_Error (Loc,
4497 Condition =>
4498 Make_Not_In (Loc,
4499 Left_Opnd =>
4500 Convert_To (Base_Type (Etype (Sub)),
4501 Duplicate_Subexpr_Move_Checks (Sub)),
4502 Right_Opnd =>
4503 Make_Attribute_Reference (Loc,
4504 Prefix => Duplicate_Subexpr_Move_Checks (A),
4505 Attribute_Name => Name_Range,
4506 Expressions => Num)),
4507 Reason => CE_Index_Check_Failed));
4508 end if;
4510 Ind := Ind + 1;
4511 Next (Sub);
4512 end loop;
4513 end Generate_Index_Checks;
4515 --------------------------
4516 -- Generate_Range_Check --
4517 --------------------------
4519 procedure Generate_Range_Check
4520 (N : Node_Id;
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);
4529 begin
4530 -- First special case, if the source type is already within the
4531 -- range of the target type, then no check is needed (probably we
4532 -- should have stopped Do_Range_Check from being set in the first
4533 -- place, but better late than later in preventing junk code!
4535 -- We do NOT apply this if the source node is a literal, since in
4536 -- this case the literal has already been labeled as having the
4537 -- subtype of the target.
4539 if In_Subrange_Of (Source_Type, Target_Type)
4540 and then not
4541 (Nkind (N) = N_Integer_Literal
4542 or else
4543 Nkind (N) = N_Real_Literal
4544 or else
4545 Nkind (N) = N_Character_Literal
4546 or else
4547 (Is_Entity_Name (N)
4548 and then Ekind (Entity (N)) = E_Enumeration_Literal))
4549 then
4550 return;
4551 end if;
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))
4560 then
4561 Force_Evaluation (N);
4562 end if;
4564 -- The easiest case is when Source_Base_Type and Target_Base_Type
4565 -- are the same since in this case we can simply do a direct
4566 -- check of the 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
4575 Insert_Action (N,
4576 Make_Raise_Constraint_Error (Loc,
4577 Condition =>
4578 Make_Not_In (Loc,
4579 Left_Opnd => Duplicate_Subexpr (N),
4580 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4581 Reason => Reason));
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)
4589 -- ..
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
4595 Insert_Action (N,
4596 Make_Raise_Constraint_Error (Loc,
4597 Condition =>
4598 Make_Not_In (Loc,
4599 Left_Opnd => Duplicate_Subexpr (N),
4601 Right_Opnd =>
4602 Make_Range (Loc,
4603 Low_Bound =>
4604 Convert_To (Source_Base_Type,
4605 Make_Attribute_Reference (Loc,
4606 Prefix =>
4607 New_Occurrence_Of (Target_Type, Loc),
4608 Attribute_Name => Name_First)),
4610 High_Bound =>
4611 Convert_To (Source_Base_Type,
4612 Make_Attribute_Reference (Loc,
4613 Prefix =>
4614 New_Occurrence_Of (Target_Type, Loc),
4615 Attribute_Name => Name_Last)))),
4616 Reason => Reason));
4618 -- Note that at this stage we now that the Target_Base_Type is
4619 -- not in the range of the Source_Base_Type (since even the
4620 -- Target_Type itself is not in this range). It could still be
4621 -- the case that the Source_Type is in range of the target base
4622 -- type, since we have not checked that case.
4624 -- If that is the case, we can freely convert the source to the
4625 -- target, and then test the target result against the bounds.
4627 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
4629 -- We make a temporary to hold the value of the converted
4630 -- value (converted to the base type), and then we will
4631 -- do the test against this temporary.
4633 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4634 -- [constraint_error when Tnn not in Target_Type]
4636 -- Then the conversion itself is replaced by an occurrence of Tnn
4638 declare
4639 Tnn : constant Entity_Id :=
4640 Make_Defining_Identifier (Loc,
4641 Chars => New_Internal_Name ('T'));
4643 begin
4644 Insert_Actions (N, New_List (
4645 Make_Object_Declaration (Loc,
4646 Defining_Identifier => Tnn,
4647 Object_Definition =>
4648 New_Occurrence_Of (Target_Base_Type, Loc),
4649 Constant_Present => True,
4650 Expression =>
4651 Make_Type_Conversion (Loc,
4652 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
4653 Expression => Duplicate_Subexpr (N))),
4655 Make_Raise_Constraint_Error (Loc,
4656 Condition =>
4657 Make_Not_In (Loc,
4658 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4659 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4661 Reason => Reason)));
4663 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4664 end;
4666 -- At this stage, we know that we have two scalar types, which are
4667 -- directly convertible, and where neither scalar type has a base
4668 -- range that is in the range of the other scalar type.
4670 -- The only way this can happen is with a signed and unsigned type.
4671 -- So test for these two cases:
4673 else
4674 -- Case of the source is unsigned and the target is signed
4676 if Is_Unsigned_Type (Source_Base_Type)
4677 and then not Is_Unsigned_Type (Target_Base_Type)
4678 then
4679 -- If the source is unsigned and the target is signed, then we
4680 -- know that the source is not shorter than the target (otherwise
4681 -- the source base type would be in the target base type range).
4683 -- In other words, the unsigned type is either the same size
4684 -- as the target, or it is larger. It cannot be smaller.
4686 pragma Assert
4687 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
4689 -- We only need to check the low bound if the low bound of the
4690 -- target type is non-negative. If the low bound of the target
4691 -- type is negative, then we know that we will fit fine.
4693 -- If the high bound of the target type is negative, then we
4694 -- know we have a constraint error, since we can't possibly
4695 -- have a negative source.
4697 -- With these two checks out of the way, we can do the check
4698 -- using the source type safely
4700 -- This is definitely the most annoying case!
4702 -- [constraint_error
4703 -- when (Target_Type'First >= 0
4704 -- and then
4705 -- N < Source_Base_Type (Target_Type'First))
4706 -- or else Target_Type'Last < 0
4707 -- or else N > Source_Base_Type (Target_Type'Last)];
4709 -- We turn off all checks since we know that the conversions
4710 -- will work fine, given the guards for negative values.
4712 Insert_Action (N,
4713 Make_Raise_Constraint_Error (Loc,
4714 Condition =>
4715 Make_Or_Else (Loc,
4716 Make_Or_Else (Loc,
4717 Left_Opnd =>
4718 Make_And_Then (Loc,
4719 Left_Opnd => Make_Op_Ge (Loc,
4720 Left_Opnd =>
4721 Make_Attribute_Reference (Loc,
4722 Prefix =>
4723 New_Occurrence_Of (Target_Type, Loc),
4724 Attribute_Name => Name_First),
4725 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4727 Right_Opnd =>
4728 Make_Op_Lt (Loc,
4729 Left_Opnd => Duplicate_Subexpr (N),
4730 Right_Opnd =>
4731 Convert_To (Source_Base_Type,
4732 Make_Attribute_Reference (Loc,
4733 Prefix =>
4734 New_Occurrence_Of (Target_Type, Loc),
4735 Attribute_Name => Name_First)))),
4737 Right_Opnd =>
4738 Make_Op_Lt (Loc,
4739 Left_Opnd =>
4740 Make_Attribute_Reference (Loc,
4741 Prefix => New_Occurrence_Of (Target_Type, Loc),
4742 Attribute_Name => Name_Last),
4743 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
4745 Right_Opnd =>
4746 Make_Op_Gt (Loc,
4747 Left_Opnd => Duplicate_Subexpr (N),
4748 Right_Opnd =>
4749 Convert_To (Source_Base_Type,
4750 Make_Attribute_Reference (Loc,
4751 Prefix => New_Occurrence_Of (Target_Type, Loc),
4752 Attribute_Name => Name_Last)))),
4754 Reason => Reason),
4755 Suppress => All_Checks);
4757 -- Only remaining possibility is that the source is signed and
4758 -- the target is unsigned
4760 else
4761 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
4762 and then Is_Unsigned_Type (Target_Base_Type));
4764 -- If the source is signed and the target is unsigned, then
4765 -- we know that the target is not shorter than the source
4766 -- (otherwise the target base type would be in the source
4767 -- base type range).
4769 -- In other words, the unsigned type is either the same size
4770 -- as the target, or it is larger. It cannot be smaller.
4772 -- Clearly we have an error if the source value is negative
4773 -- since no unsigned type can have negative values. If the
4774 -- source type is non-negative, then the check can be done
4775 -- using the target type.
4777 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4779 -- [constraint_error
4780 -- when N < 0 or else Tnn not in Target_Type];
4782 -- We turn off all checks for the conversion of N to the
4783 -- target base type, since we generate the explicit check
4784 -- to ensure that the value is non-negative
4786 declare
4787 Tnn : constant Entity_Id :=
4788 Make_Defining_Identifier (Loc,
4789 Chars => New_Internal_Name ('T'));
4791 begin
4792 Insert_Actions (N, New_List (
4793 Make_Object_Declaration (Loc,
4794 Defining_Identifier => Tnn,
4795 Object_Definition =>
4796 New_Occurrence_Of (Target_Base_Type, Loc),
4797 Constant_Present => True,
4798 Expression =>
4799 Make_Type_Conversion (Loc,
4800 Subtype_Mark =>
4801 New_Occurrence_Of (Target_Base_Type, Loc),
4802 Expression => Duplicate_Subexpr (N))),
4804 Make_Raise_Constraint_Error (Loc,
4805 Condition =>
4806 Make_Or_Else (Loc,
4807 Left_Opnd =>
4808 Make_Op_Lt (Loc,
4809 Left_Opnd => Duplicate_Subexpr (N),
4810 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4812 Right_Opnd =>
4813 Make_Not_In (Loc,
4814 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4815 Right_Opnd =>
4816 New_Occurrence_Of (Target_Type, Loc))),
4818 Reason => Reason)),
4819 Suppress => All_Checks);
4821 -- Set the Etype explicitly, because Insert_Actions may
4822 -- have placed the declaration in the freeze list for an
4823 -- enclosing construct, and thus it is not analyzed yet.
4825 Set_Etype (Tnn, Target_Base_Type);
4826 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4827 end;
4828 end if;
4829 end if;
4830 end Generate_Range_Check;
4832 ---------------------
4833 -- Get_Discriminal --
4834 ---------------------
4836 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
4837 Loc : constant Source_Ptr := Sloc (E);
4838 D : Entity_Id;
4839 Sc : Entity_Id;
4841 begin
4842 -- The entity E is the type of a private component of the protected
4843 -- type, or the type of a renaming of that component within a protected
4844 -- operation of that type.
4846 Sc := Scope (E);
4848 if Ekind (Sc) /= E_Protected_Type then
4849 Sc := Scope (Sc);
4851 if Ekind (Sc) /= E_Protected_Type then
4852 return Bound;
4853 end if;
4854 end if;
4856 -- The bound can be a bona fide parameter of a protected operation,
4857 -- rather than a prival encoded as an in-parameter.
4859 if No (Discriminal_Link (Entity (Bound))) then
4860 return Bound;
4861 end if;
4863 D := First_Discriminant (Sc);
4865 while Present (D)
4866 and then Chars (D) /= Chars (Bound)
4867 loop
4868 Next_Discriminant (D);
4869 end loop;
4871 return New_Occurrence_Of (Discriminal (D), Loc);
4872 end Get_Discriminal;
4874 ------------------
4875 -- Guard_Access --
4876 ------------------
4878 function Guard_Access
4879 (Cond : Node_Id;
4880 Loc : Source_Ptr;
4881 Ck_Node : Node_Id) return Node_Id
4883 begin
4884 if Nkind (Cond) = N_Or_Else then
4885 Set_Paren_Count (Cond, 1);
4886 end if;
4888 if Nkind (Ck_Node) = N_Allocator then
4889 return Cond;
4890 else
4891 return
4892 Make_And_Then (Loc,
4893 Left_Opnd =>
4894 Make_Op_Ne (Loc,
4895 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
4896 Right_Opnd => Make_Null (Loc)),
4897 Right_Opnd => Cond);
4898 end if;
4899 end Guard_Access;
4901 -----------------------------
4902 -- Index_Checks_Suppressed --
4903 -----------------------------
4905 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
4906 begin
4907 if Present (E) and then Checks_May_Be_Suppressed (E) then
4908 return Is_Check_Suppressed (E, Index_Check);
4909 else
4910 return Scope_Suppress (Index_Check);
4911 end if;
4912 end Index_Checks_Suppressed;
4914 ----------------
4915 -- Initialize --
4916 ----------------
4918 procedure Initialize is
4919 begin
4920 for J in Determine_Range_Cache_N'Range loop
4921 Determine_Range_Cache_N (J) := Empty;
4922 end loop;
4923 end Initialize;
4925 -------------------------
4926 -- Insert_Range_Checks --
4927 -------------------------
4929 procedure Insert_Range_Checks
4930 (Checks : Check_Result;
4931 Node : Node_Id;
4932 Suppress_Typ : Entity_Id;
4933 Static_Sloc : Source_Ptr := No_Location;
4934 Flag_Node : Node_Id := Empty;
4935 Do_Before : Boolean := False)
4937 Internal_Flag_Node : Node_Id := Flag_Node;
4938 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
4940 Check_Node : Node_Id;
4941 Checks_On : constant Boolean :=
4942 (not Index_Checks_Suppressed (Suppress_Typ))
4943 or else
4944 (not Range_Checks_Suppressed (Suppress_Typ));
4946 begin
4947 -- For now we just return if Checks_On is false, however this should
4948 -- be enhanced to check for an always True value in the condition
4949 -- and to generate a compilation warning???
4951 if not Expander_Active or else not Checks_On then
4952 return;
4953 end if;
4955 if Static_Sloc = No_Location then
4956 Internal_Static_Sloc := Sloc (Node);
4957 end if;
4959 if No (Flag_Node) then
4960 Internal_Flag_Node := Node;
4961 end if;
4963 for J in 1 .. 2 loop
4964 exit when No (Checks (J));
4966 if Nkind (Checks (J)) = N_Raise_Constraint_Error
4967 and then Present (Condition (Checks (J)))
4968 then
4969 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
4970 Check_Node := Checks (J);
4971 Mark_Rewrite_Insertion (Check_Node);
4973 if Do_Before then
4974 Insert_Before_And_Analyze (Node, Check_Node);
4975 else
4976 Insert_After_And_Analyze (Node, Check_Node);
4977 end if;
4979 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
4980 end if;
4982 else
4983 Check_Node :=
4984 Make_Raise_Constraint_Error (Internal_Static_Sloc,
4985 Reason => CE_Range_Check_Failed);
4986 Mark_Rewrite_Insertion (Check_Node);
4988 if Do_Before then
4989 Insert_Before_And_Analyze (Node, Check_Node);
4990 else
4991 Insert_After_And_Analyze (Node, Check_Node);
4992 end if;
4993 end if;
4994 end loop;
4995 end Insert_Range_Checks;
4997 ------------------------
4998 -- Insert_Valid_Check --
4999 ------------------------
5001 procedure Insert_Valid_Check (Expr : Node_Id) is
5002 Loc : constant Source_Ptr := Sloc (Expr);
5003 Exp : Node_Id;
5005 begin
5006 -- Do not insert if checks off, or if not checking validity
5008 if not Validity_Checks_On
5009 or else Range_Or_Validity_Checks_Suppressed (Expr)
5010 then
5011 return;
5012 end if;
5014 -- If we have a checked conversion, then validity check applies to
5015 -- the expression inside the conversion, not the result, since if
5016 -- the expression inside is valid, then so is the conversion result.
5018 Exp := Expr;
5019 while Nkind (Exp) = N_Type_Conversion loop
5020 Exp := Expression (Exp);
5021 end loop;
5023 -- We are about to insert the validity check for Exp. We save and
5024 -- reset the Do_Range_Check flag over this validity check, and then
5025 -- put it back for the final original reference (Exp may be rewritten).
5027 declare
5028 DRC : constant Boolean := Do_Range_Check (Exp);
5030 begin
5031 Set_Do_Range_Check (Exp, False);
5033 -- Insert the validity check. Note that we do this with validity
5034 -- checks turned off, to avoid recursion, we do not want validity
5035 -- checks on the validity checking code itself!
5037 Insert_Action
5038 (Expr,
5039 Make_Raise_Constraint_Error (Loc,
5040 Condition =>
5041 Make_Op_Not (Loc,
5042 Right_Opnd =>
5043 Make_Attribute_Reference (Loc,
5044 Prefix =>
5045 Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
5046 Attribute_Name => Name_Valid)),
5047 Reason => CE_Invalid_Data),
5048 Suppress => Validity_Check);
5050 -- If the expression is a a reference to an element of a bit-packed
5051 -- array, then it is rewritten as a renaming declaration. If the
5052 -- expression is an actual in a call, it has not been expanded,
5053 -- waiting for the proper point at which to do it. The same happens
5054 -- with renamings, so that we have to force the expansion now. This
5055 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
5056 -- and exp_ch6.adb.
5058 if Is_Entity_Name (Exp)
5059 and then Nkind (Parent (Entity (Exp))) =
5060 N_Object_Renaming_Declaration
5061 then
5062 declare
5063 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
5064 begin
5065 if Nkind (Old_Exp) = N_Indexed_Component
5066 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
5067 then
5068 Expand_Packed_Element_Reference (Old_Exp);
5069 end if;
5070 end;
5071 end if;
5073 -- Put back the Do_Range_Check flag on the resulting (possibly
5074 -- rewritten) expression.
5076 -- Note: it might be thought that a validity check is not required
5077 -- when a range check is present, but that's not the case, because
5078 -- the back end is allowed to assume for the range check that the
5079 -- operand is within its declared range (an assumption that validity
5080 -- checking is all about NOT assuming!)
5082 Set_Do_Range_Check (Exp, DRC);
5083 end;
5084 end Insert_Valid_Check;
5086 ----------------------------------
5087 -- Install_Null_Excluding_Check --
5088 ----------------------------------
5090 procedure Install_Null_Excluding_Check (N : Node_Id) is
5091 Loc : constant Source_Ptr := Sloc (N);
5092 Typ : constant Entity_Id := Etype (N);
5094 procedure Mark_Non_Null;
5095 -- After installation of check, marks node as non-null if entity
5097 -------------------
5098 -- Mark_Non_Null --
5099 -------------------
5101 procedure Mark_Non_Null is
5102 begin
5103 if Is_Entity_Name (N) then
5104 Set_Is_Known_Null (Entity (N), False);
5106 if Safe_To_Capture_Value (N, Entity (N)) then
5107 Set_Is_Known_Non_Null (Entity (N), True);
5108 end if;
5109 end if;
5110 end Mark_Non_Null;
5112 -- Start of processing for Install_Null_Excluding_Check
5114 begin
5115 pragma Assert (Is_Access_Type (Typ));
5117 -- No check inside a generic (why not???)
5119 if Inside_A_Generic then
5120 return;
5121 end if;
5123 -- No check needed if known to be non-null
5125 if Known_Non_Null (N) then
5126 return;
5127 end if;
5129 -- If known to be null, here is where we generate a compile time check
5131 if Known_Null (N) then
5132 Apply_Compile_Time_Constraint_Error
5134 "null value not allowed here?",
5135 CE_Access_Check_Failed);
5136 Mark_Non_Null;
5137 return;
5138 end if;
5140 -- If entity is never assigned, for sure a warning is appropriate
5142 if Is_Entity_Name (N) then
5143 Check_Unset_Reference (N);
5144 end if;
5146 -- No check needed if checks are suppressed on the range. Note that we
5147 -- don't set Is_Known_Non_Null in this case (we could legitimately do
5148 -- so, since the program is erroneous, but we don't like to casually
5149 -- propagate such conclusions from erroneosity).
5151 if Access_Checks_Suppressed (Typ) then
5152 return;
5153 end if;
5155 -- Otherwise install access check
5157 Insert_Action (N,
5158 Make_Raise_Constraint_Error (Loc,
5159 Condition =>
5160 Make_Op_Eq (Loc,
5161 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
5162 Right_Opnd => Make_Null (Loc)),
5163 Reason => CE_Access_Check_Failed));
5165 Mark_Non_Null;
5166 end Install_Null_Excluding_Check;
5168 --------------------------
5169 -- Install_Static_Check --
5170 --------------------------
5172 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
5173 Stat : constant Boolean := Is_Static_Expression (R_Cno);
5174 Typ : constant Entity_Id := Etype (R_Cno);
5176 begin
5177 Rewrite (R_Cno,
5178 Make_Raise_Constraint_Error (Loc,
5179 Reason => CE_Range_Check_Failed));
5180 Set_Analyzed (R_Cno);
5181 Set_Etype (R_Cno, Typ);
5182 Set_Raises_Constraint_Error (R_Cno);
5183 Set_Is_Static_Expression (R_Cno, Stat);
5184 end Install_Static_Check;
5186 ---------------------
5187 -- Kill_All_Checks --
5188 ---------------------
5190 procedure Kill_All_Checks is
5191 begin
5192 if Debug_Flag_CC then
5193 w ("Kill_All_Checks");
5194 end if;
5196 -- We reset the number of saved checks to zero, and also modify
5197 -- all stack entries for statement ranges to indicate that the
5198 -- number of checks at each level is now zero.
5200 Num_Saved_Checks := 0;
5202 for J in 1 .. Saved_Checks_TOS loop
5203 Saved_Checks_Stack (J) := 0;
5204 end loop;
5205 end Kill_All_Checks;
5207 -----------------
5208 -- Kill_Checks --
5209 -----------------
5211 procedure Kill_Checks (V : Entity_Id) is
5212 begin
5213 if Debug_Flag_CC then
5214 w ("Kill_Checks for entity", Int (V));
5215 end if;
5217 for J in 1 .. Num_Saved_Checks loop
5218 if Saved_Checks (J).Entity = V then
5219 if Debug_Flag_CC then
5220 w (" Checks killed for saved check ", J);
5221 end if;
5223 Saved_Checks (J).Killed := True;
5224 end if;
5225 end loop;
5226 end Kill_Checks;
5228 ------------------------------
5229 -- Length_Checks_Suppressed --
5230 ------------------------------
5232 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
5233 begin
5234 if Present (E) and then Checks_May_Be_Suppressed (E) then
5235 return Is_Check_Suppressed (E, Length_Check);
5236 else
5237 return Scope_Suppress (Length_Check);
5238 end if;
5239 end Length_Checks_Suppressed;
5241 --------------------------------
5242 -- Overflow_Checks_Suppressed --
5243 --------------------------------
5245 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
5246 begin
5247 if Present (E) and then Checks_May_Be_Suppressed (E) then
5248 return Is_Check_Suppressed (E, Overflow_Check);
5249 else
5250 return Scope_Suppress (Overflow_Check);
5251 end if;
5252 end Overflow_Checks_Suppressed;
5254 -----------------
5255 -- Range_Check --
5256 -----------------
5258 function Range_Check
5259 (Ck_Node : Node_Id;
5260 Target_Typ : Entity_Id;
5261 Source_Typ : Entity_Id := Empty;
5262 Warn_Node : Node_Id := Empty) return Check_Result
5264 begin
5265 return Selected_Range_Checks
5266 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
5267 end Range_Check;
5269 -----------------------------
5270 -- Range_Checks_Suppressed --
5271 -----------------------------
5273 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
5274 begin
5275 if Present (E) then
5277 -- Note: for now we always suppress range checks on Vax float types,
5278 -- since Gigi does not know how to generate these checks.
5280 if Vax_Float (E) then
5281 return True;
5282 elsif Kill_Range_Checks (E) then
5283 return True;
5284 elsif Checks_May_Be_Suppressed (E) then
5285 return Is_Check_Suppressed (E, Range_Check);
5286 end if;
5287 end if;
5289 return Scope_Suppress (Range_Check);
5290 end Range_Checks_Suppressed;
5292 -----------------------------------------
5293 -- Range_Or_Validity_Checks_Suppressed --
5294 -----------------------------------------
5296 -- Note: the coding would be simpler here if we simply made appropriate
5297 -- calls to Range/Validity_Checks_Suppressed, but that would result in
5298 -- duplicated checks which we prefer to avoid.
5300 function Range_Or_Validity_Checks_Suppressed
5301 (Expr : Node_Id) return Boolean
5303 begin
5304 -- Immediate return if scope checks suppressed for either check
5306 if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then
5307 return True;
5308 end if;
5310 -- If no expression, that's odd, decide that checks are suppressed,
5311 -- since we don't want anyone trying to do checks in this case, which
5312 -- is most likely the result of some other error.
5314 if No (Expr) then
5315 return True;
5316 end if;
5318 -- Expression is present, so perform suppress checks on type
5320 declare
5321 Typ : constant Entity_Id := Etype (Expr);
5322 begin
5323 if Vax_Float (Typ) then
5324 return True;
5325 elsif Checks_May_Be_Suppressed (Typ)
5326 and then (Is_Check_Suppressed (Typ, Range_Check)
5327 or else
5328 Is_Check_Suppressed (Typ, Validity_Check))
5329 then
5330 return True;
5331 end if;
5332 end;
5334 -- If expression is an entity name, perform checks on this entity
5336 if Is_Entity_Name (Expr) then
5337 declare
5338 Ent : constant Entity_Id := Entity (Expr);
5339 begin
5340 if Checks_May_Be_Suppressed (Ent) then
5341 return Is_Check_Suppressed (Ent, Range_Check)
5342 or else Is_Check_Suppressed (Ent, Validity_Check);
5343 end if;
5344 end;
5345 end if;
5347 -- If we fall through, no checks suppressed
5349 return False;
5350 end Range_Or_Validity_Checks_Suppressed;
5352 -------------------
5353 -- Remove_Checks --
5354 -------------------
5356 procedure Remove_Checks (Expr : Node_Id) is
5357 Discard : Traverse_Result;
5358 pragma Warnings (Off, Discard);
5360 function Process (N : Node_Id) return Traverse_Result;
5361 -- Process a single node during the traversal
5363 function Traverse is new Traverse_Func (Process);
5364 -- The traversal function itself
5366 -------------
5367 -- Process --
5368 -------------
5370 function Process (N : Node_Id) return Traverse_Result is
5371 begin
5372 if Nkind (N) not in N_Subexpr then
5373 return Skip;
5374 end if;
5376 Set_Do_Range_Check (N, False);
5378 case Nkind (N) is
5379 when N_And_Then =>
5380 Discard := Traverse (Left_Opnd (N));
5381 return Skip;
5383 when N_Attribute_Reference =>
5384 Set_Do_Overflow_Check (N, False);
5386 when N_Function_Call =>
5387 Set_Do_Tag_Check (N, False);
5389 when N_Op =>
5390 Set_Do_Overflow_Check (N, False);
5392 case Nkind (N) is
5393 when N_Op_Divide =>
5394 Set_Do_Division_Check (N, False);
5396 when N_Op_And =>
5397 Set_Do_Length_Check (N, False);
5399 when N_Op_Mod =>
5400 Set_Do_Division_Check (N, False);
5402 when N_Op_Or =>
5403 Set_Do_Length_Check (N, False);
5405 when N_Op_Rem =>
5406 Set_Do_Division_Check (N, False);
5408 when N_Op_Xor =>
5409 Set_Do_Length_Check (N, False);
5411 when others =>
5412 null;
5413 end case;
5415 when N_Or_Else =>
5416 Discard := Traverse (Left_Opnd (N));
5417 return Skip;
5419 when N_Selected_Component =>
5420 Set_Do_Discriminant_Check (N, False);
5422 when N_Type_Conversion =>
5423 Set_Do_Length_Check (N, False);
5424 Set_Do_Tag_Check (N, False);
5425 Set_Do_Overflow_Check (N, False);
5427 when others =>
5428 null;
5429 end case;
5431 return OK;
5432 end Process;
5434 -- Start of processing for Remove_Checks
5436 begin
5437 Discard := Traverse (Expr);
5438 end Remove_Checks;
5440 ----------------------------
5441 -- Selected_Length_Checks --
5442 ----------------------------
5444 function Selected_Length_Checks
5445 (Ck_Node : Node_Id;
5446 Target_Typ : Entity_Id;
5447 Source_Typ : Entity_Id;
5448 Warn_Node : Node_Id) return Check_Result
5450 Loc : constant Source_Ptr := Sloc (Ck_Node);
5451 S_Typ : Entity_Id;
5452 T_Typ : Entity_Id;
5453 Expr_Actual : Node_Id;
5454 Exptyp : Entity_Id;
5455 Cond : Node_Id := Empty;
5456 Do_Access : Boolean := False;
5457 Wnode : Node_Id := Warn_Node;
5458 Ret_Result : Check_Result := (Empty, Empty);
5459 Num_Checks : Natural := 0;
5461 procedure Add_Check (N : Node_Id);
5462 -- Adds the action given to Ret_Result if N is non-Empty
5464 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
5465 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
5466 -- Comments required ???
5468 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
5469 -- True for equal literals and for nodes that denote the same constant
5470 -- entity, even if its value is not a static constant. This includes the
5471 -- case of a discriminal reference within an init proc. Removes some
5472 -- obviously superfluous checks.
5474 function Length_E_Cond
5475 (Exptyp : Entity_Id;
5476 Typ : Entity_Id;
5477 Indx : Nat) return Node_Id;
5478 -- Returns expression to compute:
5479 -- Typ'Length /= Exptyp'Length
5481 function Length_N_Cond
5482 (Expr : Node_Id;
5483 Typ : Entity_Id;
5484 Indx : Nat) return Node_Id;
5485 -- Returns expression to compute:
5486 -- Typ'Length /= Expr'Length
5488 ---------------
5489 -- Add_Check --
5490 ---------------
5492 procedure Add_Check (N : Node_Id) is
5493 begin
5494 if Present (N) then
5496 -- For now, ignore attempt to place more than 2 checks ???
5498 if Num_Checks = 2 then
5499 return;
5500 end if;
5502 pragma Assert (Num_Checks <= 1);
5503 Num_Checks := Num_Checks + 1;
5504 Ret_Result (Num_Checks) := N;
5505 end if;
5506 end Add_Check;
5508 ------------------
5509 -- Get_E_Length --
5510 ------------------
5512 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
5513 Pt : constant Entity_Id := Scope (Scope (E));
5514 N : Node_Id;
5515 E1 : Entity_Id := E;
5517 begin
5518 if Ekind (Scope (E)) = E_Record_Type
5519 and then Has_Discriminants (Scope (E))
5520 then
5521 N := Build_Discriminal_Subtype_Of_Component (E);
5523 if Present (N) then
5524 Insert_Action (Ck_Node, N);
5525 E1 := Defining_Identifier (N);
5526 end if;
5527 end if;
5529 if Ekind (E1) = E_String_Literal_Subtype then
5530 return
5531 Make_Integer_Literal (Loc,
5532 Intval => String_Literal_Length (E1));
5534 elsif Ekind (Pt) = E_Protected_Type
5535 and then Has_Discriminants (Pt)
5536 and then Has_Completion (Pt)
5537 and then not Inside_Init_Proc
5538 then
5540 -- If the type whose length is needed is a private component
5541 -- constrained by a discriminant, we must expand the 'Length
5542 -- attribute into an explicit computation, using the discriminal
5543 -- of the current protected operation. This is because the actual
5544 -- type of the prival is constructed after the protected opera-
5545 -- tion has been fully expanded.
5547 declare
5548 Indx_Type : Node_Id;
5549 Lo : Node_Id;
5550 Hi : Node_Id;
5551 Do_Expand : Boolean := False;
5553 begin
5554 Indx_Type := First_Index (E);
5556 for J in 1 .. Indx - 1 loop
5557 Next_Index (Indx_Type);
5558 end loop;
5560 Get_Index_Bounds (Indx_Type, Lo, Hi);
5562 if Nkind (Lo) = N_Identifier
5563 and then Ekind (Entity (Lo)) = E_In_Parameter
5564 then
5565 Lo := Get_Discriminal (E, Lo);
5566 Do_Expand := True;
5567 end if;
5569 if Nkind (Hi) = N_Identifier
5570 and then Ekind (Entity (Hi)) = E_In_Parameter
5571 then
5572 Hi := Get_Discriminal (E, Hi);
5573 Do_Expand := True;
5574 end if;
5576 if Do_Expand then
5577 if not Is_Entity_Name (Lo) then
5578 Lo := Duplicate_Subexpr_No_Checks (Lo);
5579 end if;
5581 if not Is_Entity_Name (Hi) then
5582 Lo := Duplicate_Subexpr_No_Checks (Hi);
5583 end if;
5585 N :=
5586 Make_Op_Add (Loc,
5587 Left_Opnd =>
5588 Make_Op_Subtract (Loc,
5589 Left_Opnd => Hi,
5590 Right_Opnd => Lo),
5592 Right_Opnd => Make_Integer_Literal (Loc, 1));
5593 return N;
5595 else
5596 N :=
5597 Make_Attribute_Reference (Loc,
5598 Attribute_Name => Name_Length,
5599 Prefix =>
5600 New_Occurrence_Of (E1, Loc));
5602 if Indx > 1 then
5603 Set_Expressions (N, New_List (
5604 Make_Integer_Literal (Loc, Indx)));
5605 end if;
5607 return N;
5608 end if;
5609 end;
5611 else
5612 N :=
5613 Make_Attribute_Reference (Loc,
5614 Attribute_Name => Name_Length,
5615 Prefix =>
5616 New_Occurrence_Of (E1, Loc));
5618 if Indx > 1 then
5619 Set_Expressions (N, New_List (
5620 Make_Integer_Literal (Loc, Indx)));
5621 end if;
5623 return N;
5625 end if;
5626 end Get_E_Length;
5628 ------------------
5629 -- Get_N_Length --
5630 ------------------
5632 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
5633 begin
5634 return
5635 Make_Attribute_Reference (Loc,
5636 Attribute_Name => Name_Length,
5637 Prefix =>
5638 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5639 Expressions => New_List (
5640 Make_Integer_Literal (Loc, Indx)));
5642 end Get_N_Length;
5644 -------------------
5645 -- Length_E_Cond --
5646 -------------------
5648 function Length_E_Cond
5649 (Exptyp : Entity_Id;
5650 Typ : Entity_Id;
5651 Indx : Nat) return Node_Id
5653 begin
5654 return
5655 Make_Op_Ne (Loc,
5656 Left_Opnd => Get_E_Length (Typ, Indx),
5657 Right_Opnd => Get_E_Length (Exptyp, Indx));
5659 end Length_E_Cond;
5661 -------------------
5662 -- Length_N_Cond --
5663 -------------------
5665 function Length_N_Cond
5666 (Expr : Node_Id;
5667 Typ : Entity_Id;
5668 Indx : Nat) return Node_Id
5670 begin
5671 return
5672 Make_Op_Ne (Loc,
5673 Left_Opnd => Get_E_Length (Typ, Indx),
5674 Right_Opnd => Get_N_Length (Expr, Indx));
5676 end Length_N_Cond;
5678 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
5679 begin
5680 return
5681 (Nkind (L) = N_Integer_Literal
5682 and then Nkind (R) = N_Integer_Literal
5683 and then Intval (L) = Intval (R))
5685 or else
5686 (Is_Entity_Name (L)
5687 and then Ekind (Entity (L)) = E_Constant
5688 and then ((Is_Entity_Name (R)
5689 and then Entity (L) = Entity (R))
5690 or else
5691 (Nkind (R) = N_Type_Conversion
5692 and then Is_Entity_Name (Expression (R))
5693 and then Entity (L) = Entity (Expression (R)))))
5695 or else
5696 (Is_Entity_Name (R)
5697 and then Ekind (Entity (R)) = E_Constant
5698 and then Nkind (L) = N_Type_Conversion
5699 and then Is_Entity_Name (Expression (L))
5700 and then Entity (R) = Entity (Expression (L)))
5702 or else
5703 (Is_Entity_Name (L)
5704 and then Is_Entity_Name (R)
5705 and then Entity (L) = Entity (R)
5706 and then Ekind (Entity (L)) = E_In_Parameter
5707 and then Inside_Init_Proc);
5708 end Same_Bounds;
5710 -- Start of processing for Selected_Length_Checks
5712 begin
5713 if not Expander_Active then
5714 return Ret_Result;
5715 end if;
5717 if Target_Typ = Any_Type
5718 or else Target_Typ = Any_Composite
5719 or else Raises_Constraint_Error (Ck_Node)
5720 then
5721 return Ret_Result;
5722 end if;
5724 if No (Wnode) then
5725 Wnode := Ck_Node;
5726 end if;
5728 T_Typ := Target_Typ;
5730 if No (Source_Typ) then
5731 S_Typ := Etype (Ck_Node);
5732 else
5733 S_Typ := Source_Typ;
5734 end if;
5736 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5737 return Ret_Result;
5738 end if;
5740 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5741 S_Typ := Designated_Type (S_Typ);
5742 T_Typ := Designated_Type (T_Typ);
5743 Do_Access := True;
5745 -- A simple optimization
5747 if Nkind (Ck_Node) = N_Null then
5748 return Ret_Result;
5749 end if;
5750 end if;
5752 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
5753 if Is_Constrained (T_Typ) then
5755 -- The checking code to be generated will freeze the
5756 -- corresponding array type. However, we must freeze the
5757 -- type now, so that the freeze node does not appear within
5758 -- the generated condional expression, but ahead of it.
5760 Freeze_Before (Ck_Node, T_Typ);
5762 Expr_Actual := Get_Referenced_Object (Ck_Node);
5763 Exptyp := Get_Actual_Subtype (Ck_Node);
5765 if Is_Access_Type (Exptyp) then
5766 Exptyp := Designated_Type (Exptyp);
5767 end if;
5769 -- String_Literal case. This needs to be handled specially be-
5770 -- cause no index types are available for string literals. The
5771 -- condition is simply:
5773 -- T_Typ'Length = string-literal-length
5775 if Nkind (Expr_Actual) = N_String_Literal
5776 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
5777 then
5778 Cond :=
5779 Make_Op_Ne (Loc,
5780 Left_Opnd => Get_E_Length (T_Typ, 1),
5781 Right_Opnd =>
5782 Make_Integer_Literal (Loc,
5783 Intval =>
5784 String_Literal_Length (Etype (Expr_Actual))));
5786 -- General array case. Here we have a usable actual subtype for
5787 -- the expression, and the condition is built from the two types
5788 -- (Do_Length):
5790 -- T_Typ'Length /= Exptyp'Length or else
5791 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5792 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5793 -- ...
5795 elsif Is_Constrained (Exptyp) then
5796 declare
5797 Ndims : constant Nat := Number_Dimensions (T_Typ);
5799 L_Index : Node_Id;
5800 R_Index : Node_Id;
5801 L_Low : Node_Id;
5802 L_High : Node_Id;
5803 R_Low : Node_Id;
5804 R_High : Node_Id;
5805 L_Length : Uint;
5806 R_Length : Uint;
5807 Ref_Node : Node_Id;
5809 begin
5811 -- At the library level, we need to ensure that the
5812 -- type of the object is elaborated before the check
5813 -- itself is emitted. This is only done if the object
5814 -- is in the current compilation unit, otherwise the
5815 -- type is frozen and elaborated in its unit.
5817 if Is_Itype (Exptyp)
5818 and then
5819 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
5820 and then
5821 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
5822 and then In_Open_Scopes (Scope (Exptyp))
5823 then
5824 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
5825 Set_Itype (Ref_Node, Exptyp);
5826 Insert_Action (Ck_Node, Ref_Node);
5827 end if;
5829 L_Index := First_Index (T_Typ);
5830 R_Index := First_Index (Exptyp);
5832 for Indx in 1 .. Ndims loop
5833 if not (Nkind (L_Index) = N_Raise_Constraint_Error
5834 or else
5835 Nkind (R_Index) = N_Raise_Constraint_Error)
5836 then
5837 Get_Index_Bounds (L_Index, L_Low, L_High);
5838 Get_Index_Bounds (R_Index, R_Low, R_High);
5840 -- Deal with compile time length check. Note that we
5841 -- skip this in the access case, because the access
5842 -- value may be null, so we cannot know statically.
5844 if not Do_Access
5845 and then Compile_Time_Known_Value (L_Low)
5846 and then Compile_Time_Known_Value (L_High)
5847 and then Compile_Time_Known_Value (R_Low)
5848 and then Compile_Time_Known_Value (R_High)
5849 then
5850 if Expr_Value (L_High) >= Expr_Value (L_Low) then
5851 L_Length := Expr_Value (L_High) -
5852 Expr_Value (L_Low) + 1;
5853 else
5854 L_Length := UI_From_Int (0);
5855 end if;
5857 if Expr_Value (R_High) >= Expr_Value (R_Low) then
5858 R_Length := Expr_Value (R_High) -
5859 Expr_Value (R_Low) + 1;
5860 else
5861 R_Length := UI_From_Int (0);
5862 end if;
5864 if L_Length > R_Length then
5865 Add_Check
5866 (Compile_Time_Constraint_Error
5867 (Wnode, "too few elements for}?", T_Typ));
5869 elsif L_Length < R_Length then
5870 Add_Check
5871 (Compile_Time_Constraint_Error
5872 (Wnode, "too many elements for}?", T_Typ));
5873 end if;
5875 -- The comparison for an individual index subtype
5876 -- is omitted if the corresponding index subtypes
5877 -- statically match, since the result is known to
5878 -- be true. Note that this test is worth while even
5879 -- though we do static evaluation, because non-static
5880 -- subtypes can statically match.
5882 elsif not
5883 Subtypes_Statically_Match
5884 (Etype (L_Index), Etype (R_Index))
5886 and then not
5887 (Same_Bounds (L_Low, R_Low)
5888 and then Same_Bounds (L_High, R_High))
5889 then
5890 Evolve_Or_Else
5891 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
5892 end if;
5894 Next (L_Index);
5895 Next (R_Index);
5896 end if;
5897 end loop;
5898 end;
5900 -- Handle cases where we do not get a usable actual subtype that
5901 -- is constrained. This happens for example in the function call
5902 -- and explicit dereference cases. In these cases, we have to get
5903 -- the length or range from the expression itself, making sure we
5904 -- do not evaluate it more than once.
5906 -- Here Ck_Node is the original expression, or more properly the
5907 -- result of applying Duplicate_Expr to the original tree,
5908 -- forcing the result to be a name.
5910 else
5911 declare
5912 Ndims : constant Nat := Number_Dimensions (T_Typ);
5914 begin
5915 -- Build the condition for the explicit dereference case
5917 for Indx in 1 .. Ndims loop
5918 Evolve_Or_Else
5919 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
5920 end loop;
5921 end;
5922 end if;
5923 end if;
5924 end if;
5926 -- Construct the test and insert into the tree
5928 if Present (Cond) then
5929 if Do_Access then
5930 Cond := Guard_Access (Cond, Loc, Ck_Node);
5931 end if;
5933 Add_Check
5934 (Make_Raise_Constraint_Error (Loc,
5935 Condition => Cond,
5936 Reason => CE_Length_Check_Failed));
5937 end if;
5939 return Ret_Result;
5940 end Selected_Length_Checks;
5942 ---------------------------
5943 -- Selected_Range_Checks --
5944 ---------------------------
5946 function Selected_Range_Checks
5947 (Ck_Node : Node_Id;
5948 Target_Typ : Entity_Id;
5949 Source_Typ : Entity_Id;
5950 Warn_Node : Node_Id) return Check_Result
5952 Loc : constant Source_Ptr := Sloc (Ck_Node);
5953 S_Typ : Entity_Id;
5954 T_Typ : Entity_Id;
5955 Expr_Actual : Node_Id;
5956 Exptyp : Entity_Id;
5957 Cond : Node_Id := Empty;
5958 Do_Access : Boolean := False;
5959 Wnode : Node_Id := Warn_Node;
5960 Ret_Result : Check_Result := (Empty, Empty);
5961 Num_Checks : Integer := 0;
5963 procedure Add_Check (N : Node_Id);
5964 -- Adds the action given to Ret_Result if N is non-Empty
5966 function Discrete_Range_Cond
5967 (Expr : Node_Id;
5968 Typ : Entity_Id) return Node_Id;
5969 -- Returns expression to compute:
5970 -- Low_Bound (Expr) < Typ'First
5971 -- or else
5972 -- High_Bound (Expr) > Typ'Last
5974 function Discrete_Expr_Cond
5975 (Expr : Node_Id;
5976 Typ : Entity_Id) return Node_Id;
5977 -- Returns expression to compute:
5978 -- Expr < Typ'First
5979 -- or else
5980 -- Expr > Typ'Last
5982 function Get_E_First_Or_Last
5983 (E : Entity_Id;
5984 Indx : Nat;
5985 Nam : Name_Id) return Node_Id;
5986 -- Returns expression to compute:
5987 -- E'First or E'Last
5989 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
5990 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
5991 -- Returns expression to compute:
5992 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
5994 function Range_E_Cond
5995 (Exptyp : Entity_Id;
5996 Typ : Entity_Id;
5997 Indx : Nat)
5998 return Node_Id;
5999 -- Returns expression to compute:
6000 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
6002 function Range_Equal_E_Cond
6003 (Exptyp : Entity_Id;
6004 Typ : Entity_Id;
6005 Indx : Nat) return Node_Id;
6006 -- Returns expression to compute:
6007 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
6009 function Range_N_Cond
6010 (Expr : Node_Id;
6011 Typ : Entity_Id;
6012 Indx : Nat) return Node_Id;
6013 -- Return expression to compute:
6014 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
6016 ---------------
6017 -- Add_Check --
6018 ---------------
6020 procedure Add_Check (N : Node_Id) is
6021 begin
6022 if Present (N) then
6024 -- For now, ignore attempt to place more than 2 checks ???
6026 if Num_Checks = 2 then
6027 return;
6028 end if;
6030 pragma Assert (Num_Checks <= 1);
6031 Num_Checks := Num_Checks + 1;
6032 Ret_Result (Num_Checks) := N;
6033 end if;
6034 end Add_Check;
6036 -------------------------
6037 -- Discrete_Expr_Cond --
6038 -------------------------
6040 function Discrete_Expr_Cond
6041 (Expr : Node_Id;
6042 Typ : Entity_Id) return Node_Id
6044 begin
6045 return
6046 Make_Or_Else (Loc,
6047 Left_Opnd =>
6048 Make_Op_Lt (Loc,
6049 Left_Opnd =>
6050 Convert_To (Base_Type (Typ),
6051 Duplicate_Subexpr_No_Checks (Expr)),
6052 Right_Opnd =>
6053 Convert_To (Base_Type (Typ),
6054 Get_E_First_Or_Last (Typ, 0, Name_First))),
6056 Right_Opnd =>
6057 Make_Op_Gt (Loc,
6058 Left_Opnd =>
6059 Convert_To (Base_Type (Typ),
6060 Duplicate_Subexpr_No_Checks (Expr)),
6061 Right_Opnd =>
6062 Convert_To
6063 (Base_Type (Typ),
6064 Get_E_First_Or_Last (Typ, 0, Name_Last))));
6065 end Discrete_Expr_Cond;
6067 -------------------------
6068 -- Discrete_Range_Cond --
6069 -------------------------
6071 function Discrete_Range_Cond
6072 (Expr : Node_Id;
6073 Typ : Entity_Id) return Node_Id
6075 LB : Node_Id := Low_Bound (Expr);
6076 HB : Node_Id := High_Bound (Expr);
6078 Left_Opnd : Node_Id;
6079 Right_Opnd : Node_Id;
6081 begin
6082 if Nkind (LB) = N_Identifier
6083 and then Ekind (Entity (LB)) = E_Discriminant then
6084 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
6085 end if;
6087 if Nkind (HB) = N_Identifier
6088 and then Ekind (Entity (HB)) = E_Discriminant then
6089 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
6090 end if;
6092 Left_Opnd :=
6093 Make_Op_Lt (Loc,
6094 Left_Opnd =>
6095 Convert_To
6096 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
6098 Right_Opnd =>
6099 Convert_To
6100 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
6102 if Base_Type (Typ) = Typ then
6103 return Left_Opnd;
6105 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
6106 and then
6107 Compile_Time_Known_Value (High_Bound (Scalar_Range
6108 (Base_Type (Typ))))
6109 then
6110 if Is_Floating_Point_Type (Typ) then
6111 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
6112 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
6113 then
6114 return Left_Opnd;
6115 end if;
6117 else
6118 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
6119 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
6120 then
6121 return Left_Opnd;
6122 end if;
6123 end if;
6124 end if;
6126 Right_Opnd :=
6127 Make_Op_Gt (Loc,
6128 Left_Opnd =>
6129 Convert_To
6130 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
6132 Right_Opnd =>
6133 Convert_To
6134 (Base_Type (Typ),
6135 Get_E_First_Or_Last (Typ, 0, Name_Last)));
6137 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
6138 end Discrete_Range_Cond;
6140 -------------------------
6141 -- Get_E_First_Or_Last --
6142 -------------------------
6144 function Get_E_First_Or_Last
6145 (E : Entity_Id;
6146 Indx : Nat;
6147 Nam : Name_Id) return Node_Id
6149 N : Node_Id;
6150 LB : Node_Id;
6151 HB : Node_Id;
6152 Bound : Node_Id;
6154 begin
6155 if Is_Array_Type (E) then
6156 N := First_Index (E);
6158 for J in 2 .. Indx loop
6159 Next_Index (N);
6160 end loop;
6162 else
6163 N := Scalar_Range (E);
6164 end if;
6166 if Nkind (N) = N_Subtype_Indication then
6167 LB := Low_Bound (Range_Expression (Constraint (N)));
6168 HB := High_Bound (Range_Expression (Constraint (N)));
6170 elsif Is_Entity_Name (N) then
6171 LB := Type_Low_Bound (Etype (N));
6172 HB := Type_High_Bound (Etype (N));
6174 else
6175 LB := Low_Bound (N);
6176 HB := High_Bound (N);
6177 end if;
6179 if Nam = Name_First then
6180 Bound := LB;
6181 else
6182 Bound := HB;
6183 end if;
6185 if Nkind (Bound) = N_Identifier
6186 and then Ekind (Entity (Bound)) = E_Discriminant
6187 then
6188 -- If this is a task discriminant, and we are the body, we must
6189 -- retrieve the corresponding body discriminal. This is another
6190 -- consequence of the early creation of discriminals, and the
6191 -- need to generate constraint checks before their declarations
6192 -- are made visible.
6194 if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
6195 declare
6196 Tsk : constant Entity_Id :=
6197 Corresponding_Concurrent_Type
6198 (Scope (Entity (Bound)));
6199 Disc : Entity_Id;
6201 begin
6202 if In_Open_Scopes (Tsk)
6203 and then Has_Completion (Tsk)
6204 then
6205 -- Find discriminant of original task, and use its
6206 -- current discriminal, which is the renaming within
6207 -- the task body.
6209 Disc := First_Discriminant (Tsk);
6210 while Present (Disc) loop
6211 if Chars (Disc) = Chars (Entity (Bound)) then
6212 Set_Scope (Discriminal (Disc), Tsk);
6213 return New_Occurrence_Of (Discriminal (Disc), Loc);
6214 end if;
6216 Next_Discriminant (Disc);
6217 end loop;
6219 -- That loop should always succeed in finding a matching
6220 -- entry and returning. Fatal error if not.
6222 raise Program_Error;
6224 else
6225 return
6226 New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
6227 end if;
6228 end;
6229 else
6230 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
6231 end if;
6233 elsif Nkind (Bound) = N_Identifier
6234 and then Ekind (Entity (Bound)) = E_In_Parameter
6235 and then not Inside_Init_Proc
6236 then
6237 return Get_Discriminal (E, Bound);
6239 elsif Nkind (Bound) = N_Integer_Literal then
6240 return Make_Integer_Literal (Loc, Intval (Bound));
6242 -- Case of a bound that has been rewritten to an
6243 -- N_Raise_Constraint_Error node because it is an out-of-range
6244 -- value. We may not call Duplicate_Subexpr on this node because
6245 -- an N_Raise_Constraint_Error is not side effect free, and we may
6246 -- not assume that we are in the proper context to remove side
6247 -- effects on it at the point of reference.
6249 elsif Nkind (Bound) = N_Raise_Constraint_Error then
6250 return New_Copy_Tree (Bound);
6252 else
6253 return Duplicate_Subexpr_No_Checks (Bound);
6254 end if;
6255 end Get_E_First_Or_Last;
6257 -----------------
6258 -- Get_N_First --
6259 -----------------
6261 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
6262 begin
6263 return
6264 Make_Attribute_Reference (Loc,
6265 Attribute_Name => Name_First,
6266 Prefix =>
6267 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
6268 Expressions => New_List (
6269 Make_Integer_Literal (Loc, Indx)));
6270 end Get_N_First;
6272 ----------------
6273 -- Get_N_Last --
6274 ----------------
6276 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
6277 begin
6278 return
6279 Make_Attribute_Reference (Loc,
6280 Attribute_Name => Name_Last,
6281 Prefix =>
6282 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
6283 Expressions => New_List (
6284 Make_Integer_Literal (Loc, Indx)));
6285 end Get_N_Last;
6287 ------------------
6288 -- Range_E_Cond --
6289 ------------------
6291 function Range_E_Cond
6292 (Exptyp : Entity_Id;
6293 Typ : Entity_Id;
6294 Indx : Nat) return Node_Id
6296 begin
6297 return
6298 Make_Or_Else (Loc,
6299 Left_Opnd =>
6300 Make_Op_Lt (Loc,
6301 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
6302 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
6304 Right_Opnd =>
6305 Make_Op_Gt (Loc,
6306 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
6307 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
6309 end Range_E_Cond;
6311 ------------------------
6312 -- Range_Equal_E_Cond --
6313 ------------------------
6315 function Range_Equal_E_Cond
6316 (Exptyp : Entity_Id;
6317 Typ : Entity_Id;
6318 Indx : Nat) return Node_Id
6320 begin
6321 return
6322 Make_Or_Else (Loc,
6323 Left_Opnd =>
6324 Make_Op_Ne (Loc,
6325 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
6326 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
6327 Right_Opnd =>
6328 Make_Op_Ne (Loc,
6329 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
6330 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
6331 end Range_Equal_E_Cond;
6333 ------------------
6334 -- Range_N_Cond --
6335 ------------------
6337 function Range_N_Cond
6338 (Expr : Node_Id;
6339 Typ : Entity_Id;
6340 Indx : Nat) return Node_Id
6342 begin
6343 return
6344 Make_Or_Else (Loc,
6345 Left_Opnd =>
6346 Make_Op_Lt (Loc,
6347 Left_Opnd => Get_N_First (Expr, Indx),
6348 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
6350 Right_Opnd =>
6351 Make_Op_Gt (Loc,
6352 Left_Opnd => Get_N_Last (Expr, Indx),
6353 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
6354 end Range_N_Cond;
6356 -- Start of processing for Selected_Range_Checks
6358 begin
6359 if not Expander_Active then
6360 return Ret_Result;
6361 end if;
6363 if Target_Typ = Any_Type
6364 or else Target_Typ = Any_Composite
6365 or else Raises_Constraint_Error (Ck_Node)
6366 then
6367 return Ret_Result;
6368 end if;
6370 if No (Wnode) then
6371 Wnode := Ck_Node;
6372 end if;
6374 T_Typ := Target_Typ;
6376 if No (Source_Typ) then
6377 S_Typ := Etype (Ck_Node);
6378 else
6379 S_Typ := Source_Typ;
6380 end if;
6382 if S_Typ = Any_Type or else S_Typ = Any_Composite then
6383 return Ret_Result;
6384 end if;
6386 -- The order of evaluating T_Typ before S_Typ seems to be critical
6387 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
6388 -- in, and since Node can be an N_Range node, it might be invalid.
6389 -- Should there be an assert check somewhere for taking the Etype of
6390 -- an N_Range node ???
6392 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
6393 S_Typ := Designated_Type (S_Typ);
6394 T_Typ := Designated_Type (T_Typ);
6395 Do_Access := True;
6397 -- A simple optimization
6399 if Nkind (Ck_Node) = N_Null then
6400 return Ret_Result;
6401 end if;
6402 end if;
6404 -- For an N_Range Node, check for a null range and then if not
6405 -- null generate a range check action.
6407 if Nkind (Ck_Node) = N_Range then
6409 -- There's no point in checking a range against itself
6411 if Ck_Node = Scalar_Range (T_Typ) then
6412 return Ret_Result;
6413 end if;
6415 declare
6416 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
6417 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
6418 LB : constant Node_Id := Low_Bound (Ck_Node);
6419 HB : constant Node_Id := High_Bound (Ck_Node);
6420 Null_Range : Boolean;
6422 Out_Of_Range_L : Boolean;
6423 Out_Of_Range_H : Boolean;
6425 begin
6426 -- Check for case where everything is static and we can
6427 -- do the check at compile time. This is skipped if we
6428 -- have an access type, since the access value may be null.
6430 -- ??? This code can be improved since you only need to know
6431 -- that the two respective bounds (LB & T_LB or HB & T_HB)
6432 -- are known at compile time to emit pertinent messages.
6434 if Compile_Time_Known_Value (LB)
6435 and then Compile_Time_Known_Value (HB)
6436 and then Compile_Time_Known_Value (T_LB)
6437 and then Compile_Time_Known_Value (T_HB)
6438 and then not Do_Access
6439 then
6440 -- Floating-point case
6442 if Is_Floating_Point_Type (S_Typ) then
6443 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
6444 Out_Of_Range_L :=
6445 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
6446 or else
6447 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
6449 Out_Of_Range_H :=
6450 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
6451 or else
6452 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
6454 -- Fixed or discrete type case
6456 else
6457 Null_Range := Expr_Value (HB) < Expr_Value (LB);
6458 Out_Of_Range_L :=
6459 (Expr_Value (LB) < Expr_Value (T_LB))
6460 or else
6461 (Expr_Value (LB) > Expr_Value (T_HB));
6463 Out_Of_Range_H :=
6464 (Expr_Value (HB) > Expr_Value (T_HB))
6465 or else
6466 (Expr_Value (HB) < Expr_Value (T_LB));
6467 end if;
6469 if not Null_Range then
6470 if Out_Of_Range_L then
6471 if No (Warn_Node) then
6472 Add_Check
6473 (Compile_Time_Constraint_Error
6474 (Low_Bound (Ck_Node),
6475 "static value out of range of}?", T_Typ));
6477 else
6478 Add_Check
6479 (Compile_Time_Constraint_Error
6480 (Wnode,
6481 "static range out of bounds of}?", T_Typ));
6482 end if;
6483 end if;
6485 if Out_Of_Range_H then
6486 if No (Warn_Node) then
6487 Add_Check
6488 (Compile_Time_Constraint_Error
6489 (High_Bound (Ck_Node),
6490 "static value out of range of}?", T_Typ));
6492 else
6493 Add_Check
6494 (Compile_Time_Constraint_Error
6495 (Wnode,
6496 "static range out of bounds of}?", T_Typ));
6497 end if;
6498 end if;
6500 end if;
6502 else
6503 declare
6504 LB : Node_Id := Low_Bound (Ck_Node);
6505 HB : Node_Id := High_Bound (Ck_Node);
6507 begin
6509 -- If either bound is a discriminant and we are within
6510 -- the record declaration, it is a use of the discriminant
6511 -- in a constraint of a component, and nothing can be
6512 -- checked here. The check will be emitted within the
6513 -- init proc. Before then, the discriminal has no real
6514 -- meaning. Similarly, if the entity is a discriminal,
6515 -- there is no check to perform yet.
6517 -- The same holds within a discriminated synchronized
6518 -- type, where the discriminant may constrain a component
6519 -- or an entry family.
6521 if Nkind (LB) = N_Identifier
6522 and then Denotes_Discriminant (LB, True)
6523 then
6524 if Current_Scope = Scope (Entity (LB))
6525 or else Is_Concurrent_Type (Current_Scope)
6526 or else Ekind (Entity (LB)) /= E_Discriminant
6527 then
6528 return Ret_Result;
6529 else
6530 LB :=
6531 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
6532 end if;
6533 end if;
6535 if Nkind (HB) = N_Identifier
6536 and then Denotes_Discriminant (HB, True)
6537 then
6538 if Current_Scope = Scope (Entity (HB))
6539 or else Is_Concurrent_Type (Current_Scope)
6540 or else Ekind (Entity (HB)) /= E_Discriminant
6541 then
6542 return Ret_Result;
6543 else
6544 HB :=
6545 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
6546 end if;
6547 end if;
6549 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
6550 Set_Paren_Count (Cond, 1);
6552 Cond :=
6553 Make_And_Then (Loc,
6554 Left_Opnd =>
6555 Make_Op_Ge (Loc,
6556 Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
6557 Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
6558 Right_Opnd => Cond);
6559 end;
6561 end if;
6562 end;
6564 elsif Is_Scalar_Type (S_Typ) then
6566 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6567 -- except the above simply sets a flag in the node and lets
6568 -- gigi generate the check base on the Etype of the expression.
6569 -- Sometimes, however we want to do a dynamic check against an
6570 -- arbitrary target type, so we do that here.
6572 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
6573 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6575 -- For literals, we can tell if the constraint error will be
6576 -- raised at compile time, so we never need a dynamic check, but
6577 -- if the exception will be raised, then post the usual warning,
6578 -- and replace the literal with a raise constraint error
6579 -- expression. As usual, skip this for access types
6581 elsif Compile_Time_Known_Value (Ck_Node)
6582 and then not Do_Access
6583 then
6584 declare
6585 LB : constant Node_Id := Type_Low_Bound (T_Typ);
6586 UB : constant Node_Id := Type_High_Bound (T_Typ);
6588 Out_Of_Range : Boolean;
6589 Static_Bounds : constant Boolean :=
6590 Compile_Time_Known_Value (LB)
6591 and Compile_Time_Known_Value (UB);
6593 begin
6594 -- Following range tests should use Sem_Eval routine ???
6596 if Static_Bounds then
6597 if Is_Floating_Point_Type (S_Typ) then
6598 Out_Of_Range :=
6599 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
6600 or else
6601 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
6603 else -- fixed or discrete type
6604 Out_Of_Range :=
6605 Expr_Value (Ck_Node) < Expr_Value (LB)
6606 or else
6607 Expr_Value (Ck_Node) > Expr_Value (UB);
6608 end if;
6610 -- Bounds of the type are static and the literal is
6611 -- out of range so make a warning message.
6613 if Out_Of_Range then
6614 if No (Warn_Node) then
6615 Add_Check
6616 (Compile_Time_Constraint_Error
6617 (Ck_Node,
6618 "static value out of range of}?", T_Typ));
6620 else
6621 Add_Check
6622 (Compile_Time_Constraint_Error
6623 (Wnode,
6624 "static value out of range of}?", T_Typ));
6625 end if;
6626 end if;
6628 else
6629 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6630 end if;
6631 end;
6633 -- Here for the case of a non-static expression, we need a runtime
6634 -- check unless the source type range is guaranteed to be in the
6635 -- range of the target type.
6637 else
6638 if not In_Subrange_Of (S_Typ, T_Typ) then
6639 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6640 end if;
6641 end if;
6642 end if;
6644 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
6645 if Is_Constrained (T_Typ) then
6647 Expr_Actual := Get_Referenced_Object (Ck_Node);
6648 Exptyp := Get_Actual_Subtype (Expr_Actual);
6650 if Is_Access_Type (Exptyp) then
6651 Exptyp := Designated_Type (Exptyp);
6652 end if;
6654 -- String_Literal case. This needs to be handled specially be-
6655 -- cause no index types are available for string literals. The
6656 -- condition is simply:
6658 -- T_Typ'Length = string-literal-length
6660 if Nkind (Expr_Actual) = N_String_Literal then
6661 null;
6663 -- General array case. Here we have a usable actual subtype for
6664 -- the expression, and the condition is built from the two types
6666 -- T_Typ'First < Exptyp'First or else
6667 -- T_Typ'Last > Exptyp'Last or else
6668 -- T_Typ'First(1) < Exptyp'First(1) or else
6669 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6670 -- ...
6672 elsif Is_Constrained (Exptyp) then
6673 declare
6674 Ndims : constant Nat := Number_Dimensions (T_Typ);
6676 L_Index : Node_Id;
6677 R_Index : Node_Id;
6678 L_Low : Node_Id;
6679 L_High : Node_Id;
6680 R_Low : Node_Id;
6681 R_High : Node_Id;
6683 begin
6684 L_Index := First_Index (T_Typ);
6685 R_Index := First_Index (Exptyp);
6687 for Indx in 1 .. Ndims loop
6688 if not (Nkind (L_Index) = N_Raise_Constraint_Error
6689 or else
6690 Nkind (R_Index) = N_Raise_Constraint_Error)
6691 then
6692 Get_Index_Bounds (L_Index, L_Low, L_High);
6693 Get_Index_Bounds (R_Index, R_Low, R_High);
6695 -- Deal with compile time length check. Note that we
6696 -- skip this in the access case, because the access
6697 -- value may be null, so we cannot know statically.
6699 if not
6700 Subtypes_Statically_Match
6701 (Etype (L_Index), Etype (R_Index))
6702 then
6703 -- If the target type is constrained then we
6704 -- have to check for exact equality of bounds
6705 -- (required for qualified expressions).
6707 if Is_Constrained (T_Typ) then
6708 Evolve_Or_Else
6709 (Cond,
6710 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
6712 else
6713 Evolve_Or_Else
6714 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
6715 end if;
6716 end if;
6718 Next (L_Index);
6719 Next (R_Index);
6721 end if;
6722 end loop;
6723 end;
6725 -- Handle cases where we do not get a usable actual subtype that
6726 -- is constrained. This happens for example in the function call
6727 -- and explicit dereference cases. In these cases, we have to get
6728 -- the length or range from the expression itself, making sure we
6729 -- do not evaluate it more than once.
6731 -- Here Ck_Node is the original expression, or more properly the
6732 -- result of applying Duplicate_Expr to the original tree,
6733 -- forcing the result to be a name.
6735 else
6736 declare
6737 Ndims : constant Nat := Number_Dimensions (T_Typ);
6739 begin
6740 -- Build the condition for the explicit dereference case
6742 for Indx in 1 .. Ndims loop
6743 Evolve_Or_Else
6744 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
6745 end loop;
6746 end;
6748 end if;
6750 else
6751 -- Generate an Action to check that the bounds of the
6752 -- source value are within the constraints imposed by the
6753 -- target type for a conversion to an unconstrained type.
6754 -- Rule is 4.6(38).
6756 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
6757 declare
6758 Opnd_Index : Node_Id;
6759 Targ_Index : Node_Id;
6761 begin
6762 Opnd_Index
6763 := First_Index (Get_Actual_Subtype (Ck_Node));
6764 Targ_Index := First_Index (T_Typ);
6766 while Opnd_Index /= Empty loop
6767 if Nkind (Opnd_Index) = N_Range then
6768 if Is_In_Range
6769 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6770 and then
6771 Is_In_Range
6772 (High_Bound (Opnd_Index), Etype (Targ_Index))
6773 then
6774 null;
6776 -- If null range, no check needed
6778 elsif
6779 Compile_Time_Known_Value (High_Bound (Opnd_Index))
6780 and then
6781 Compile_Time_Known_Value (Low_Bound (Opnd_Index))
6782 and then
6783 Expr_Value (High_Bound (Opnd_Index)) <
6784 Expr_Value (Low_Bound (Opnd_Index))
6785 then
6786 null;
6788 elsif Is_Out_Of_Range
6789 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6790 or else
6791 Is_Out_Of_Range
6792 (High_Bound (Opnd_Index), Etype (Targ_Index))
6793 then
6794 Add_Check
6795 (Compile_Time_Constraint_Error
6796 (Wnode, "value out of range of}?", T_Typ));
6798 else
6799 Evolve_Or_Else
6800 (Cond,
6801 Discrete_Range_Cond
6802 (Opnd_Index, Etype (Targ_Index)));
6803 end if;
6804 end if;
6806 Next_Index (Opnd_Index);
6807 Next_Index (Targ_Index);
6808 end loop;
6809 end;
6810 end if;
6811 end if;
6812 end if;
6814 -- Construct the test and insert into the tree
6816 if Present (Cond) then
6817 if Do_Access then
6818 Cond := Guard_Access (Cond, Loc, Ck_Node);
6819 end if;
6821 Add_Check
6822 (Make_Raise_Constraint_Error (Loc,
6823 Condition => Cond,
6824 Reason => CE_Range_Check_Failed));
6825 end if;
6827 return Ret_Result;
6828 end Selected_Range_Checks;
6830 -------------------------------
6831 -- Storage_Checks_Suppressed --
6832 -------------------------------
6834 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
6835 begin
6836 if Present (E) and then Checks_May_Be_Suppressed (E) then
6837 return Is_Check_Suppressed (E, Storage_Check);
6838 else
6839 return Scope_Suppress (Storage_Check);
6840 end if;
6841 end Storage_Checks_Suppressed;
6843 ---------------------------
6844 -- Tag_Checks_Suppressed --
6845 ---------------------------
6847 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
6848 begin
6849 if Present (E) then
6850 if Kill_Tag_Checks (E) then
6851 return True;
6852 elsif Checks_May_Be_Suppressed (E) then
6853 return Is_Check_Suppressed (E, Tag_Check);
6854 end if;
6855 end if;
6857 return Scope_Suppress (Tag_Check);
6858 end Tag_Checks_Suppressed;
6860 --------------------------
6861 -- Validity_Check_Range --
6862 --------------------------
6864 procedure Validity_Check_Range (N : Node_Id) is
6865 begin
6866 if Validity_Checks_On and Validity_Check_Operands then
6867 if Nkind (N) = N_Range then
6868 Ensure_Valid (Low_Bound (N));
6869 Ensure_Valid (High_Bound (N));
6870 end if;
6871 end if;
6872 end Validity_Check_Range;
6874 --------------------------------
6875 -- Validity_Checks_Suppressed --
6876 --------------------------------
6878 function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
6879 begin
6880 if Present (E) and then Checks_May_Be_Suppressed (E) then
6881 return Is_Check_Suppressed (E, Validity_Check);
6882 else
6883 return Scope_Suppress (Validity_Check);
6884 end if;
6885 end Validity_Checks_Suppressed;
6887 end Checks;