File : checks.adb
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-2016, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Eval_Fat; use Eval_Fat;
32 with Exp_Ch11; use Exp_Ch11;
33 with Exp_Ch2; use Exp_Ch2;
34 with Exp_Ch4; use Exp_Ch4;
35 with Exp_Pakd; use Exp_Pakd;
36 with Exp_Util; use Exp_Util;
37 with Expander; use Expander;
38 with Freeze; use Freeze;
39 with Lib; use Lib;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
42 with Opt; use Opt;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
47 with Sem; use Sem;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Eval; use Sem_Eval;
52 with Sem_Res; use Sem_Res;
53 with Sem_Util; use Sem_Util;
54 with Sem_Warn; use Sem_Warn;
55 with Sinfo; use Sinfo;
56 with Sinput; use Sinput;
57 with Snames; use Snames;
58 with Sprint; use Sprint;
59 with Stand; use Stand;
60 with Stringt; use Stringt;
61 with Targparm; use Targparm;
62 with Tbuild; use Tbuild;
63 with Ttypes; use Ttypes;
64 with Validsw; use Validsw;
65
66 package body Checks is
67
68 -- General note: many of these routines are concerned with generating
69 -- checking code to make sure that constraint error is raised at runtime.
70 -- Clearly this code is only needed if the expander is active, since
71 -- otherwise we will not be generating code or going into the runtime
72 -- execution anyway.
73
74 -- We therefore disconnect most of these checks if the expander is
75 -- inactive. This has the additional benefit that we do not need to
76 -- worry about the tree being messed up by previous errors (since errors
77 -- turn off expansion anyway).
78
79 -- There are a few exceptions to the above rule. For instance routines
80 -- such as Apply_Scalar_Range_Check that do not insert any code can be
81 -- safely called even when the Expander is inactive (but Errors_Detected
82 -- is 0). The benefit of executing this code when expansion is off, is
83 -- the ability to emit constraint error warning for static expressions
84 -- even when we are not generating code.
85
86 -- The above is modified in gnatprove mode to ensure that proper check
87 -- flags are always placed, even if expansion is off.
88
89 -------------------------------------
90 -- Suppression of Redundant Checks --
91 -------------------------------------
92
93 -- This unit implements a limited circuit for removal of redundant
94 -- checks. The processing is based on a tracing of simple sequential
95 -- flow. For any sequence of statements, we save expressions that are
96 -- marked to be checked, and then if the same expression appears later
97 -- with the same check, then under certain circumstances, the second
98 -- check can be suppressed.
99
100 -- Basically, we can suppress the check if we know for certain that
101 -- the previous expression has been elaborated (together with its
102 -- check), and we know that the exception frame is the same, and that
103 -- nothing has happened to change the result of the exception.
104
105 -- Let us examine each of these three conditions in turn to describe
106 -- how we ensure that this condition is met.
107
108 -- First, we need to know for certain that the previous expression has
109 -- been executed. This is done principally by the mechanism of calling
110 -- Conditional_Statements_Begin at the start of any statement sequence
111 -- and Conditional_Statements_End at the end. The End call causes all
112 -- checks remembered since the Begin call to be discarded. This does
113 -- miss a few cases, notably the case of a nested BEGIN-END block with
114 -- no exception handlers. But the important thing is to be conservative.
115 -- The other protection is that all checks are discarded if a label
116 -- is encountered, since then the assumption of sequential execution
117 -- is violated, and we don't know enough about the flow.
118
119 -- Second, we need to know that the exception frame is the same. We
120 -- do this by killing all remembered checks when we enter a new frame.
121 -- Again, that's over-conservative, but generally the cases we can help
122 -- with are pretty local anyway (like the body of a loop for example).
123
124 -- Third, we must be sure to forget any checks which are no longer valid.
125 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
126 -- used to note any changes to local variables. We only attempt to deal
127 -- with checks involving local variables, so we do not need to worry
128 -- about global variables. Second, a call to any non-global procedure
129 -- causes us to abandon all stored checks, since such a all may affect
130 -- the values of any local variables.
131
132 -- The following define the data structures used to deal with remembering
133 -- checks so that redundant checks can be eliminated as described above.
134
135 -- Right now, the only expressions that we deal with are of the form of
136 -- simple local objects (either declared locally, or IN parameters) or
137 -- such objects plus/minus a compile time known constant. We can do
138 -- more later on if it seems worthwhile, but this catches many simple
139 -- cases in practice.
140
141 -- The following record type reflects a single saved check. An entry
142 -- is made in the stack of saved checks if and only if the expression
143 -- has been elaborated with the indicated checks.
144
145 type Saved_Check is record
146 Killed : Boolean;
147 -- Set True if entry is killed by Kill_Checks
148
149 Entity : Entity_Id;
150 -- The entity involved in the expression that is checked
151
152 Offset : Uint;
153 -- A compile time value indicating the result of adding or
154 -- subtracting a compile time value. This value is to be
155 -- added to the value of the Entity. A value of zero is
156 -- used for the case of a simple entity reference.
157
158 Check_Type : Character;
159 -- This is set to 'R' for a range check (in which case Target_Type
160 -- is set to the target type for the range check) or to 'O' for an
161 -- overflow check (in which case Target_Type is set to Empty).
162
163 Target_Type : Entity_Id;
164 -- Used only if Do_Range_Check is set. Records the target type for
165 -- the check. We need this, because a check is a duplicate only if
166 -- it has the same target type (or more accurately one with a
167 -- range that is smaller or equal to the stored target type of a
168 -- saved check).
169 end record;
170
171 -- The following table keeps track of saved checks. Rather than use an
172 -- extensible table, we just use a table of fixed size, and we discard
173 -- any saved checks that do not fit. That's very unlikely to happen and
174 -- this is only an optimization in any case.
175
176 Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
177 -- Array of saved checks
178
179 Num_Saved_Checks : Nat := 0;
180 -- Number of saved checks
181
182 -- The following stack keeps track of statement ranges. It is treated
183 -- as a stack. When Conditional_Statements_Begin is called, an entry
184 -- is pushed onto this stack containing the value of Num_Saved_Checks
185 -- at the time of the call. Then when Conditional_Statements_End is
186 -- called, this value is popped off and used to reset Num_Saved_Checks.
187
188 -- Note: again, this is a fixed length stack with a size that should
189 -- always be fine. If the value of the stack pointer goes above the
190 -- limit, then we just forget all saved checks.
191
192 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
193 Saved_Checks_TOS : Nat := 0;
194
195 -----------------------
196 -- Local Subprograms --
197 -----------------------
198
199 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id);
200 -- Used to apply arithmetic overflow checks for all cases except operators
201 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
202 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
203 -- signed integer arithmetic operator (but not an if or case expression).
204 -- It is also called for types other than signed integers.
205
206 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id);
207 -- Used to apply arithmetic overflow checks for the case where the overflow
208 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
209 -- arithmetic op (which includes the case of if and case expressions). Note
210 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
211 -- we have work to do even if overflow checking is suppressed.
212
213 procedure Apply_Division_Check
214 (N : Node_Id;
215 Rlo : Uint;
216 Rhi : Uint;
217 ROK : Boolean);
218 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
219 -- division checks as required if the Do_Division_Check flag is set.
220 -- Rlo and Rhi give the possible range of the right operand, these values
221 -- can be referenced and trusted only if ROK is set True.
222
223 procedure Apply_Float_Conversion_Check
224 (Ck_Node : Node_Id;
225 Target_Typ : Entity_Id);
226 -- The checks on a conversion from a floating-point type to an integer
227 -- type are delicate. They have to be performed before conversion, they
228 -- have to raise an exception when the operand is a NaN, and rounding must
229 -- be taken into account to determine the safe bounds of the operand.
230
231 procedure Apply_Selected_Length_Checks
232 (Ck_Node : Node_Id;
233 Target_Typ : Entity_Id;
234 Source_Typ : Entity_Id;
235 Do_Static : Boolean);
236 -- This is the subprogram that does all the work for Apply_Length_Check
237 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
238 -- described for the above routines. The Do_Static flag indicates that
239 -- only a static check is to be done.
240
241 procedure Apply_Selected_Range_Checks
242 (Ck_Node : Node_Id;
243 Target_Typ : Entity_Id;
244 Source_Typ : Entity_Id;
245 Do_Static : Boolean);
246 -- This is the subprogram that does all the work for Apply_Range_Check.
247 -- Expr, Target_Typ and Source_Typ are as described for the above
248 -- routine. The Do_Static flag indicates that only a static check is
249 -- to be done.
250
251 type Check_Type is new Check_Id range Access_Check .. Division_Check;
252 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
253 -- This function is used to see if an access or division by zero check is
254 -- needed. The check is to be applied to a single variable appearing in the
255 -- source, and N is the node for the reference. If N is not of this form,
256 -- True is returned with no further processing. If N is of the right form,
257 -- then further processing determines if the given Check is needed.
258 --
259 -- The particular circuit is to see if we have the case of a check that is
260 -- not needed because it appears in the right operand of a short circuited
261 -- conditional where the left operand guards the check. For example:
262 --
263 -- if Var = 0 or else Q / Var > 12 then
264 -- ...
265 -- end if;
266 --
267 -- In this example, the division check is not required. At the same time
268 -- we can issue warnings for suspicious use of non-short-circuited forms,
269 -- such as:
270 --
271 -- if Var = 0 or Q / Var > 12 then
272 -- ...
273 -- end if;
274
275 procedure Find_Check
276 (Expr : Node_Id;
277 Check_Type : Character;
278 Target_Type : Entity_Id;
279 Entry_OK : out Boolean;
280 Check_Num : out Nat;
281 Ent : out Entity_Id;
282 Ofs : out Uint);
283 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
284 -- to see if a check is of the form for optimization, and if so, to see
285 -- if it has already been performed. Expr is the expression to check,
286 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
287 -- Target_Type is the target type for a range check, and Empty for an
288 -- overflow check. If the entry is not of the form for optimization,
289 -- then Entry_OK is set to False, and the remaining out parameters
290 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
291 -- entity and offset from the expression. Check_Num is the number of
292 -- a matching saved entry in Saved_Checks, or zero if no such entry
293 -- is located.
294
295 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
296 -- If a discriminal is used in constraining a prival, Return reference
297 -- to the discriminal of the protected body (which renames the parameter
298 -- of the enclosing protected operation). This clumsy transformation is
299 -- needed because privals are created too late and their actual subtypes
300 -- are not available when analysing the bodies of the protected operations.
301 -- This function is called whenever the bound is an entity and the scope
302 -- indicates a protected operation. If the bound is an in-parameter of
303 -- a protected operation that is not a prival, the function returns the
304 -- bound itself.
305 -- To be cleaned up???
306
307 function Guard_Access
308 (Cond : Node_Id;
309 Loc : Source_Ptr;
310 Ck_Node : Node_Id) return Node_Id;
311 -- In the access type case, guard the test with a test to ensure
312 -- that the access value is non-null, since the checks do not
313 -- not apply to null access values.
314
315 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
316 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
317 -- Constraint_Error node.
318
319 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean;
320 -- Returns True if node N is for an arithmetic operation with signed
321 -- integer operands. This includes unary and binary operators, and also
322 -- if and case expression nodes where the dependent expressions are of
323 -- a signed integer type. These are the kinds of nodes for which special
324 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
325
326 function Range_Or_Validity_Checks_Suppressed
327 (Expr : Node_Id) return Boolean;
328 -- Returns True if either range or validity checks or both are suppressed
329 -- for the type of the given expression, or, if the expression is the name
330 -- of an entity, if these checks are suppressed for the entity.
331
332 function Selected_Length_Checks
333 (Ck_Node : Node_Id;
334 Target_Typ : Entity_Id;
335 Source_Typ : Entity_Id;
336 Warn_Node : Node_Id) return Check_Result;
337 -- Like Apply_Selected_Length_Checks, except it doesn't modify
338 -- anything, just returns a list of nodes as described in the spec of
339 -- this package for the Range_Check function.
340
341 function Selected_Range_Checks
342 (Ck_Node : Node_Id;
343 Target_Typ : Entity_Id;
344 Source_Typ : Entity_Id;
345 Warn_Node : Node_Id) return Check_Result;
346 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
347 -- just returns a list of nodes as described in the spec of this package
348 -- for the Range_Check function.
349
350 ------------------------------
351 -- Access_Checks_Suppressed --
352 ------------------------------
353
354 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
355 begin
356 if Present (E) and then Checks_May_Be_Suppressed (E) then
357 return Is_Check_Suppressed (E, Access_Check);
358 else
359 return Scope_Suppress.Suppress (Access_Check);
360 end if;
361 end Access_Checks_Suppressed;
362
363 -------------------------------------
364 -- Accessibility_Checks_Suppressed --
365 -------------------------------------
366
367 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
368 begin
369 if Present (E) and then Checks_May_Be_Suppressed (E) then
370 return Is_Check_Suppressed (E, Accessibility_Check);
371 else
372 return Scope_Suppress.Suppress (Accessibility_Check);
373 end if;
374 end Accessibility_Checks_Suppressed;
375
376 -----------------------------
377 -- Activate_Division_Check --
378 -----------------------------
379
380 procedure Activate_Division_Check (N : Node_Id) is
381 begin
382 Set_Do_Division_Check (N, True);
383 Possible_Local_Raise (N, Standard_Constraint_Error);
384 end Activate_Division_Check;
385
386 -----------------------------
387 -- Activate_Overflow_Check --
388 -----------------------------
389
390 procedure Activate_Overflow_Check (N : Node_Id) is
391 Typ : constant Entity_Id := Etype (N);
392
393 begin
394 -- Floating-point case. If Etype is not set (this can happen when we
395 -- activate a check on a node that has not yet been analyzed), then
396 -- we assume we do not have a floating-point type (as per our spec).
397
398 if Present (Typ) and then Is_Floating_Point_Type (Typ) then
399
400 -- Ignore call if we have no automatic overflow checks on the target
401 -- and Check_Float_Overflow mode is not set. These are the cases in
402 -- which we expect to generate infinities and NaN's with no check.
403
404 if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
405 return;
406
407 -- Ignore for unary operations ("+", "-", abs) since these can never
408 -- result in overflow for floating-point cases.
409
410 elsif Nkind (N) in N_Unary_Op then
411 return;
412
413 -- Otherwise we will set the flag
414
415 else
416 null;
417 end if;
418
419 -- Discrete case
420
421 else
422 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
423 -- for zero-divide is a divide check, not an overflow check).
424
425 if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then
426 return;
427 end if;
428 end if;
429
430 -- Fall through for cases where we do set the flag
431
432 Set_Do_Overflow_Check (N, True);
433 Possible_Local_Raise (N, Standard_Constraint_Error);
434 end Activate_Overflow_Check;
435
436 --------------------------
437 -- Activate_Range_Check --
438 --------------------------
439
440 procedure Activate_Range_Check (N : Node_Id) is
441 begin
442 Set_Do_Range_Check (N, True);
443 Possible_Local_Raise (N, Standard_Constraint_Error);
444 end Activate_Range_Check;
445
446 ---------------------------------
447 -- Alignment_Checks_Suppressed --
448 ---------------------------------
449
450 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
451 begin
452 if Present (E) and then Checks_May_Be_Suppressed (E) then
453 return Is_Check_Suppressed (E, Alignment_Check);
454 else
455 return Scope_Suppress.Suppress (Alignment_Check);
456 end if;
457 end Alignment_Checks_Suppressed;
458
459 ----------------------------------
460 -- Allocation_Checks_Suppressed --
461 ----------------------------------
462
463 -- Note: at the current time there are no calls to this function, because
464 -- the relevant check is in the run-time, so it is not a check that the
465 -- compiler can suppress anyway, but we still have to recognize the check
466 -- name Allocation_Check since it is part of the standard.
467
468 function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
469 begin
470 if Present (E) and then Checks_May_Be_Suppressed (E) then
471 return Is_Check_Suppressed (E, Allocation_Check);
472 else
473 return Scope_Suppress.Suppress (Allocation_Check);
474 end if;
475 end Allocation_Checks_Suppressed;
476
477 -------------------------
478 -- Append_Range_Checks --
479 -------------------------
480
481 procedure Append_Range_Checks
482 (Checks : Check_Result;
483 Stmts : List_Id;
484 Suppress_Typ : Entity_Id;
485 Static_Sloc : Source_Ptr;
486 Flag_Node : Node_Id)
487 is
488 Internal_Flag_Node : constant Node_Id := Flag_Node;
489 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
490
491 Checks_On : constant Boolean :=
492 (not Index_Checks_Suppressed (Suppress_Typ))
493 or else (not Range_Checks_Suppressed (Suppress_Typ));
494
495 begin
496 -- For now we just return if Checks_On is false, however this should
497 -- be enhanced to check for an always True value in the condition
498 -- and to generate a compilation warning???
499
500 if not Checks_On then
501 return;
502 end if;
503
504 for J in 1 .. 2 loop
505 exit when No (Checks (J));
506
507 if Nkind (Checks (J)) = N_Raise_Constraint_Error
508 and then Present (Condition (Checks (J)))
509 then
510 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
511 Append_To (Stmts, Checks (J));
512 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
513 end if;
514
515 else
516 Append_To
517 (Stmts,
518 Make_Raise_Constraint_Error (Internal_Static_Sloc,
519 Reason => CE_Range_Check_Failed));
520 end if;
521 end loop;
522 end Append_Range_Checks;
523
524 ------------------------
525 -- Apply_Access_Check --
526 ------------------------
527
528 procedure Apply_Access_Check (N : Node_Id) is
529 P : constant Node_Id := Prefix (N);
530
531 begin
532 -- We do not need checks if we are not generating code (i.e. the
533 -- expander is not active). This is not just an optimization, there
534 -- are cases (e.g. with pragma Debug) where generating the checks
535 -- can cause real trouble).
536
537 if not Expander_Active then
538 return;
539 end if;
540
541 -- No check if short circuiting makes check unnecessary
542
543 if not Check_Needed (P, Access_Check) then
544 return;
545 end if;
546
547 -- No check if accessing the Offset_To_Top component of a dispatch
548 -- table. They are safe by construction.
549
550 if Tagged_Type_Expansion
551 and then Present (Etype (P))
552 and then RTU_Loaded (Ada_Tags)
553 and then RTE_Available (RE_Offset_To_Top_Ptr)
554 and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
555 then
556 return;
557 end if;
558
559 -- Otherwise go ahead and install the check
560
561 Install_Null_Excluding_Check (P);
562 end Apply_Access_Check;
563
564 -------------------------------
565 -- Apply_Accessibility_Check --
566 -------------------------------
567
568 procedure Apply_Accessibility_Check
569 (N : Node_Id;
570 Typ : Entity_Id;
571 Insert_Node : Node_Id)
572 is
573 Loc : constant Source_Ptr := Sloc (N);
574 Param_Ent : Entity_Id := Param_Entity (N);
575 Param_Level : Node_Id;
576 Type_Level : Node_Id;
577
578 begin
579 if Ada_Version >= Ada_2012
580 and then not Present (Param_Ent)
581 and then Is_Entity_Name (N)
582 and then Ekind_In (Entity (N), E_Constant, E_Variable)
583 and then Present (Effective_Extra_Accessibility (Entity (N)))
584 then
585 Param_Ent := Entity (N);
586 while Present (Renamed_Object (Param_Ent)) loop
587
588 -- Renamed_Object must return an Entity_Name here
589 -- because of preceding "Present (E_E_A (...))" test.
590
591 Param_Ent := Entity (Renamed_Object (Param_Ent));
592 end loop;
593 end if;
594
595 if Inside_A_Generic then
596 return;
597
598 -- Only apply the run-time check if the access parameter has an
599 -- associated extra access level parameter and when the level of the
600 -- type is less deep than the level of the access parameter, and
601 -- accessibility checks are not suppressed.
602
603 elsif Present (Param_Ent)
604 and then Present (Extra_Accessibility (Param_Ent))
605 and then UI_Gt (Object_Access_Level (N),
606 Deepest_Type_Access_Level (Typ))
607 and then not Accessibility_Checks_Suppressed (Param_Ent)
608 and then not Accessibility_Checks_Suppressed (Typ)
609 then
610 Param_Level :=
611 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
612
613 Type_Level :=
614 Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
615
616 -- Raise Program_Error if the accessibility level of the access
617 -- parameter is deeper than the level of the target access type.
618
619 Insert_Action (Insert_Node,
620 Make_Raise_Program_Error (Loc,
621 Condition =>
622 Make_Op_Gt (Loc,
623 Left_Opnd => Param_Level,
624 Right_Opnd => Type_Level),
625 Reason => PE_Accessibility_Check_Failed));
626
627 Analyze_And_Resolve (N);
628 end if;
629 end Apply_Accessibility_Check;
630
631 --------------------------------
632 -- Apply_Address_Clause_Check --
633 --------------------------------
634
635 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
636 pragma Assert (Nkind (N) = N_Freeze_Entity);
637
638 AC : constant Node_Id := Address_Clause (E);
639 Loc : constant Source_Ptr := Sloc (AC);
640 Typ : constant Entity_Id := Etype (E);
641
642 Expr : Node_Id;
643 -- Address expression (not necessarily the same as Aexp, for example
644 -- when Aexp is a reference to a constant, in which case Expr gets
645 -- reset to reference the value expression of the constant).
646
647 begin
648 -- See if alignment check needed. Note that we never need a check if the
649 -- maximum alignment is one, since the check will always succeed.
650
651 -- Note: we do not check for checks suppressed here, since that check
652 -- was done in Sem_Ch13 when the address clause was processed. We are
653 -- only called if checks were not suppressed. The reason for this is
654 -- that we have to delay the call to Apply_Alignment_Check till freeze
655 -- time (so that all types etc are elaborated), but we have to check
656 -- the status of check suppressing at the point of the address clause.
657
658 if No (AC)
659 or else not Check_Address_Alignment (AC)
660 or else Maximum_Alignment = 1
661 then
662 return;
663 end if;
664
665 -- Obtain expression from address clause
666
667 Expr := Address_Value (Expression (AC));
668
669 -- See if we know that Expr has an acceptable value at compile time. If
670 -- it hasn't or we don't know, we defer issuing the warning until the
671 -- end of the compilation to take into account back end annotations.
672
673 if Compile_Time_Known_Value (Expr)
674 and then (Known_Alignment (E) or else Known_Alignment (Typ))
675 then
676 declare
677 AL : Uint := Alignment (Typ);
678
679 begin
680 -- The object alignment might be more restrictive than the type
681 -- alignment.
682
683 if Known_Alignment (E) then
684 AL := Alignment (E);
685 end if;
686
687 if Expr_Value (Expr) mod AL = 0 then
688 return;
689 end if;
690 end;
691
692 -- If the expression has the form X'Address, then we can find out if the
693 -- object X has an alignment that is compatible with the object E. If it
694 -- hasn't or we don't know, we defer issuing the warning until the end
695 -- of the compilation to take into account back end annotations.
696
697 elsif Nkind (Expr) = N_Attribute_Reference
698 and then Attribute_Name (Expr) = Name_Address
699 and then
700 Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible
701 then
702 return;
703 end if;
704
705 -- Here we do not know if the value is acceptable. Strictly we don't
706 -- have to do anything, since if the alignment is bad, we have an
707 -- erroneous program. However we are allowed to check for erroneous
708 -- conditions and we decide to do this by default if the check is not
709 -- suppressed.
710
711 -- However, don't do the check if elaboration code is unwanted
712
713 if Restriction_Active (No_Elaboration_Code) then
714 return;
715
716 -- Generate a check to raise PE if alignment may be inappropriate
717
718 else
719 -- If the original expression is a non-static constant, use the name
720 -- of the constant itself rather than duplicating its initialization
721 -- expression, which was extracted above.
722
723 -- Note: Expr is empty if the address-clause is applied to in-mode
724 -- actuals (allowed by 13.1(22)).
725
726 if not Present (Expr)
727 or else
728 (Is_Entity_Name (Expression (AC))
729 and then Ekind (Entity (Expression (AC))) = E_Constant
730 and then Nkind (Parent (Entity (Expression (AC)))) =
731 N_Object_Declaration)
732 then
733 Expr := New_Copy_Tree (Expression (AC));
734 else
735 Remove_Side_Effects (Expr);
736 end if;
737
738 if No (Actions (N)) then
739 Set_Actions (N, New_List);
740 end if;
741
742 Prepend_To (Actions (N),
743 Make_Raise_Program_Error (Loc,
744 Condition =>
745 Make_Op_Ne (Loc,
746 Left_Opnd =>
747 Make_Op_Mod (Loc,
748 Left_Opnd =>
749 Unchecked_Convert_To
750 (RTE (RE_Integer_Address), Expr),
751 Right_Opnd =>
752 Make_Attribute_Reference (Loc,
753 Prefix => New_Occurrence_Of (E, Loc),
754 Attribute_Name => Name_Alignment)),
755 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
756 Reason => PE_Misaligned_Address_Value));
757
758 Warning_Msg := No_Error_Msg;
759 Analyze (First (Actions (N)), Suppress => All_Checks);
760
761 -- If the above raise action generated a warning message (for example
762 -- from Warn_On_Non_Local_Exception mode with the active restriction
763 -- No_Exception_Propagation).
764
765 if Warning_Msg /= No_Error_Msg then
766
767 -- If the expression has a known at compile time value, then
768 -- once we know the alignment of the type, we can check if the
769 -- exception will be raised or not, and if not, we don't need
770 -- the warning so we will kill the warning later on.
771
772 if Compile_Time_Known_Value (Expr) then
773 Alignment_Warnings.Append
774 ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
775
776 -- Add explanation of the warning generated by the check
777
778 else
779 Error_Msg_N
780 ("\address value may be incompatible with alignment of "
781 & "object?X?", AC);
782 end if;
783 end if;
784
785 return;
786 end if;
787
788 exception
789
790 -- If we have some missing run time component in configurable run time
791 -- mode then just skip the check (it is not required in any case).
792
793 when RE_Not_Available =>
794 return;
795 end Apply_Address_Clause_Check;
796
797 -------------------------------------
798 -- Apply_Arithmetic_Overflow_Check --
799 -------------------------------------
800
801 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
802 begin
803 -- Use old routine in almost all cases (the only case we are treating
804 -- specially is the case of a signed integer arithmetic op with the
805 -- overflow checking mode set to MINIMIZED or ELIMINATED).
806
807 if Overflow_Check_Mode = Strict
808 or else not Is_Signed_Integer_Arithmetic_Op (N)
809 then
810 Apply_Arithmetic_Overflow_Strict (N);
811
812 -- Otherwise use the new routine for the case of a signed integer
813 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
814 -- mode is MINIMIZED or ELIMINATED.
815
816 else
817 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
818 end if;
819 end Apply_Arithmetic_Overflow_Check;
820
821 --------------------------------------
822 -- Apply_Arithmetic_Overflow_Strict --
823 --------------------------------------
824
825 -- This routine is called only if the type is an integer type, and a
826 -- software arithmetic overflow check may be needed for op (add, subtract,
827 -- or multiply). This check is performed only if Software_Overflow_Checking
828 -- is enabled and Do_Overflow_Check is set. In this case we expand the
829 -- operation into a more complex sequence of tests that ensures that
830 -- overflow is properly caught.
831
832 -- This is used in CHECKED modes. It is identical to the code for this
833 -- cases before the big overflow earthquake, thus ensuring that in this
834 -- modes we have compatible behavior (and reliability) to what was there
835 -- before. It is also called for types other than signed integers, and if
836 -- the Do_Overflow_Check flag is off.
837
838 -- Note: we also call this routine if we decide in the MINIMIZED case
839 -- to give up and just generate an overflow check without any fuss.
840
841 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
842 Loc : constant Source_Ptr := Sloc (N);
843 Typ : constant Entity_Id := Etype (N);
844 Rtyp : constant Entity_Id := Root_Type (Typ);
845
846 begin
847 -- Nothing to do if Do_Overflow_Check not set or overflow checks
848 -- suppressed.
849
850 if not Do_Overflow_Check (N) then
851 return;
852 end if;
853
854 -- An interesting special case. If the arithmetic operation appears as
855 -- the operand of a type conversion:
856
857 -- type1 (x op y)
858
859 -- and all the following conditions apply:
860
861 -- arithmetic operation is for a signed integer type
862 -- target type type1 is a static integer subtype
863 -- range of x and y are both included in the range of type1
864 -- range of x op y is included in the range of type1
865 -- size of type1 is at least twice the result size of op
866
867 -- then we don't do an overflow check in any case. Instead, we transform
868 -- the operation so that we end up with:
869
870 -- type1 (type1 (x) op type1 (y))
871
872 -- This avoids intermediate overflow before the conversion. It is
873 -- explicitly permitted by RM 3.5.4(24):
874
875 -- For the execution of a predefined operation of a signed integer
876 -- type, the implementation need not raise Constraint_Error if the
877 -- result is outside the base range of the type, so long as the
878 -- correct result is produced.
879
880 -- It's hard to imagine that any programmer counts on the exception
881 -- being raised in this case, and in any case it's wrong coding to
882 -- have this expectation, given the RM permission. Furthermore, other
883 -- Ada compilers do allow such out of range results.
884
885 -- Note that we do this transformation even if overflow checking is
886 -- off, since this is precisely about giving the "right" result and
887 -- avoiding the need for an overflow check.
888
889 -- Note: this circuit is partially redundant with respect to the similar
890 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
891 -- with cases that do not come through here. We still need the following
892 -- processing even with the Exp_Ch4 code in place, since we want to be
893 -- sure not to generate the arithmetic overflow check in these cases
894 -- (Exp_Ch4 would have a hard time removing them once generated).
895
896 if Is_Signed_Integer_Type (Typ)
897 and then Nkind (Parent (N)) = N_Type_Conversion
898 then
899 Conversion_Optimization : declare
900 Target_Type : constant Entity_Id :=
901 Base_Type (Entity (Subtype_Mark (Parent (N))));
902
903 Llo, Lhi : Uint;
904 Rlo, Rhi : Uint;
905 LOK, ROK : Boolean;
906
907 Vlo : Uint;
908 Vhi : Uint;
909 VOK : Boolean;
910
911 Tlo : Uint;
912 Thi : Uint;
913
914 begin
915 if Is_Integer_Type (Target_Type)
916 and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
917 then
918 Tlo := Expr_Value (Type_Low_Bound (Target_Type));
919 Thi := Expr_Value (Type_High_Bound (Target_Type));
920
921 Determine_Range
922 (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
923 Determine_Range
924 (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
925
926 if (LOK and ROK)
927 and then Tlo <= Llo and then Lhi <= Thi
928 and then Tlo <= Rlo and then Rhi <= Thi
929 then
930 Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
931
932 if VOK and then Tlo <= Vlo and then Vhi <= Thi then
933 Rewrite (Left_Opnd (N),
934 Make_Type_Conversion (Loc,
935 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
936 Expression => Relocate_Node (Left_Opnd (N))));
937
938 Rewrite (Right_Opnd (N),
939 Make_Type_Conversion (Loc,
940 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
941 Expression => Relocate_Node (Right_Opnd (N))));
942
943 -- Rewrite the conversion operand so that the original
944 -- node is retained, in order to avoid the warning for
945 -- redundant conversions in Resolve_Type_Conversion.
946
947 Rewrite (N, Relocate_Node (N));
948
949 Set_Etype (N, Target_Type);
950
951 Analyze_And_Resolve (Left_Opnd (N), Target_Type);
952 Analyze_And_Resolve (Right_Opnd (N), Target_Type);
953
954 -- Given that the target type is twice the size of the
955 -- source type, overflow is now impossible, so we can
956 -- safely kill the overflow check and return.
957
958 Set_Do_Overflow_Check (N, False);
959 return;
960 end if;
961 end if;
962 end if;
963 end Conversion_Optimization;
964 end if;
965
966 -- Now see if an overflow check is required
967
968 declare
969 Siz : constant Int := UI_To_Int (Esize (Rtyp));
970 Dsiz : constant Int := Siz * 2;
971 Opnod : Node_Id;
972 Ctyp : Entity_Id;
973 Opnd : Node_Id;
974 Cent : RE_Id;
975
976 begin
977 -- Skip check if back end does overflow checks, or the overflow flag
978 -- is not set anyway, or we are not doing code expansion, or the
979 -- parent node is a type conversion whose operand is an arithmetic
980 -- operation on signed integers on which the expander can promote
981 -- later the operands to type Integer (see Expand_N_Type_Conversion).
982
983 if Backend_Overflow_Checks_On_Target
984 or else not Do_Overflow_Check (N)
985 or else not Expander_Active
986 or else (Present (Parent (N))
987 and then Nkind (Parent (N)) = N_Type_Conversion
988 and then Integer_Promotion_Possible (Parent (N)))
989 then
990 return;
991 end if;
992
993 -- Otherwise, generate the full general code for front end overflow
994 -- detection, which works by doing arithmetic in a larger type:
995
996 -- x op y
997
998 -- is expanded into
999
1000 -- Typ (Checktyp (x) op Checktyp (y));
1001
1002 -- where Typ is the type of the original expression, and Checktyp is
1003 -- an integer type of sufficient length to hold the largest possible
1004 -- result.
1005
1006 -- If the size of check type exceeds the size of Long_Long_Integer,
1007 -- we use a different approach, expanding to:
1008
1009 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1010
1011 -- where xxx is Add, Multiply or Subtract as appropriate
1012
1013 -- Find check type if one exists
1014
1015 if Dsiz <= Standard_Integer_Size then
1016 Ctyp := Standard_Integer;
1017
1018 elsif Dsiz <= Standard_Long_Long_Integer_Size then
1019 Ctyp := Standard_Long_Long_Integer;
1020
1021 -- No check type exists, use runtime call
1022
1023 else
1024 if Nkind (N) = N_Op_Add then
1025 Cent := RE_Add_With_Ovflo_Check;
1026
1027 elsif Nkind (N) = N_Op_Multiply then
1028 Cent := RE_Multiply_With_Ovflo_Check;
1029
1030 else
1031 pragma Assert (Nkind (N) = N_Op_Subtract);
1032 Cent := RE_Subtract_With_Ovflo_Check;
1033 end if;
1034
1035 Rewrite (N,
1036 OK_Convert_To (Typ,
1037 Make_Function_Call (Loc,
1038 Name => New_Occurrence_Of (RTE (Cent), Loc),
1039 Parameter_Associations => New_List (
1040 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
1041 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
1042
1043 Analyze_And_Resolve (N, Typ);
1044 return;
1045 end if;
1046
1047 -- If we fall through, we have the case where we do the arithmetic
1048 -- in the next higher type and get the check by conversion. In these
1049 -- cases Ctyp is set to the type to be used as the check type.
1050
1051 Opnod := Relocate_Node (N);
1052
1053 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
1054
1055 Analyze (Opnd);
1056 Set_Etype (Opnd, Ctyp);
1057 Set_Analyzed (Opnd, True);
1058 Set_Left_Opnd (Opnod, Opnd);
1059
1060 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
1061
1062 Analyze (Opnd);
1063 Set_Etype (Opnd, Ctyp);
1064 Set_Analyzed (Opnd, True);
1065 Set_Right_Opnd (Opnod, Opnd);
1066
1067 -- The type of the operation changes to the base type of the check
1068 -- type, and we reset the overflow check indication, since clearly no
1069 -- overflow is possible now that we are using a double length type.
1070 -- We also set the Analyzed flag to avoid a recursive attempt to
1071 -- expand the node.
1072
1073 Set_Etype (Opnod, Base_Type (Ctyp));
1074 Set_Do_Overflow_Check (Opnod, False);
1075 Set_Analyzed (Opnod, True);
1076
1077 -- Now build the outer conversion
1078
1079 Opnd := OK_Convert_To (Typ, Opnod);
1080 Analyze (Opnd);
1081 Set_Etype (Opnd, Typ);
1082
1083 -- In the discrete type case, we directly generate the range check
1084 -- for the outer operand. This range check will implement the
1085 -- required overflow check.
1086
1087 if Is_Discrete_Type (Typ) then
1088 Rewrite (N, Opnd);
1089 Generate_Range_Check
1090 (Expression (N), Typ, CE_Overflow_Check_Failed);
1091
1092 -- For other types, we enable overflow checking on the conversion,
1093 -- after setting the node as analyzed to prevent recursive attempts
1094 -- to expand the conversion node.
1095
1096 else
1097 Set_Analyzed (Opnd, True);
1098 Enable_Overflow_Check (Opnd);
1099 Rewrite (N, Opnd);
1100 end if;
1101
1102 exception
1103 when RE_Not_Available =>
1104 return;
1105 end;
1106 end Apply_Arithmetic_Overflow_Strict;
1107
1108 ----------------------------------------------------
1109 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1110 ----------------------------------------------------
1111
1112 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
1113 pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
1114
1115 Loc : constant Source_Ptr := Sloc (Op);
1116 P : constant Node_Id := Parent (Op);
1117
1118 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
1119 -- Operands and results are of this type when we convert
1120
1121 Result_Type : constant Entity_Id := Etype (Op);
1122 -- Original result type
1123
1124 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1125 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
1126
1127 Lo, Hi : Uint;
1128 -- Ranges of values for result
1129
1130 begin
1131 -- Nothing to do if our parent is one of the following:
1132
1133 -- Another signed integer arithmetic op
1134 -- A membership operation
1135 -- A comparison operation
1136
1137 -- In all these cases, we will process at the higher level (and then
1138 -- this node will be processed during the downwards recursion that
1139 -- is part of the processing in Minimize_Eliminate_Overflows).
1140
1141 if Is_Signed_Integer_Arithmetic_Op (P)
1142 or else Nkind (P) in N_Membership_Test
1143 or else Nkind (P) in N_Op_Compare
1144
1145 -- This is also true for an alternative in a case expression
1146
1147 or else Nkind (P) = N_Case_Expression_Alternative
1148
1149 -- This is also true for a range operand in a membership test
1150
1151 or else (Nkind (P) = N_Range
1152 and then Nkind (Parent (P)) in N_Membership_Test)
1153 then
1154 -- If_Expressions and Case_Expressions are treated as arithmetic
1155 -- ops, but if they appear in an assignment or similar contexts
1156 -- there is no overflow check that starts from that parent node,
1157 -- so apply check now.
1158
1159 if Nkind_In (P, N_If_Expression, N_Case_Expression)
1160 and then not Is_Signed_Integer_Arithmetic_Op (Parent (P))
1161 then
1162 null;
1163 else
1164 return;
1165 end if;
1166 end if;
1167
1168 -- Otherwise, we have a top level arithmetic operation node, and this
1169 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1170 -- modes. This is the case where we tell the machinery not to move into
1171 -- Bignum mode at this top level (of course the top level operation
1172 -- will still be in Bignum mode if either of its operands are of type
1173 -- Bignum).
1174
1175 Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
1176
1177 -- That call may but does not necessarily change the result type of Op.
1178 -- It is the job of this routine to undo such changes, so that at the
1179 -- top level, we have the proper type. This "undoing" is a point at
1180 -- which a final overflow check may be applied.
1181
1182 -- If the result type was not fiddled we are all set. We go to base
1183 -- types here because things may have been rewritten to generate the
1184 -- base type of the operand types.
1185
1186 if Base_Type (Etype (Op)) = Base_Type (Result_Type) then
1187 return;
1188
1189 -- Bignum case
1190
1191 elsif Is_RTE (Etype (Op), RE_Bignum) then
1192
1193 -- We need a sequence that looks like:
1194
1195 -- Rnn : Result_Type;
1196
1197 -- declare
1198 -- M : Mark_Id := SS_Mark;
1199 -- begin
1200 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1201 -- SS_Release (M);
1202 -- end;
1203
1204 -- This block is inserted (using Insert_Actions), and then the node
1205 -- is replaced with a reference to Rnn.
1206
1207 -- If our parent is a conversion node then there is no point in
1208 -- generating a conversion to Result_Type. Instead, we let the parent
1209 -- handle this. Note that this special case is not just about
1210 -- optimization. Consider
1211
1212 -- A,B,C : Integer;
1213 -- ...
1214 -- X := Long_Long_Integer'Base (A * (B ** C));
1215
1216 -- Now the product may fit in Long_Long_Integer but not in Integer.
1217 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1218 -- overflow exception for this intermediate value.
1219
1220 declare
1221 Blk : constant Node_Id := Make_Bignum_Block (Loc);
1222 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
1223 RHS : Node_Id;
1224
1225 Rtype : Entity_Id;
1226
1227 begin
1228 RHS := Convert_From_Bignum (Op);
1229
1230 if Nkind (P) /= N_Type_Conversion then
1231 Convert_To_And_Rewrite (Result_Type, RHS);
1232 Rtype := Result_Type;
1233
1234 -- Interesting question, do we need a check on that conversion
1235 -- operation. Answer, not if we know the result is in range.
1236 -- At the moment we are not taking advantage of this. To be
1237 -- looked at later ???
1238
1239 else
1240 Rtype := LLIB;
1241 end if;
1242
1243 Insert_Before
1244 (First (Statements (Handled_Statement_Sequence (Blk))),
1245 Make_Assignment_Statement (Loc,
1246 Name => New_Occurrence_Of (Rnn, Loc),
1247 Expression => RHS));
1248
1249 Insert_Actions (Op, New_List (
1250 Make_Object_Declaration (Loc,
1251 Defining_Identifier => Rnn,
1252 Object_Definition => New_Occurrence_Of (Rtype, Loc)),
1253 Blk));
1254
1255 Rewrite (Op, New_Occurrence_Of (Rnn, Loc));
1256 Analyze_And_Resolve (Op);
1257 end;
1258
1259 -- Here we know the result is Long_Long_Integer'Base, or that it has
1260 -- been rewritten because the parent operation is a conversion. See
1261 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1262
1263 else
1264 pragma Assert
1265 (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion);
1266
1267 -- All we need to do here is to convert the result to the proper
1268 -- result type. As explained above for the Bignum case, we can
1269 -- omit this if our parent is a type conversion.
1270
1271 if Nkind (P) /= N_Type_Conversion then
1272 Convert_To_And_Rewrite (Result_Type, Op);
1273 end if;
1274
1275 Analyze_And_Resolve (Op);
1276 end if;
1277 end Apply_Arithmetic_Overflow_Minimized_Eliminated;
1278
1279 ----------------------------
1280 -- Apply_Constraint_Check --
1281 ----------------------------
1282
1283 procedure Apply_Constraint_Check
1284 (N : Node_Id;
1285 Typ : Entity_Id;
1286 No_Sliding : Boolean := False)
1287 is
1288 Desig_Typ : Entity_Id;
1289
1290 begin
1291 -- No checks inside a generic (check the instantiations)
1292
1293 if Inside_A_Generic then
1294 return;
1295 end if;
1296
1297 -- Apply required constraint checks
1298
1299 if Is_Scalar_Type (Typ) then
1300 Apply_Scalar_Range_Check (N, Typ);
1301
1302 elsif Is_Array_Type (Typ) then
1303
1304 -- A useful optimization: an aggregate with only an others clause
1305 -- always has the right bounds.
1306
1307 if Nkind (N) = N_Aggregate
1308 and then No (Expressions (N))
1309 and then Nkind
1310 (First (Choices (First (Component_Associations (N)))))
1311 = N_Others_Choice
1312 then
1313 return;
1314 end if;
1315
1316 if Is_Constrained (Typ) then
1317 Apply_Length_Check (N, Typ);
1318
1319 if No_Sliding then
1320 Apply_Range_Check (N, Typ);
1321 end if;
1322 else
1323 Apply_Range_Check (N, Typ);
1324 end if;
1325
1326 elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
1327 and then Has_Discriminants (Base_Type (Typ))
1328 and then Is_Constrained (Typ)
1329 then
1330 Apply_Discriminant_Check (N, Typ);
1331
1332 elsif Is_Access_Type (Typ) then
1333
1334 Desig_Typ := Designated_Type (Typ);
1335
1336 -- No checks necessary if expression statically null
1337
1338 if Known_Null (N) then
1339 if Can_Never_Be_Null (Typ) then
1340 Install_Null_Excluding_Check (N);
1341 end if;
1342
1343 -- No sliding possible on access to arrays
1344
1345 elsif Is_Array_Type (Desig_Typ) then
1346 if Is_Constrained (Desig_Typ) then
1347 Apply_Length_Check (N, Typ);
1348 end if;
1349
1350 Apply_Range_Check (N, Typ);
1351
1352 elsif Has_Discriminants (Base_Type (Desig_Typ))
1353 and then Is_Constrained (Desig_Typ)
1354 then
1355 Apply_Discriminant_Check (N, Typ);
1356 end if;
1357
1358 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1359 -- this check if the constraint node is illegal, as shown by having
1360 -- an error posted. This additional guard prevents cascaded errors
1361 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1362
1363 if Can_Never_Be_Null (Typ)
1364 and then not Can_Never_Be_Null (Etype (N))
1365 and then not Error_Posted (N)
1366 then
1367 Install_Null_Excluding_Check (N);
1368 end if;
1369 end if;
1370 end Apply_Constraint_Check;
1371
1372 ------------------------------
1373 -- Apply_Discriminant_Check --
1374 ------------------------------
1375
1376 procedure Apply_Discriminant_Check
1377 (N : Node_Id;
1378 Typ : Entity_Id;
1379 Lhs : Node_Id := Empty)
1380 is
1381 Loc : constant Source_Ptr := Sloc (N);
1382 Do_Access : constant Boolean := Is_Access_Type (Typ);
1383 S_Typ : Entity_Id := Etype (N);
1384 Cond : Node_Id;
1385 T_Typ : Entity_Id;
1386
1387 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
1388 -- A heap object with an indefinite subtype is constrained by its
1389 -- initial value, and assigning to it requires a constraint_check.
1390 -- The target may be an explicit dereference, or a renaming of one.
1391
1392 function Is_Aliased_Unconstrained_Component return Boolean;
1393 -- It is possible for an aliased component to have a nominal
1394 -- unconstrained subtype (through instantiation). If this is a
1395 -- discriminated component assigned in the expansion of an aggregate
1396 -- in an initialization, the check must be suppressed. This unusual
1397 -- situation requires a predicate of its own.
1398
1399 ----------------------------------
1400 -- Denotes_Explicit_Dereference --
1401 ----------------------------------
1402
1403 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
1404 begin
1405 return
1406 Nkind (Obj) = N_Explicit_Dereference
1407 or else
1408 (Is_Entity_Name (Obj)
1409 and then Present (Renamed_Object (Entity (Obj)))
1410 and then Nkind (Renamed_Object (Entity (Obj))) =
1411 N_Explicit_Dereference);
1412 end Denotes_Explicit_Dereference;
1413
1414 ----------------------------------------
1415 -- Is_Aliased_Unconstrained_Component --
1416 ----------------------------------------
1417
1418 function Is_Aliased_Unconstrained_Component return Boolean is
1419 Comp : Entity_Id;
1420 Pref : Node_Id;
1421
1422 begin
1423 if Nkind (Lhs) /= N_Selected_Component then
1424 return False;
1425 else
1426 Comp := Entity (Selector_Name (Lhs));
1427 Pref := Prefix (Lhs);
1428 end if;
1429
1430 if Ekind (Comp) /= E_Component
1431 or else not Is_Aliased (Comp)
1432 then
1433 return False;
1434 end if;
1435
1436 return not Comes_From_Source (Pref)
1437 and then In_Instance
1438 and then not Is_Constrained (Etype (Comp));
1439 end Is_Aliased_Unconstrained_Component;
1440
1441 -- Start of processing for Apply_Discriminant_Check
1442
1443 begin
1444 if Do_Access then
1445 T_Typ := Designated_Type (Typ);
1446 else
1447 T_Typ := Typ;
1448 end if;
1449
1450 -- Nothing to do if discriminant checks are suppressed or else no code
1451 -- is to be generated
1452
1453 if not Expander_Active
1454 or else Discriminant_Checks_Suppressed (T_Typ)
1455 then
1456 return;
1457 end if;
1458
1459 -- No discriminant checks necessary for an access when expression is
1460 -- statically Null. This is not only an optimization, it is fundamental
1461 -- because otherwise discriminant checks may be generated in init procs
1462 -- for types containing an access to a not-yet-frozen record, causing a
1463 -- deadly forward reference.
1464
1465 -- Also, if the expression is of an access type whose designated type is
1466 -- incomplete, then the access value must be null and we suppress the
1467 -- check.
1468
1469 if Known_Null (N) then
1470 return;
1471
1472 elsif Is_Access_Type (S_Typ) then
1473 S_Typ := Designated_Type (S_Typ);
1474
1475 if Ekind (S_Typ) = E_Incomplete_Type then
1476 return;
1477 end if;
1478 end if;
1479
1480 -- If an assignment target is present, then we need to generate the
1481 -- actual subtype if the target is a parameter or aliased object with
1482 -- an unconstrained nominal subtype.
1483
1484 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1485 -- subtype to the parameter and dereference cases, since other aliased
1486 -- objects are unconstrained (unless the nominal subtype is explicitly
1487 -- constrained).
1488
1489 if Present (Lhs)
1490 and then (Present (Param_Entity (Lhs))
1491 or else (Ada_Version < Ada_2005
1492 and then not Is_Constrained (T_Typ)
1493 and then Is_Aliased_View (Lhs)
1494 and then not Is_Aliased_Unconstrained_Component)
1495 or else (Ada_Version >= Ada_2005
1496 and then not Is_Constrained (T_Typ)
1497 and then Denotes_Explicit_Dereference (Lhs)
1498 and then Nkind (Original_Node (Lhs)) /=
1499 N_Function_Call))
1500 then
1501 T_Typ := Get_Actual_Subtype (Lhs);
1502 end if;
1503
1504 -- Nothing to do if the type is unconstrained (this is the case where
1505 -- the actual subtype in the RM sense of N is unconstrained and no check
1506 -- is required).
1507
1508 if not Is_Constrained (T_Typ) then
1509 return;
1510
1511 -- Ada 2005: nothing to do if the type is one for which there is a
1512 -- partial view that is constrained.
1513
1514 elsif Ada_Version >= Ada_2005
1515 and then Object_Type_Has_Constrained_Partial_View
1516 (Typ => Base_Type (T_Typ),
1517 Scop => Current_Scope)
1518 then
1519 return;
1520 end if;
1521
1522 -- Nothing to do if the type is an Unchecked_Union
1523
1524 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1525 return;
1526 end if;
1527
1528 -- Suppress checks if the subtypes are the same. The check must be
1529 -- preserved in an assignment to a formal, because the constraint is
1530 -- given by the actual.
1531
1532 if Nkind (Original_Node (N)) /= N_Allocator
1533 and then (No (Lhs)
1534 or else not Is_Entity_Name (Lhs)
1535 or else No (Param_Entity (Lhs)))
1536 then
1537 if (Etype (N) = Typ
1538 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1539 and then not Is_Aliased_View (Lhs)
1540 then
1541 return;
1542 end if;
1543
1544 -- We can also eliminate checks on allocators with a subtype mark that
1545 -- coincides with the context type. The context type may be a subtype
1546 -- without a constraint (common case, a generic actual).
1547
1548 elsif Nkind (Original_Node (N)) = N_Allocator
1549 and then Is_Entity_Name (Expression (Original_Node (N)))
1550 then
1551 declare
1552 Alloc_Typ : constant Entity_Id :=
1553 Entity (Expression (Original_Node (N)));
1554
1555 begin
1556 if Alloc_Typ = T_Typ
1557 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1558 and then Is_Entity_Name (
1559 Subtype_Indication (Parent (T_Typ)))
1560 and then Alloc_Typ = Base_Type (T_Typ))
1561
1562 then
1563 return;
1564 end if;
1565 end;
1566 end if;
1567
1568 -- See if we have a case where the types are both constrained, and all
1569 -- the constraints are constants. In this case, we can do the check
1570 -- successfully at compile time.
1571
1572 -- We skip this check for the case where the node is rewritten as
1573 -- an allocator, because it already carries the context subtype,
1574 -- and extracting the discriminants from the aggregate is messy.
1575
1576 if Is_Constrained (S_Typ)
1577 and then Nkind (Original_Node (N)) /= N_Allocator
1578 then
1579 declare
1580 DconT : Elmt_Id;
1581 Discr : Entity_Id;
1582 DconS : Elmt_Id;
1583 ItemS : Node_Id;
1584 ItemT : Node_Id;
1585
1586 begin
1587 -- S_Typ may not have discriminants in the case where it is a
1588 -- private type completed by a default discriminated type. In that
1589 -- case, we need to get the constraints from the underlying type.
1590 -- If the underlying type is unconstrained (i.e. has no default
1591 -- discriminants) no check is needed.
1592
1593 if Has_Discriminants (S_Typ) then
1594 Discr := First_Discriminant (S_Typ);
1595 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1596
1597 else
1598 Discr := First_Discriminant (Underlying_Type (S_Typ));
1599 DconS :=
1600 First_Elmt
1601 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1602
1603 if No (DconS) then
1604 return;
1605 end if;
1606
1607 -- A further optimization: if T_Typ is derived from S_Typ
1608 -- without imposing a constraint, no check is needed.
1609
1610 if Nkind (Original_Node (Parent (T_Typ))) =
1611 N_Full_Type_Declaration
1612 then
1613 declare
1614 Type_Def : constant Node_Id :=
1615 Type_Definition (Original_Node (Parent (T_Typ)));
1616 begin
1617 if Nkind (Type_Def) = N_Derived_Type_Definition
1618 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1619 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1620 then
1621 return;
1622 end if;
1623 end;
1624 end if;
1625 end if;
1626
1627 -- Constraint may appear in full view of type
1628
1629 if Ekind (T_Typ) = E_Private_Subtype
1630 and then Present (Full_View (T_Typ))
1631 then
1632 DconT :=
1633 First_Elmt (Discriminant_Constraint (Full_View (T_Typ)));
1634 else
1635 DconT :=
1636 First_Elmt (Discriminant_Constraint (T_Typ));
1637 end if;
1638
1639 while Present (Discr) loop
1640 ItemS := Node (DconS);
1641 ItemT := Node (DconT);
1642
1643 -- For a discriminated component type constrained by the
1644 -- current instance of an enclosing type, there is no
1645 -- applicable discriminant check.
1646
1647 if Nkind (ItemT) = N_Attribute_Reference
1648 and then Is_Access_Type (Etype (ItemT))
1649 and then Is_Entity_Name (Prefix (ItemT))
1650 and then Is_Type (Entity (Prefix (ItemT)))
1651 then
1652 return;
1653 end if;
1654
1655 -- If the expressions for the discriminants are identical
1656 -- and it is side-effect free (for now just an entity),
1657 -- this may be a shared constraint, e.g. from a subtype
1658 -- without a constraint introduced as a generic actual.
1659 -- Examine other discriminants if any.
1660
1661 if ItemS = ItemT
1662 and then Is_Entity_Name (ItemS)
1663 then
1664 null;
1665
1666 elsif not Is_OK_Static_Expression (ItemS)
1667 or else not Is_OK_Static_Expression (ItemT)
1668 then
1669 exit;
1670
1671 elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
1672 if Do_Access then -- needs run-time check.
1673 exit;
1674 else
1675 Apply_Compile_Time_Constraint_Error
1676 (N, "incorrect value for discriminant&??",
1677 CE_Discriminant_Check_Failed, Ent => Discr);
1678 return;
1679 end if;
1680 end if;
1681
1682 Next_Elmt (DconS);
1683 Next_Elmt (DconT);
1684 Next_Discriminant (Discr);
1685 end loop;
1686
1687 if No (Discr) then
1688 return;
1689 end if;
1690 end;
1691 end if;
1692
1693 -- Here we need a discriminant check. First build the expression
1694 -- for the comparisons of the discriminants:
1695
1696 -- (n.disc1 /= typ.disc1) or else
1697 -- (n.disc2 /= typ.disc2) or else
1698 -- ...
1699 -- (n.discn /= typ.discn)
1700
1701 Cond := Build_Discriminant_Checks (N, T_Typ);
1702
1703 -- If Lhs is set and is a parameter, then the condition is guarded by:
1704 -- lhs'constrained and then (condition built above)
1705
1706 if Present (Param_Entity (Lhs)) then
1707 Cond :=
1708 Make_And_Then (Loc,
1709 Left_Opnd =>
1710 Make_Attribute_Reference (Loc,
1711 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1712 Attribute_Name => Name_Constrained),
1713 Right_Opnd => Cond);
1714 end if;
1715
1716 if Do_Access then
1717 Cond := Guard_Access (Cond, Loc, N);
1718 end if;
1719
1720 Insert_Action (N,
1721 Make_Raise_Constraint_Error (Loc,
1722 Condition => Cond,
1723 Reason => CE_Discriminant_Check_Failed));
1724 end Apply_Discriminant_Check;
1725
1726 -------------------------
1727 -- Apply_Divide_Checks --
1728 -------------------------
1729
1730 procedure Apply_Divide_Checks (N : Node_Id) is
1731 Loc : constant Source_Ptr := Sloc (N);
1732 Typ : constant Entity_Id := Etype (N);
1733 Left : constant Node_Id := Left_Opnd (N);
1734 Right : constant Node_Id := Right_Opnd (N);
1735
1736 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
1737 -- Current overflow checking mode
1738
1739 LLB : Uint;
1740 Llo : Uint;
1741 Lhi : Uint;
1742 LOK : Boolean;
1743 Rlo : Uint;
1744 Rhi : Uint;
1745 ROK : Boolean;
1746
1747 pragma Warnings (Off, Lhi);
1748 -- Don't actually use this value
1749
1750 begin
1751 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1752 -- operating on signed integer types, then the only thing this routine
1753 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1754 -- procedure will (possibly later on during recursive downward calls),
1755 -- ensure that any needed overflow/division checks are properly applied.
1756
1757 if Mode in Minimized_Or_Eliminated
1758 and then Is_Signed_Integer_Type (Typ)
1759 then
1760 Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
1761 return;
1762 end if;
1763
1764 -- Proceed here in SUPPRESSED or CHECKED modes
1765
1766 if Expander_Active
1767 and then not Backend_Divide_Checks_On_Target
1768 and then Check_Needed (Right, Division_Check)
1769 then
1770 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
1771
1772 -- Deal with division check
1773
1774 if Do_Division_Check (N)
1775 and then not Division_Checks_Suppressed (Typ)
1776 then
1777 Apply_Division_Check (N, Rlo, Rhi, ROK);
1778 end if;
1779
1780 -- Deal with overflow check
1781
1782 if Do_Overflow_Check (N)
1783 and then not Overflow_Checks_Suppressed (Etype (N))
1784 then
1785 Set_Do_Overflow_Check (N, False);
1786
1787 -- Test for extremely annoying case of xxx'First divided by -1
1788 -- for division of signed integer types (only overflow case).
1789
1790 if Nkind (N) = N_Op_Divide
1791 and then Is_Signed_Integer_Type (Typ)
1792 then
1793 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
1794 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1795
1796 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1797 and then
1798 ((not LOK) or else (Llo = LLB))
1799 then
1800 Insert_Action (N,
1801 Make_Raise_Constraint_Error (Loc,
1802 Condition =>
1803 Make_And_Then (Loc,
1804 Left_Opnd =>
1805 Make_Op_Eq (Loc,
1806 Left_Opnd =>
1807 Duplicate_Subexpr_Move_Checks (Left),
1808 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1809
1810 Right_Opnd =>
1811 Make_Op_Eq (Loc,
1812 Left_Opnd => Duplicate_Subexpr (Right),
1813 Right_Opnd => Make_Integer_Literal (Loc, -1))),
1814
1815 Reason => CE_Overflow_Check_Failed));
1816 end if;
1817 end if;
1818 end if;
1819 end if;
1820 end Apply_Divide_Checks;
1821
1822 --------------------------
1823 -- Apply_Division_Check --
1824 --------------------------
1825
1826 procedure Apply_Division_Check
1827 (N : Node_Id;
1828 Rlo : Uint;
1829 Rhi : Uint;
1830 ROK : Boolean)
1831 is
1832 pragma Assert (Do_Division_Check (N));
1833
1834 Loc : constant Source_Ptr := Sloc (N);
1835 Right : constant Node_Id := Right_Opnd (N);
1836
1837 begin
1838 if Expander_Active
1839 and then not Backend_Divide_Checks_On_Target
1840 and then Check_Needed (Right, Division_Check)
1841 then
1842 -- See if division by zero possible, and if so generate test. This
1843 -- part of the test is not controlled by the -gnato switch, since
1844 -- it is a Division_Check and not an Overflow_Check.
1845
1846 if Do_Division_Check (N) then
1847 Set_Do_Division_Check (N, False);
1848
1849 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1850 Insert_Action (N,
1851 Make_Raise_Constraint_Error (Loc,
1852 Condition =>
1853 Make_Op_Eq (Loc,
1854 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1855 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1856 Reason => CE_Divide_By_Zero));
1857 end if;
1858 end if;
1859 end if;
1860 end Apply_Division_Check;
1861
1862 ----------------------------------
1863 -- Apply_Float_Conversion_Check --
1864 ----------------------------------
1865
1866 -- Let F and I be the source and target types of the conversion. The RM
1867 -- specifies that a floating-point value X is rounded to the nearest
1868 -- integer, with halfway cases being rounded away from zero. The rounded
1869 -- value of X is checked against I'Range.
1870
1871 -- The catch in the above paragraph is that there is no good way to know
1872 -- whether the round-to-integer operation resulted in overflow. A remedy is
1873 -- to perform a range check in the floating-point domain instead, however:
1874
1875 -- (1) The bounds may not be known at compile time
1876 -- (2) The check must take into account rounding or truncation.
1877 -- (3) The range of type I may not be exactly representable in F.
1878 -- (4) For the rounding case, The end-points I'First - 0.5 and
1879 -- I'Last + 0.5 may or may not be in range, depending on the
1880 -- sign of I'First and I'Last.
1881 -- (5) X may be a NaN, which will fail any comparison
1882
1883 -- The following steps correctly convert X with rounding:
1884
1885 -- (1) If either I'First or I'Last is not known at compile time, use
1886 -- I'Base instead of I in the next three steps and perform a
1887 -- regular range check against I'Range after conversion.
1888 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1889 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1890 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1891 -- In other words, take one of the closest floating-point numbers
1892 -- (which is an integer value) to I'First, and see if it is in
1893 -- range or not.
1894 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1895 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1896 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1897 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1898 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1899
1900 -- For the truncating case, replace steps (2) and (3) as follows:
1901 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1902 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1903 -- Lo_OK be True.
1904 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1905 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1906 -- Hi_OK be True.
1907
1908 procedure Apply_Float_Conversion_Check
1909 (Ck_Node : Node_Id;
1910 Target_Typ : Entity_Id)
1911 is
1912 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1913 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1914 Loc : constant Source_Ptr := Sloc (Ck_Node);
1915 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1916 Target_Base : constant Entity_Id :=
1917 Implementation_Base_Type (Target_Typ);
1918
1919 Par : constant Node_Id := Parent (Ck_Node);
1920 pragma Assert (Nkind (Par) = N_Type_Conversion);
1921 -- Parent of check node, must be a type conversion
1922
1923 Truncate : constant Boolean := Float_Truncate (Par);
1924 Max_Bound : constant Uint :=
1925 UI_Expon
1926 (Machine_Radix_Value (Expr_Type),
1927 Machine_Mantissa_Value (Expr_Type) - 1) - 1;
1928
1929 -- Largest bound, so bound plus or minus half is a machine number of F
1930
1931 Ifirst, Ilast : Uint;
1932 -- Bounds of integer type
1933
1934 Lo, Hi : Ureal;
1935 -- Bounds to check in floating-point domain
1936
1937 Lo_OK, Hi_OK : Boolean;
1938 -- True iff Lo resp. Hi belongs to I'Range
1939
1940 Lo_Chk, Hi_Chk : Node_Id;
1941 -- Expressions that are False iff check fails
1942
1943 Reason : RT_Exception_Code;
1944
1945 begin
1946 -- We do not need checks if we are not generating code (i.e. the full
1947 -- expander is not active). In SPARK mode, we specifically don't want
1948 -- the frontend to expand these checks, which are dealt with directly
1949 -- in the formal verification backend.
1950
1951 if not Expander_Active then
1952 return;
1953 end if;
1954
1955 if not Compile_Time_Known_Value (LB)
1956 or not Compile_Time_Known_Value (HB)
1957 then
1958 declare
1959 -- First check that the value falls in the range of the base type,
1960 -- to prevent overflow during conversion and then perform a
1961 -- regular range check against the (dynamic) bounds.
1962
1963 pragma Assert (Target_Base /= Target_Typ);
1964
1965 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
1966
1967 begin
1968 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
1969 Set_Etype (Temp, Target_Base);
1970
1971 Insert_Action (Parent (Par),
1972 Make_Object_Declaration (Loc,
1973 Defining_Identifier => Temp,
1974 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
1975 Expression => New_Copy_Tree (Par)),
1976 Suppress => All_Checks);
1977
1978 Insert_Action (Par,
1979 Make_Raise_Constraint_Error (Loc,
1980 Condition =>
1981 Make_Not_In (Loc,
1982 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1983 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
1984 Reason => CE_Range_Check_Failed));
1985 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
1986
1987 return;
1988 end;
1989 end if;
1990
1991 -- Get the (static) bounds of the target type
1992
1993 Ifirst := Expr_Value (LB);
1994 Ilast := Expr_Value (HB);
1995
1996 -- A simple optimization: if the expression is a universal literal,
1997 -- we can do the comparison with the bounds and the conversion to
1998 -- an integer type statically. The range checks are unchanged.
1999
2000 if Nkind (Ck_Node) = N_Real_Literal
2001 and then Etype (Ck_Node) = Universal_Real
2002 and then Is_Integer_Type (Target_Typ)
2003 and then Nkind (Parent (Ck_Node)) = N_Type_Conversion
2004 then
2005 declare
2006 Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
2007
2008 begin
2009 if Int_Val <= Ilast and then Int_Val >= Ifirst then
2010
2011 -- Conversion is safe
2012
2013 Rewrite (Parent (Ck_Node),
2014 Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
2015 Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
2016 return;
2017 end if;
2018 end;
2019 end if;
2020
2021 -- Check against lower bound
2022
2023 if Truncate and then Ifirst > 0 then
2024 Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
2025 Lo_OK := False;
2026
2027 elsif Truncate then
2028 Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
2029 Lo_OK := True;
2030
2031 elsif abs (Ifirst) < Max_Bound then
2032 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
2033 Lo_OK := (Ifirst > 0);
2034
2035 else
2036 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
2037 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
2038 end if;
2039
2040 if Lo_OK then
2041
2042 -- Lo_Chk := (X >= Lo)
2043
2044 Lo_Chk := Make_Op_Ge (Loc,
2045 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2046 Right_Opnd => Make_Real_Literal (Loc, Lo));
2047
2048 else
2049 -- Lo_Chk := (X > Lo)
2050
2051 Lo_Chk := Make_Op_Gt (Loc,
2052 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2053 Right_Opnd => Make_Real_Literal (Loc, Lo));
2054 end if;
2055
2056 -- Check against higher bound
2057
2058 if Truncate and then Ilast < 0 then
2059 Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
2060 Hi_OK := False;
2061
2062 elsif Truncate then
2063 Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
2064 Hi_OK := True;
2065
2066 elsif abs (Ilast) < Max_Bound then
2067 Hi := UR_From_Uint (Ilast) + Ureal_Half;
2068 Hi_OK := (Ilast < 0);
2069 else
2070 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
2071 Hi_OK := (Hi <= UR_From_Uint (Ilast));
2072 end if;
2073
2074 if Hi_OK then
2075
2076 -- Hi_Chk := (X <= Hi)
2077
2078 Hi_Chk := Make_Op_Le (Loc,
2079 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2080 Right_Opnd => Make_Real_Literal (Loc, Hi));
2081
2082 else
2083 -- Hi_Chk := (X < Hi)
2084
2085 Hi_Chk := Make_Op_Lt (Loc,
2086 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
2087 Right_Opnd => Make_Real_Literal (Loc, Hi));
2088 end if;
2089
2090 -- If the bounds of the target type are the same as those of the base
2091 -- type, the check is an overflow check as a range check is not
2092 -- performed in these cases.
2093
2094 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
2095 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
2096 then
2097 Reason := CE_Overflow_Check_Failed;
2098 else
2099 Reason := CE_Range_Check_Failed;
2100 end if;
2101
2102 -- Raise CE if either conditions does not hold
2103
2104 Insert_Action (Ck_Node,
2105 Make_Raise_Constraint_Error (Loc,
2106 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
2107 Reason => Reason));
2108 end Apply_Float_Conversion_Check;
2109
2110 ------------------------
2111 -- Apply_Length_Check --
2112 ------------------------
2113
2114 procedure Apply_Length_Check
2115 (Ck_Node : Node_Id;
2116 Target_Typ : Entity_Id;
2117 Source_Typ : Entity_Id := Empty)
2118 is
2119 begin
2120 Apply_Selected_Length_Checks
2121 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2122 end Apply_Length_Check;
2123
2124 -------------------------------------
2125 -- Apply_Parameter_Aliasing_Checks --
2126 -------------------------------------
2127
2128 procedure Apply_Parameter_Aliasing_Checks
2129 (Call : Node_Id;
2130 Subp : Entity_Id)
2131 is
2132 Loc : constant Source_Ptr := Sloc (Call);
2133
2134 function May_Cause_Aliasing
2135 (Formal_1 : Entity_Id;
2136 Formal_2 : Entity_Id) return Boolean;
2137 -- Determine whether two formal parameters can alias each other
2138 -- depending on their modes.
2139
2140 function Original_Actual (N : Node_Id) return Node_Id;
2141 -- The expander may replace an actual with a temporary for the sake of
2142 -- side effect removal. The temporary may hide a potential aliasing as
2143 -- it does not share the address of the actual. This routine attempts
2144 -- to retrieve the original actual.
2145
2146 procedure Overlap_Check
2147 (Actual_1 : Node_Id;
2148 Actual_2 : Node_Id;
2149 Formal_1 : Entity_Id;
2150 Formal_2 : Entity_Id;
2151 Check : in out Node_Id);
2152 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2153 -- If detailed exception messages are enabled, the check is augmented to
2154 -- provide information about the names of the corresponding formals. See
2155 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2156 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2157 -- Check contains all and-ed simple tests generated so far or remains
2158 -- unchanged in the case of detailed exception messaged.
2159
2160 ------------------------
2161 -- May_Cause_Aliasing --
2162 ------------------------
2163
2164 function May_Cause_Aliasing
2165 (Formal_1 : Entity_Id;
2166 Formal_2 : Entity_Id) return Boolean
2167 is
2168 begin
2169 -- The following combination cannot lead to aliasing
2170
2171 -- Formal 1 Formal 2
2172 -- IN IN
2173
2174 if Ekind (Formal_1) = E_In_Parameter
2175 and then
2176 Ekind (Formal_2) = E_In_Parameter
2177 then
2178 return False;
2179
2180 -- The following combinations may lead to aliasing
2181
2182 -- Formal 1 Formal 2
2183 -- IN OUT
2184 -- IN IN OUT
2185 -- OUT IN
2186 -- OUT IN OUT
2187 -- OUT OUT
2188
2189 else
2190 return True;
2191 end if;
2192 end May_Cause_Aliasing;
2193
2194 ---------------------
2195 -- Original_Actual --
2196 ---------------------
2197
2198 function Original_Actual (N : Node_Id) return Node_Id is
2199 begin
2200 if Nkind (N) = N_Type_Conversion then
2201 return Expression (N);
2202
2203 -- The expander created a temporary to capture the result of a type
2204 -- conversion where the expression is the real actual.
2205
2206 elsif Nkind (N) = N_Identifier
2207 and then Present (Original_Node (N))
2208 and then Nkind (Original_Node (N)) = N_Type_Conversion
2209 then
2210 return Expression (Original_Node (N));
2211 end if;
2212
2213 return N;
2214 end Original_Actual;
2215
2216 -------------------
2217 -- Overlap_Check --
2218 -------------------
2219
2220 procedure Overlap_Check
2221 (Actual_1 : Node_Id;
2222 Actual_2 : Node_Id;
2223 Formal_1 : Entity_Id;
2224 Formal_2 : Entity_Id;
2225 Check : in out Node_Id)
2226 is
2227 Cond : Node_Id;
2228 ID_Casing : constant Casing_Type :=
2229 Identifier_Casing (Source_Index (Current_Sem_Unit));
2230
2231 begin
2232 -- Generate:
2233 -- Actual_1'Overlaps_Storage (Actual_2)
2234
2235 Cond :=
2236 Make_Attribute_Reference (Loc,
2237 Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
2238 Attribute_Name => Name_Overlaps_Storage,
2239 Expressions =>
2240 New_List (New_Copy_Tree (Original_Actual (Actual_2))));
2241
2242 -- Generate the following check when detailed exception messages are
2243 -- enabled:
2244
2245 -- if Actual_1'Overlaps_Storage (Actual_2) then
2246 -- raise Program_Error with <detailed message>;
2247 -- end if;
2248
2249 if Exception_Extra_Info then
2250 Start_String;
2251
2252 -- Do not generate location information for internal calls
2253
2254 if Comes_From_Source (Call) then
2255 Store_String_Chars (Build_Location_String (Loc));
2256 Store_String_Char (' ');
2257 end if;
2258
2259 Store_String_Chars ("aliased parameters, actuals for """);
2260
2261 Get_Name_String (Chars (Formal_1));
2262 Set_Casing (ID_Casing);
2263 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2264
2265 Store_String_Chars (""" and """);
2266
2267 Get_Name_String (Chars (Formal_2));
2268 Set_Casing (ID_Casing);
2269 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2270
2271 Store_String_Chars (""" overlap");
2272
2273 Insert_Action (Call,
2274 Make_If_Statement (Loc,
2275 Condition => Cond,
2276 Then_Statements => New_List (
2277 Make_Raise_Statement (Loc,
2278 Name =>
2279 New_Occurrence_Of (Standard_Program_Error, Loc),
2280 Expression => Make_String_Literal (Loc, End_String)))));
2281
2282 -- Create a sequence of overlapping checks by and-ing them all
2283 -- together.
2284
2285 else
2286 if No (Check) then
2287 Check := Cond;
2288 else
2289 Check :=
2290 Make_And_Then (Loc,
2291 Left_Opnd => Check,
2292 Right_Opnd => Cond);
2293 end if;
2294 end if;
2295 end Overlap_Check;
2296
2297 -- Local variables
2298
2299 Actual_1 : Node_Id;
2300 Actual_2 : Node_Id;
2301 Check : Node_Id;
2302 Formal_1 : Entity_Id;
2303 Formal_2 : Entity_Id;
2304 Orig_Act_1 : Node_Id;
2305 Orig_Act_2 : Node_Id;
2306
2307 -- Start of processing for Apply_Parameter_Aliasing_Checks
2308
2309 begin
2310 Check := Empty;
2311
2312 Actual_1 := First_Actual (Call);
2313 Formal_1 := First_Formal (Subp);
2314 while Present (Actual_1) and then Present (Formal_1) loop
2315 Orig_Act_1 := Original_Actual (Actual_1);
2316
2317 -- Ensure that the actual is an object that is not passed by value.
2318 -- Elementary types are always passed by value, therefore actuals of
2319 -- such types cannot lead to aliasing. An aggregate is an object in
2320 -- Ada 2012, but an actual that is an aggregate cannot overlap with
2321 -- another actual. A type that is By_Reference (such as an array of
2322 -- controlled types) is not subject to the check because any update
2323 -- will be done in place and a subsequent read will always see the
2324 -- correct value, see RM 6.2 (12/3).
2325
2326 if Nkind (Orig_Act_1) = N_Aggregate
2327 or else (Nkind (Orig_Act_1) = N_Qualified_Expression
2328 and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
2329 then
2330 null;
2331
2332 elsif Is_Object_Reference (Orig_Act_1)
2333 and then not Is_Elementary_Type (Etype (Orig_Act_1))
2334 and then not Is_By_Reference_Type (Etype (Orig_Act_1))
2335 then
2336 Actual_2 := Next_Actual (Actual_1);
2337 Formal_2 := Next_Formal (Formal_1);
2338 while Present (Actual_2) and then Present (Formal_2) loop
2339 Orig_Act_2 := Original_Actual (Actual_2);
2340
2341 -- The other actual we are testing against must also denote
2342 -- a non pass-by-value object. Generate the check only when
2343 -- the mode of the two formals may lead to aliasing.
2344
2345 if Is_Object_Reference (Orig_Act_2)
2346 and then not Is_Elementary_Type (Etype (Orig_Act_2))
2347 and then May_Cause_Aliasing (Formal_1, Formal_2)
2348 then
2349 Overlap_Check
2350 (Actual_1 => Actual_1,
2351 Actual_2 => Actual_2,
2352 Formal_1 => Formal_1,
2353 Formal_2 => Formal_2,
2354 Check => Check);
2355 end if;
2356
2357 Next_Actual (Actual_2);
2358 Next_Formal (Formal_2);
2359 end loop;
2360 end if;
2361
2362 Next_Actual (Actual_1);
2363 Next_Formal (Formal_1);
2364 end loop;
2365
2366 -- Place a simple check right before the call
2367
2368 if Present (Check) and then not Exception_Extra_Info then
2369 Insert_Action (Call,
2370 Make_Raise_Program_Error (Loc,
2371 Condition => Check,
2372 Reason => PE_Aliased_Parameters));
2373 end if;
2374 end Apply_Parameter_Aliasing_Checks;
2375
2376 -------------------------------------
2377 -- Apply_Parameter_Validity_Checks --
2378 -------------------------------------
2379
2380 procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
2381 Subp_Decl : Node_Id;
2382
2383 procedure Add_Validity_Check
2384 (Formal : Entity_Id;
2385 Prag_Nam : Name_Id;
2386 For_Result : Boolean := False);
2387 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2388 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2389 -- Set flag For_Result when to verify the result of a function.
2390
2391 ------------------------
2392 -- Add_Validity_Check --
2393 ------------------------
2394
2395 procedure Add_Validity_Check
2396 (Formal : Entity_Id;
2397 Prag_Nam : Name_Id;
2398 For_Result : Boolean := False)
2399 is
2400 procedure Build_Pre_Post_Condition (Expr : Node_Id);
2401 -- Create a pre/postcondition pragma that tests expression Expr
2402
2403 ------------------------------
2404 -- Build_Pre_Post_Condition --
2405 ------------------------------
2406
2407 procedure Build_Pre_Post_Condition (Expr : Node_Id) is
2408 Loc : constant Source_Ptr := Sloc (Subp);
2409 Decls : List_Id;
2410 Prag : Node_Id;
2411
2412 begin
2413 Prag :=
2414 Make_Pragma (Loc,
2415 Pragma_Identifier =>
2416 Make_Identifier (Loc, Prag_Nam),
2417 Pragma_Argument_Associations => New_List (
2418 Make_Pragma_Argument_Association (Loc,
2419 Chars => Name_Check,
2420 Expression => Expr)));
2421
2422 -- Add a message unless exception messages are suppressed
2423
2424 if not Exception_Locations_Suppressed then
2425 Append_To (Pragma_Argument_Associations (Prag),
2426 Make_Pragma_Argument_Association (Loc,
2427 Chars => Name_Message,
2428 Expression =>
2429 Make_String_Literal (Loc,
2430 Strval => "failed "
2431 & Get_Name_String (Prag_Nam)
2432 & " from "
2433 & Build_Location_String (Loc))));
2434 end if;
2435
2436 -- Insert the pragma in the tree
2437
2438 if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then
2439 Add_Global_Declaration (Prag);
2440 Analyze (Prag);
2441
2442 -- PPC pragmas associated with subprogram bodies must be inserted
2443 -- in the declarative part of the body.
2444
2445 elsif Nkind (Subp_Decl) = N_Subprogram_Body then
2446 Decls := Declarations (Subp_Decl);
2447
2448 if No (Decls) then
2449 Decls := New_List;
2450 Set_Declarations (Subp_Decl, Decls);
2451 end if;
2452
2453 Prepend_To (Decls, Prag);
2454 Analyze (Prag);
2455
2456 -- For subprogram declarations insert the PPC pragma right after
2457 -- the declarative node.
2458
2459 else
2460 Insert_After_And_Analyze (Subp_Decl, Prag);
2461 end if;
2462 end Build_Pre_Post_Condition;
2463
2464 -- Local variables
2465
2466 Loc : constant Source_Ptr := Sloc (Subp);
2467 Typ : constant Entity_Id := Etype (Formal);
2468 Check : Node_Id;
2469 Nam : Name_Id;
2470
2471 -- Start of processing for Add_Validity_Check
2472
2473 begin
2474 -- For scalars, generate 'Valid test
2475
2476 if Is_Scalar_Type (Typ) then
2477 Nam := Name_Valid;
2478
2479 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2480
2481 elsif Scalar_Part_Present (Typ) then
2482 Nam := Name_Valid_Scalars;
2483
2484 -- No test needed for other cases (no scalars to test)
2485
2486 else
2487 return;
2488 end if;
2489
2490 -- Step 1: Create the expression to verify the validity of the
2491 -- context.
2492
2493 Check := New_Occurrence_Of (Formal, Loc);
2494
2495 -- When processing a function result, use 'Result. Generate
2496 -- Context'Result
2497
2498 if For_Result then
2499 Check :=
2500 Make_Attribute_Reference (Loc,
2501 Prefix => Check,
2502 Attribute_Name => Name_Result);
2503 end if;
2504
2505 -- Generate:
2506 -- Context['Result]'Valid[_Scalars]
2507
2508 Check :=
2509 Make_Attribute_Reference (Loc,
2510 Prefix => Check,
2511 Attribute_Name => Nam);
2512
2513 -- Step 2: Create a pre or post condition pragma
2514
2515 Build_Pre_Post_Condition (Check);
2516 end Add_Validity_Check;
2517
2518 -- Local variables
2519
2520 Formal : Entity_Id;
2521 Subp_Spec : Node_Id;
2522
2523 -- Start of processing for Apply_Parameter_Validity_Checks
2524
2525 begin
2526 -- Extract the subprogram specification and declaration nodes
2527
2528 Subp_Spec := Parent (Subp);
2529
2530 if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
2531 Subp_Spec := Parent (Subp_Spec);
2532 end if;
2533
2534 Subp_Decl := Parent (Subp_Spec);
2535
2536 if not Comes_From_Source (Subp)
2537
2538 -- Do not process formal subprograms because the corresponding actual
2539 -- will receive the proper checks when the instance is analyzed.
2540
2541 or else Is_Formal_Subprogram (Subp)
2542
2543 -- Do not process imported subprograms since pre and postconditions
2544 -- are never verified on routines coming from a different language.
2545
2546 or else Is_Imported (Subp)
2547 or else Is_Intrinsic_Subprogram (Subp)
2548
2549 -- The PPC pragmas generated by this routine do not correspond to
2550 -- source aspects, therefore they cannot be applied to abstract
2551 -- subprograms.
2552
2553 or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
2554
2555 -- Do not consider subprogram renaminds because the renamed entity
2556 -- already has the proper PPC pragmas.
2557
2558 or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
2559
2560 -- Do not process null procedures because there is no benefit of
2561 -- adding the checks to a no action routine.
2562
2563 or else (Nkind (Subp_Spec) = N_Procedure_Specification
2564 and then Null_Present (Subp_Spec))
2565 then
2566 return;
2567 end if;
2568
2569 -- Inspect all the formals applying aliasing and scalar initialization
2570 -- checks where applicable.
2571
2572 Formal := First_Formal (Subp);
2573 while Present (Formal) loop
2574
2575 -- Generate the following scalar initialization checks for each
2576 -- formal parameter:
2577
2578 -- mode IN - Pre => Formal'Valid[_Scalars]
2579 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2580 -- mode OUT - Post => Formal'Valid[_Scalars]
2581
2582 if Check_Validity_Of_Parameters then
2583 if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
2584 Add_Validity_Check (Formal, Name_Precondition, False);
2585 end if;
2586
2587 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
2588 Add_Validity_Check (Formal, Name_Postcondition, False);
2589 end if;
2590 end if;
2591
2592 Next_Formal (Formal);
2593 end loop;
2594
2595 -- Generate following scalar initialization check for function result:
2596
2597 -- Post => Subp'Result'Valid[_Scalars]
2598
2599 if Check_Validity_Of_Parameters and then Ekind (Subp) = E_Function then
2600 Add_Validity_Check (Subp, Name_Postcondition, True);
2601 end if;
2602 end Apply_Parameter_Validity_Checks;
2603
2604 ---------------------------
2605 -- Apply_Predicate_Check --
2606 ---------------------------
2607
2608 procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
2609 S : Entity_Id;
2610
2611 begin
2612 if Predicate_Checks_Suppressed (Empty) then
2613 return;
2614
2615 elsif Predicates_Ignored (Typ) then
2616 return;
2617
2618 elsif Present (Predicate_Function (Typ)) then
2619 S := Current_Scope;
2620 while Present (S) and then not Is_Subprogram (S) loop
2621 S := Scope (S);
2622 end loop;
2623
2624 -- A predicate check does not apply within internally generated
2625 -- subprograms, such as TSS functions.
2626
2627 if Within_Internal_Subprogram then
2628 return;
2629
2630 -- If the check appears within the predicate function itself, it
2631 -- means that the user specified a check whose formal is the
2632 -- predicated subtype itself, rather than some covering type. This
2633 -- is likely to be a common error, and thus deserves a warning.
2634
2635 elsif Present (S) and then S = Predicate_Function (Typ) then
2636 Error_Msg_N
2637 ("predicate check includes a function call that "
2638 & "requires a predicate check??", Parent (N));
2639 Error_Msg_N
2640 ("\this will result in infinite recursion??", Parent (N));
2641 Insert_Action (N,
2642 Make_Raise_Storage_Error (Sloc (N),
2643 Reason => SE_Infinite_Recursion));
2644
2645 -- Here for normal case of predicate active
2646
2647 else
2648 -- If the type has a static predicate and the expression is known
2649 -- at compile time, see if the expression satisfies the predicate.
2650
2651 Check_Expression_Against_Static_Predicate (N, Typ);
2652
2653 if not Expander_Active then
2654 return;
2655 end if;
2656
2657 -- For an entity of the type, generate a call to the predicate
2658 -- function, unless its type is an actual subtype, which is not
2659 -- visible outside of the enclosing subprogram.
2660
2661 if Is_Entity_Name (N)
2662 and then not Is_Actual_Subtype (Typ)
2663 then
2664 Insert_Action (N,
2665 Make_Predicate_Check
2666 (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
2667
2668 -- If the expression is not an entity it may have side effects,
2669 -- and the following call will create an object declaration for
2670 -- it. We disable checks during its analysis, to prevent an
2671 -- infinite recursion.
2672
2673 else
2674 Insert_Action (N,
2675 Make_Predicate_Check
2676 (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
2677 end if;
2678 end if;
2679 end if;
2680 end Apply_Predicate_Check;
2681
2682 -----------------------
2683 -- Apply_Range_Check --
2684 -----------------------
2685
2686 procedure Apply_Range_Check
2687 (Ck_Node : Node_Id;
2688 Target_Typ : Entity_Id;
2689 Source_Typ : Entity_Id := Empty)
2690 is
2691 begin
2692 Apply_Selected_Range_Checks
2693 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
2694 end Apply_Range_Check;
2695
2696 ------------------------------
2697 -- Apply_Scalar_Range_Check --
2698 ------------------------------
2699
2700 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2701 -- off if it is already set on.
2702
2703 procedure Apply_Scalar_Range_Check
2704 (Expr : Node_Id;
2705 Target_Typ : Entity_Id;
2706 Source_Typ : Entity_Id := Empty;
2707 Fixed_Int : Boolean := False)
2708 is
2709 Parnt : constant Node_Id := Parent (Expr);
2710 S_Typ : Entity_Id;
2711 Arr : Node_Id := Empty; -- initialize to prevent warning
2712 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
2713 OK : Boolean;
2714
2715 Is_Subscr_Ref : Boolean;
2716 -- Set true if Expr is a subscript
2717
2718 Is_Unconstrained_Subscr_Ref : Boolean;
2719 -- Set true if Expr is a subscript of an unconstrained array. In this
2720 -- case we do not attempt to do an analysis of the value against the
2721 -- range of the subscript, since we don't know the actual subtype.
2722
2723 Int_Real : Boolean;
2724 -- Set to True if Expr should be regarded as a real value even though
2725 -- the type of Expr might be discrete.
2726
2727 procedure Bad_Value (Warn : Boolean := False);
2728 -- Procedure called if value is determined to be out of range. Warn is
2729 -- True to force a warning instead of an error, even when SPARK_Mode is
2730 -- On.
2731
2732 ---------------
2733 -- Bad_Value --
2734 ---------------
2735
2736 procedure Bad_Value (Warn : Boolean := False) is
2737 begin
2738 Apply_Compile_Time_Constraint_Error
2739 (Expr, "value not in range of}??", CE_Range_Check_Failed,
2740 Ent => Target_Typ,
2741 Typ => Target_Typ,
2742 Warn => Warn);
2743 end Bad_Value;
2744
2745 -- Start of processing for Apply_Scalar_Range_Check
2746
2747 begin
2748 -- Return if check obviously not needed
2749
2750 if
2751 -- Not needed inside generic
2752
2753 Inside_A_Generic
2754
2755 -- Not needed if previous error
2756
2757 or else Target_Typ = Any_Type
2758 or else Nkind (Expr) = N_Error
2759
2760 -- Not needed for non-scalar type
2761
2762 or else not Is_Scalar_Type (Target_Typ)
2763
2764 -- Not needed if we know node raises CE already
2765
2766 or else Raises_Constraint_Error (Expr)
2767 then
2768 return;
2769 end if;
2770
2771 -- Now, see if checks are suppressed
2772
2773 Is_Subscr_Ref :=
2774 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
2775
2776 if Is_Subscr_Ref then
2777 Arr := Prefix (Parnt);
2778 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
2779
2780 if Is_Access_Type (Arr_Typ) then
2781 Arr_Typ := Designated_Type (Arr_Typ);
2782 end if;
2783 end if;
2784
2785 if not Do_Range_Check (Expr) then
2786
2787 -- Subscript reference. Check for Index_Checks suppressed
2788
2789 if Is_Subscr_Ref then
2790
2791 -- Check array type and its base type
2792
2793 if Index_Checks_Suppressed (Arr_Typ)
2794 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
2795 then
2796 return;
2797
2798 -- Check array itself if it is an entity name
2799
2800 elsif Is_Entity_Name (Arr)
2801 and then Index_Checks_Suppressed (Entity (Arr))
2802 then
2803 return;
2804
2805 -- Check expression itself if it is an entity name
2806
2807 elsif Is_Entity_Name (Expr)
2808 and then Index_Checks_Suppressed (Entity (Expr))
2809 then
2810 return;
2811 end if;
2812
2813 -- All other cases, check for Range_Checks suppressed
2814
2815 else
2816 -- Check target type and its base type
2817
2818 if Range_Checks_Suppressed (Target_Typ)
2819 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
2820 then
2821 return;
2822
2823 -- Check expression itself if it is an entity name
2824
2825 elsif Is_Entity_Name (Expr)
2826 and then Range_Checks_Suppressed (Entity (Expr))
2827 then
2828 return;
2829
2830 -- If Expr is part of an assignment statement, then check left
2831 -- side of assignment if it is an entity name.
2832
2833 elsif Nkind (Parnt) = N_Assignment_Statement
2834 and then Is_Entity_Name (Name (Parnt))
2835 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
2836 then
2837 return;
2838 end if;
2839 end if;
2840 end if;
2841
2842 -- Do not set range checks if they are killed
2843
2844 if Nkind (Expr) = N_Unchecked_Type_Conversion
2845 and then Kill_Range_Check (Expr)
2846 then
2847 return;
2848 end if;
2849
2850 -- Do not set range checks for any values from System.Scalar_Values
2851 -- since the whole idea of such values is to avoid checking them.
2852
2853 if Is_Entity_Name (Expr)
2854 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
2855 then
2856 return;
2857 end if;
2858
2859 -- Now see if we need a check
2860
2861 if No (Source_Typ) then
2862 S_Typ := Etype (Expr);
2863 else
2864 S_Typ := Source_Typ;
2865 end if;
2866
2867 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
2868 return;
2869 end if;
2870
2871 Is_Unconstrained_Subscr_Ref :=
2872 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
2873
2874 -- Special checks for floating-point type
2875
2876 if Is_Floating_Point_Type (S_Typ) then
2877
2878 -- Always do a range check if the source type includes infinities and
2879 -- the target type does not include infinities. We do not do this if
2880 -- range checks are killed.
2881 -- If the expression is a literal and the bounds of the type are
2882 -- static constants it may be possible to optimize the check.
2883
2884 if Has_Infinities (S_Typ)
2885 and then not Has_Infinities (Target_Typ)
2886 then
2887 -- If the expression is a literal and the bounds of the type are
2888 -- static constants it may be possible to optimize the check.
2889
2890 if Nkind (Expr) = N_Real_Literal then
2891 declare
2892 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
2893 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
2894
2895 begin
2896 if Compile_Time_Known_Value (Tlo)
2897 and then Compile_Time_Known_Value (Thi)
2898 and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo)
2899 and then Expr_Value_R (Expr) <= Expr_Value_R (Thi)
2900 then
2901 return;
2902 else
2903 Enable_Range_Check (Expr);
2904 end if;
2905 end;
2906
2907 else
2908 Enable_Range_Check (Expr);
2909 end if;
2910 end if;
2911 end if;
2912
2913 -- Return if we know expression is definitely in the range of the target
2914 -- type as determined by Determine_Range. Right now we only do this for
2915 -- discrete types, and not fixed-point or floating-point types.
2916
2917 -- The additional less-precise tests below catch these cases
2918
2919 -- Note: skip this if we are given a source_typ, since the point of
2920 -- supplying a Source_Typ is to stop us looking at the expression.
2921 -- We could sharpen this test to be out parameters only ???
2922
2923 if Is_Discrete_Type (Target_Typ)
2924 and then Is_Discrete_Type (Etype (Expr))
2925 and then not Is_Unconstrained_Subscr_Ref
2926 and then No (Source_Typ)
2927 then
2928 declare
2929 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
2930 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
2931 Lo : Uint;
2932 Hi : Uint;
2933
2934 begin
2935 if Compile_Time_Known_Value (Tlo)
2936 and then Compile_Time_Known_Value (Thi)
2937 then
2938 declare
2939 Lov : constant Uint := Expr_Value (Tlo);
2940 Hiv : constant Uint := Expr_Value (Thi);
2941
2942 begin
2943 -- If range is null, we for sure have a constraint error
2944 -- (we don't even need to look at the value involved,
2945 -- since all possible values will raise CE).
2946
2947 if Lov > Hiv then
2948
2949 -- When SPARK_Mode is On, force a warning instead of
2950 -- an error in that case, as this likely corresponds
2951 -- to deactivated code.
2952
2953 Bad_Value (Warn => SPARK_Mode = On);
2954
2955 -- In GNATprove mode, we enable the range check so that
2956 -- GNATprove will issue a message if it cannot be proved.
2957
2958 if GNATprove_Mode then
2959 Enable_Range_Check (Expr);
2960 end if;
2961
2962 return;
2963 end if;
2964
2965 -- Otherwise determine range of value
2966
2967 Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True);
2968
2969 if OK then
2970
2971 -- If definitely in range, all OK
2972
2973 if Lo >= Lov and then Hi <= Hiv then
2974 return;
2975
2976 -- If definitely not in range, warn
2977
2978 elsif Lov > Hi or else Hiv < Lo then
2979 Bad_Value;
2980 return;
2981
2982 -- Otherwise we don't know
2983
2984 else
2985 null;
2986 end if;
2987 end if;
2988 end;
2989 end if;
2990 end;
2991 end if;
2992
2993 Int_Real :=
2994 Is_Floating_Point_Type (S_Typ)
2995 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
2996
2997 -- Check if we can determine at compile time whether Expr is in the
2998 -- range of the target type. Note that if S_Typ is within the bounds
2999 -- of Target_Typ then this must be the case. This check is meaningful
3000 -- only if this is not a conversion between integer and real types.
3001
3002 if not Is_Unconstrained_Subscr_Ref
3003 and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
3004 and then
3005 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
3006
3007 -- Also check if the expression itself is in the range of the
3008 -- target type if it is a known at compile time value. We skip
3009 -- this test if S_Typ is set since for OUT and IN OUT parameters
3010 -- the Expr itself is not relevant to the checking.
3011
3012 or else
3013 (No (Source_Typ)
3014 and then Is_In_Range (Expr, Target_Typ,
3015 Assume_Valid => True,
3016 Fixed_Int => Fixed_Int,
3017 Int_Real => Int_Real)))
3018 then
3019 return;
3020
3021 elsif Is_Out_Of_Range (Expr, Target_Typ,
3022 Assume_Valid => True,
3023 Fixed_Int => Fixed_Int,
3024 Int_Real => Int_Real)
3025 then
3026 Bad_Value;
3027 return;
3028
3029 -- Floating-point case
3030 -- In the floating-point case, we only do range checks if the type is
3031 -- constrained. We definitely do NOT want range checks for unconstrained
3032 -- types, since we want to have infinities, except when
3033 -- Check_Float_Overflow is set.
3034
3035 elsif Is_Floating_Point_Type (S_Typ) then
3036 if Is_Constrained (S_Typ) or else Check_Float_Overflow then
3037 Enable_Range_Check (Expr);
3038 end if;
3039
3040 -- For all other cases we enable a range check unconditionally
3041
3042 else
3043 Enable_Range_Check (Expr);
3044 return;
3045 end if;
3046 end Apply_Scalar_Range_Check;
3047
3048 ----------------------------------
3049 -- Apply_Selected_Length_Checks --
3050 ----------------------------------
3051
3052 procedure Apply_Selected_Length_Checks
3053 (Ck_Node : Node_Id;
3054 Target_Typ : Entity_Id;
3055 Source_Typ : Entity_Id;
3056 Do_Static : Boolean)
3057 is
3058 Cond : Node_Id;
3059 R_Result : Check_Result;
3060 R_Cno : Node_Id;
3061
3062 Loc : constant Source_Ptr := Sloc (Ck_Node);
3063 Checks_On : constant Boolean :=
3064 (not Index_Checks_Suppressed (Target_Typ))
3065 or else (not Length_Checks_Suppressed (Target_Typ));
3066
3067 begin
3068 -- Note: this means that we lose some useful warnings if the expander
3069 -- is not active, and we also lose these warnings in SPARK mode ???
3070
3071 if not Expander_Active then
3072 return;
3073 end if;
3074
3075 R_Result :=
3076 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3077
3078 for J in 1 .. 2 loop
3079 R_Cno := R_Result (J);
3080 exit when No (R_Cno);
3081
3082 -- A length check may mention an Itype which is attached to a
3083 -- subsequent node. At the top level in a package this can cause
3084 -- an order-of-elaboration problem, so we make sure that the itype
3085 -- is referenced now.
3086
3087 if Ekind (Current_Scope) = E_Package
3088 and then Is_Compilation_Unit (Current_Scope)
3089 then
3090 Ensure_Defined (Target_Typ, Ck_Node);
3091
3092 if Present (Source_Typ) then
3093 Ensure_Defined (Source_Typ, Ck_Node);
3094
3095 elsif Is_Itype (Etype (Ck_Node)) then
3096 Ensure_Defined (Etype (Ck_Node), Ck_Node);
3097 end if;
3098 end if;
3099
3100 -- If the item is a conditional raise of constraint error, then have
3101 -- a look at what check is being performed and ???
3102
3103 if Nkind (R_Cno) = N_Raise_Constraint_Error
3104 and then Present (Condition (R_Cno))
3105 then
3106 Cond := Condition (R_Cno);
3107
3108 -- Case where node does not now have a dynamic check
3109
3110 if not Has_Dynamic_Length_Check (Ck_Node) then
3111
3112 -- If checks are on, just insert the check
3113
3114 if Checks_On then
3115 Insert_Action (Ck_Node, R_Cno);
3116
3117 if not Do_Static then
3118 Set_Has_Dynamic_Length_Check (Ck_Node);
3119 end if;
3120
3121 -- If checks are off, then analyze the length check after
3122 -- temporarily attaching it to the tree in case the relevant
3123 -- condition can be evaluated at compile time. We still want a
3124 -- compile time warning in this case.
3125
3126 else
3127 Set_Parent (R_Cno, Ck_Node);
3128 Analyze (R_Cno);
3129 end if;
3130 end if;
3131
3132 -- Output a warning if the condition is known to be True
3133
3134 if Is_Entity_Name (Cond)
3135 and then Entity (Cond) = Standard_True
3136 then
3137 Apply_Compile_Time_Constraint_Error
3138 (Ck_Node, "wrong length for array of}??",
3139 CE_Length_Check_Failed,
3140 Ent => Target_Typ,
3141 Typ => Target_Typ);
3142
3143 -- If we were only doing a static check, or if checks are not
3144 -- on, then we want to delete the check, since it is not needed.
3145 -- We do this by replacing the if statement by a null statement
3146
3147 elsif Do_Static or else not Checks_On then
3148 Remove_Warning_Messages (R_Cno);
3149 Rewrite (R_Cno, Make_Null_Statement (Loc));
3150 end if;
3151
3152 else
3153 Install_Static_Check (R_Cno, Loc);
3154 end if;
3155 end loop;
3156 end Apply_Selected_Length_Checks;
3157
3158 ---------------------------------
3159 -- Apply_Selected_Range_Checks --
3160 ---------------------------------
3161
3162 procedure Apply_Selected_Range_Checks
3163 (Ck_Node : Node_Id;
3164 Target_Typ : Entity_Id;
3165 Source_Typ : Entity_Id;
3166 Do_Static : Boolean)
3167 is
3168 Loc : constant Source_Ptr := Sloc (Ck_Node);
3169 Checks_On : constant Boolean :=
3170 not Index_Checks_Suppressed (Target_Typ)
3171 or else
3172 not Range_Checks_Suppressed (Target_Typ);
3173
3174 Cond : Node_Id;
3175 R_Cno : Node_Id;
3176 R_Result : Check_Result;
3177
3178 begin
3179 if not Expander_Active or not Checks_On then
3180 return;
3181 end if;
3182
3183 R_Result :=
3184 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
3185
3186 for J in 1 .. 2 loop
3187 R_Cno := R_Result (J);
3188 exit when No (R_Cno);
3189
3190 -- The range check requires runtime evaluation. Depending on what its
3191 -- triggering condition is, the check may be converted into a compile
3192 -- time constraint check.
3193
3194 if Nkind (R_Cno) = N_Raise_Constraint_Error
3195 and then Present (Condition (R_Cno))
3196 then
3197 Cond := Condition (R_Cno);
3198
3199 -- Insert the range check before the related context. Note that
3200 -- this action analyses the triggering condition.
3201
3202 Insert_Action (Ck_Node, R_Cno);
3203
3204 -- This old code doesn't make sense, why is the context flagged as
3205 -- requiring dynamic range checks now in the middle of generating
3206 -- them ???
3207
3208 if not Do_Static then
3209 Set_Has_Dynamic_Range_Check (Ck_Node);
3210 end if;
3211
3212 -- The triggering condition evaluates to True, the range check
3213 -- can be converted into a compile time constraint check.
3214
3215 if Is_Entity_Name (Cond)
3216 and then Entity (Cond) = Standard_True
3217 then
3218 -- Since an N_Range is technically not an expression, we have
3219 -- to set one of the bounds to C_E and then just flag the
3220 -- N_Range. The warning message will point to the lower bound
3221 -- and complain about a range, which seems OK.
3222
3223 if Nkind (Ck_Node) = N_Range then
3224 Apply_Compile_Time_Constraint_Error
3225 (Low_Bound (Ck_Node),
3226 "static range out of bounds of}??",
3227 CE_Range_Check_Failed,
3228 Ent => Target_Typ,
3229 Typ => Target_Typ);
3230
3231 Set_Raises_Constraint_Error (Ck_Node);
3232
3233 else
3234 Apply_Compile_Time_Constraint_Error
3235 (Ck_Node,
3236 "static value out of range of}??",
3237 CE_Range_Check_Failed,
3238 Ent => Target_Typ,
3239 Typ => Target_Typ);
3240 end if;
3241
3242 -- If we were only doing a static check, or if checks are not
3243 -- on, then we want to delete the check, since it is not needed.
3244 -- We do this by replacing the if statement by a null statement
3245
3246 elsif Do_Static then
3247 Remove_Warning_Messages (R_Cno);
3248 Rewrite (R_Cno, Make_Null_Statement (Loc));
3249 end if;
3250
3251 -- The range check raises Constraint_Error explicitly
3252
3253 else
3254 Install_Static_Check (R_Cno, Loc);
3255 end if;
3256 end loop;
3257 end Apply_Selected_Range_Checks;
3258
3259 -------------------------------
3260 -- Apply_Static_Length_Check --
3261 -------------------------------
3262
3263 procedure Apply_Static_Length_Check
3264 (Expr : Node_Id;
3265 Target_Typ : Entity_Id;
3266 Source_Typ : Entity_Id := Empty)
3267 is
3268 begin
3269 Apply_Selected_Length_Checks
3270 (Expr, Target_Typ, Source_Typ, Do_Static => True);
3271 end Apply_Static_Length_Check;
3272
3273 -------------------------------------
3274 -- Apply_Subscript_Validity_Checks --
3275 -------------------------------------
3276
3277 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
3278 Sub : Node_Id;
3279
3280 begin
3281 pragma Assert (Nkind (Expr) = N_Indexed_Component);
3282
3283 -- Loop through subscripts
3284
3285 Sub := First (Expressions (Expr));
3286 while Present (Sub) loop
3287
3288 -- Check one subscript. Note that we do not worry about enumeration
3289 -- type with holes, since we will convert the value to a Pos value
3290 -- for the subscript, and that convert will do the necessary validity
3291 -- check.
3292
3293 Ensure_Valid (Sub, Holes_OK => True);
3294
3295 -- Move to next subscript
3296
3297 Sub := Next (Sub);
3298 end loop;
3299 end Apply_Subscript_Validity_Checks;
3300
3301 ----------------------------------
3302 -- Apply_Type_Conversion_Checks --
3303 ----------------------------------
3304
3305 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
3306 Target_Type : constant Entity_Id := Etype (N);
3307 Target_Base : constant Entity_Id := Base_Type (Target_Type);
3308 Expr : constant Node_Id := Expression (N);
3309
3310 Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
3311 -- Note: if Etype (Expr) is a private type without discriminants, its
3312 -- full view might have discriminants with defaults, so we need the
3313 -- full view here to retrieve the constraints.
3314
3315 begin
3316 if Inside_A_Generic then
3317 return;
3318
3319 -- Skip these checks if serious errors detected, there are some nasty
3320 -- situations of incomplete trees that blow things up.
3321
3322 elsif Serious_Errors_Detected > 0 then
3323 return;
3324
3325 -- Never generate discriminant checks for Unchecked_Union types
3326
3327 elsif Present (Expr_Type)
3328 and then Is_Unchecked_Union (Expr_Type)
3329 then
3330 return;
3331
3332 -- Scalar type conversions of the form Target_Type (Expr) require a
3333 -- range check if we cannot be sure that Expr is in the base type of
3334 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3335 -- are not quite the same condition from an implementation point of
3336 -- view, but clearly the second includes the first.
3337
3338 elsif Is_Scalar_Type (Target_Type) then
3339 declare
3340 Conv_OK : constant Boolean := Conversion_OK (N);
3341 -- If the Conversion_OK flag on the type conversion is set and no
3342 -- floating-point type is involved in the type conversion then
3343 -- fixed-point values must be read as integral values.
3344
3345 Float_To_Int : constant Boolean :=
3346 Is_Floating_Point_Type (Expr_Type)
3347 and then Is_Integer_Type (Target_Type);
3348
3349 begin
3350 if not Overflow_Checks_Suppressed (Target_Base)
3351 and then not Overflow_Checks_Suppressed (Target_Type)
3352 and then not
3353 In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
3354 and then not Float_To_Int
3355 then
3356 Activate_Overflow_Check (N);
3357 end if;
3358
3359 if not Range_Checks_Suppressed (Target_Type)
3360 and then not Range_Checks_Suppressed (Expr_Type)
3361 then
3362 if Float_To_Int then
3363 Apply_Float_Conversion_Check (Expr, Target_Type);
3364 else
3365 Apply_Scalar_Range_Check
3366 (Expr, Target_Type, Fixed_Int => Conv_OK);
3367
3368 -- If the target type has predicates, we need to indicate
3369 -- the need for a check, even if Determine_Range finds that
3370 -- the value is within bounds. This may be the case e.g for
3371 -- a division with a constant denominator.
3372
3373 if Has_Predicates (Target_Type) then
3374 Enable_Range_Check (Expr);
3375 end if;
3376 end if;
3377 end if;
3378 end;
3379
3380 elsif Comes_From_Source (N)
3381 and then not Discriminant_Checks_Suppressed (Target_Type)
3382 and then Is_Record_Type (Target_Type)
3383 and then Is_Derived_Type (Target_Type)
3384 and then not Is_Tagged_Type (Target_Type)
3385 and then not Is_Constrained (Target_Type)
3386 and then Present (Stored_Constraint (Target_Type))
3387 then
3388 -- An unconstrained derived type may have inherited discriminant.
3389 -- Build an actual discriminant constraint list using the stored
3390 -- constraint, to verify that the expression of the parent type
3391 -- satisfies the constraints imposed by the (unconstrained) derived
3392 -- type. This applies to value conversions, not to view conversions
3393 -- of tagged types.
3394
3395 declare
3396 Loc : constant Source_Ptr := Sloc (N);
3397 Cond : Node_Id;
3398 Constraint : Elmt_Id;
3399 Discr_Value : Node_Id;
3400 Discr : Entity_Id;
3401
3402 New_Constraints : constant Elist_Id := New_Elmt_List;
3403 Old_Constraints : constant Elist_Id :=
3404 Discriminant_Constraint (Expr_Type);
3405
3406 begin
3407 Constraint := First_Elmt (Stored_Constraint (Target_Type));
3408 while Present (Constraint) loop
3409 Discr_Value := Node (Constraint);
3410
3411 if Is_Entity_Name (Discr_Value)
3412 and then Ekind (Entity (Discr_Value)) = E_Discriminant
3413 then
3414 Discr := Corresponding_Discriminant (Entity (Discr_Value));
3415
3416 if Present (Discr)
3417 and then Scope (Discr) = Base_Type (Expr_Type)
3418 then
3419 -- Parent is constrained by new discriminant. Obtain
3420 -- Value of original discriminant in expression. If the
3421 -- new discriminant has been used to constrain more than
3422 -- one of the stored discriminants, this will provide the
3423 -- required consistency check.
3424
3425 Append_Elmt
3426 (Make_Selected_Component (Loc,
3427 Prefix =>
3428 Duplicate_Subexpr_No_Checks
3429 (Expr, Name_Req => True),
3430 Selector_Name =>
3431 Make_Identifier (Loc, Chars (Discr))),
3432 New_Constraints);
3433
3434 else
3435 -- Discriminant of more remote ancestor ???
3436
3437 return;
3438 end if;
3439
3440 -- Derived type definition has an explicit value for this
3441 -- stored discriminant.
3442
3443 else
3444 Append_Elmt
3445 (Duplicate_Subexpr_No_Checks (Discr_Value),
3446 New_Constraints);
3447 end if;
3448
3449 Next_Elmt (Constraint);
3450 end loop;
3451
3452 -- Use the unconstrained expression type to retrieve the
3453 -- discriminants of the parent, and apply momentarily the
3454 -- discriminant constraint synthesized above.
3455
3456 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
3457 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
3458 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
3459
3460 Insert_Action (N,
3461 Make_Raise_Constraint_Error (Loc,
3462 Condition => Cond,
3463 Reason => CE_Discriminant_Check_Failed));
3464 end;
3465
3466 -- For arrays, checks are set now, but conversions are applied during
3467 -- expansion, to take into accounts changes of representation. The
3468 -- checks become range checks on the base type or length checks on the
3469 -- subtype, depending on whether the target type is unconstrained or
3470 -- constrained. Note that the range check is put on the expression of a
3471 -- type conversion, while the length check is put on the type conversion
3472 -- itself.
3473
3474 elsif Is_Array_Type (Target_Type) then
3475 if Is_Constrained (Target_Type) then
3476 Set_Do_Length_Check (N);
3477 else
3478 Set_Do_Range_Check (Expr);
3479 end if;
3480 end if;
3481 end Apply_Type_Conversion_Checks;
3482
3483 ----------------------------------------------
3484 -- Apply_Universal_Integer_Attribute_Checks --
3485 ----------------------------------------------
3486
3487 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
3488 Loc : constant Source_Ptr := Sloc (N);
3489 Typ : constant Entity_Id := Etype (N);
3490
3491 begin
3492 if Inside_A_Generic then
3493 return;
3494
3495 -- Nothing to do if checks are suppressed
3496
3497 elsif Range_Checks_Suppressed (Typ)
3498 and then Overflow_Checks_Suppressed (Typ)
3499 then
3500 return;
3501
3502 -- Nothing to do if the attribute does not come from source. The
3503 -- internal attributes we generate of this type do not need checks,
3504 -- and furthermore the attempt to check them causes some circular
3505 -- elaboration orders when dealing with packed types.
3506
3507 elsif not Comes_From_Source (N) then
3508 return;
3509
3510 -- If the prefix is a selected component that depends on a discriminant
3511 -- the check may improperly expose a discriminant instead of using
3512 -- the bounds of the object itself. Set the type of the attribute to
3513 -- the base type of the context, so that a check will be imposed when
3514 -- needed (e.g. if the node appears as an index).
3515
3516 elsif Nkind (Prefix (N)) = N_Selected_Component
3517 and then Ekind (Typ) = E_Signed_Integer_Subtype
3518 and then Depends_On_Discriminant (Scalar_Range (Typ))
3519 then
3520 Set_Etype (N, Base_Type (Typ));
3521
3522 -- Otherwise, replace the attribute node with a type conversion node
3523 -- whose expression is the attribute, retyped to universal integer, and
3524 -- whose subtype mark is the target type. The call to analyze this
3525 -- conversion will set range and overflow checks as required for proper
3526 -- detection of an out of range value.
3527
3528 else
3529 Set_Etype (N, Universal_Integer);
3530 Set_Analyzed (N, True);
3531
3532 Rewrite (N,
3533 Make_Type_Conversion (Loc,
3534 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
3535 Expression => Relocate_Node (N)));
3536
3537 Analyze_And_Resolve (N, Typ);
3538 return;
3539 end if;
3540 end Apply_Universal_Integer_Attribute_Checks;
3541
3542 -------------------------------------
3543 -- Atomic_Synchronization_Disabled --
3544 -------------------------------------
3545
3546 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3547 -- using a bogus check called Atomic_Synchronization. This is to make it
3548 -- more convenient to get exactly the same semantics as [Un]Suppress.
3549
3550 function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
3551 begin
3552 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3553 -- looks enabled, since it is never disabled.
3554
3555 if Debug_Flag_Dot_E then
3556 return False;
3557
3558 -- If debug flag d.d is set then always return True, i.e. all atomic
3559 -- sync looks disabled, since it always tests True.
3560
3561 elsif Debug_Flag_Dot_D then
3562 return True;
3563
3564 -- If entity present, then check result for that entity
3565
3566 elsif Present (E) and then Checks_May_Be_Suppressed (E) then
3567 return Is_Check_Suppressed (E, Atomic_Synchronization);
3568
3569 -- Otherwise result depends on current scope setting
3570
3571 else
3572 return Scope_Suppress.Suppress (Atomic_Synchronization);
3573 end if;
3574 end Atomic_Synchronization_Disabled;
3575
3576 -------------------------------
3577 -- Build_Discriminant_Checks --
3578 -------------------------------
3579
3580 function Build_Discriminant_Checks
3581 (N : Node_Id;
3582 T_Typ : Entity_Id) return Node_Id
3583 is
3584 Loc : constant Source_Ptr := Sloc (N);
3585 Cond : Node_Id;
3586 Disc : Elmt_Id;
3587 Disc_Ent : Entity_Id;
3588 Dref : Node_Id;
3589 Dval : Node_Id;
3590
3591 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
3592
3593 ----------------------------------
3594 -- Aggregate_Discriminant_Value --
3595 ----------------------------------
3596
3597 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
3598 Assoc : Node_Id;
3599
3600 begin
3601 -- The aggregate has been normalized with named associations. We use
3602 -- the Chars field to locate the discriminant to take into account
3603 -- discriminants in derived types, which carry the same name as those
3604 -- in the parent.
3605
3606 Assoc := First (Component_Associations (N));
3607 while Present (Assoc) loop
3608 if Chars (First (Choices (Assoc))) = Chars (Disc) then
3609 return Expression (Assoc);
3610 else
3611 Next (Assoc);
3612 end if;
3613 end loop;
3614
3615 -- Discriminant must have been found in the loop above
3616
3617 raise Program_Error;
3618 end Aggregate_Discriminant_Val;
3619
3620 -- Start of processing for Build_Discriminant_Checks
3621
3622 begin
3623 -- Loop through discriminants evolving the condition
3624
3625 Cond := Empty;
3626 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
3627
3628 -- For a fully private type, use the discriminants of the parent type
3629
3630 if Is_Private_Type (T_Typ)
3631 and then No (Full_View (T_Typ))
3632 then
3633 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
3634 else
3635 Disc_Ent := First_Discriminant (T_Typ);
3636 end if;
3637
3638 while Present (Disc) loop
3639 Dval := Node (Disc);
3640
3641 if Nkind (Dval) = N_Identifier
3642 and then Ekind (Entity (Dval)) = E_Discriminant
3643 then
3644 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
3645 else
3646 Dval := Duplicate_Subexpr_No_Checks (Dval);
3647 end if;
3648
3649 -- If we have an Unchecked_Union node, we can infer the discriminants
3650 -- of the node.
3651
3652 if Is_Unchecked_Union (Base_Type (T_Typ)) then
3653 Dref := New_Copy (
3654 Get_Discriminant_Value (
3655 First_Discriminant (T_Typ),
3656 T_Typ,
3657 Stored_Constraint (T_Typ)));
3658
3659 elsif Nkind (N) = N_Aggregate then
3660 Dref :=
3661 Duplicate_Subexpr_No_Checks
3662 (Aggregate_Discriminant_Val (Disc_Ent));
3663
3664 else
3665 Dref :=
3666 Make_Selected_Component (Loc,
3667 Prefix =>
3668 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
3669 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
3670
3671 Set_Is_In_Discriminant_Check (Dref);
3672 end if;
3673
3674 Evolve_Or_Else (Cond,
3675 Make_Op_Ne (Loc,
3676 Left_Opnd => Dref,
3677 Right_Opnd => Dval));
3678
3679 Next_Elmt (Disc);
3680 Next_Discriminant (Disc_Ent);
3681 end loop;
3682
3683 return Cond;
3684 end Build_Discriminant_Checks;
3685
3686 ------------------
3687 -- Check_Needed --
3688 ------------------
3689
3690 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
3691 N : Node_Id;
3692 P : Node_Id;
3693 K : Node_Kind;
3694 L : Node_Id;
3695 R : Node_Id;
3696
3697 function Left_Expression (Op : Node_Id) return Node_Id;
3698 -- Return the relevant expression from the left operand of the given
3699 -- short circuit form: this is LO itself, except if LO is a qualified
3700 -- expression, a type conversion, or an expression with actions, in
3701 -- which case this is Left_Expression (Expression (LO)).
3702
3703 ---------------------
3704 -- Left_Expression --
3705 ---------------------
3706
3707 function Left_Expression (Op : Node_Id) return Node_Id is
3708 LE : Node_Id := Left_Opnd (Op);
3709 begin
3710 while Nkind_In (LE, N_Qualified_Expression,
3711 N_Type_Conversion,
3712 N_Expression_With_Actions)
3713 loop
3714 LE := Expression (LE);
3715 end loop;
3716
3717 return LE;
3718 end Left_Expression;
3719
3720 -- Start of processing for Check_Needed
3721
3722 begin
3723 -- Always check if not simple entity
3724
3725 if Nkind (Nod) not in N_Has_Entity
3726 or else not Comes_From_Source (Nod)
3727 then
3728 return True;
3729 end if;
3730
3731 -- Look up tree for short circuit
3732
3733 N := Nod;
3734 loop
3735 P := Parent (N);
3736 K := Nkind (P);
3737
3738 -- Done if out of subexpression (note that we allow generated stuff
3739 -- such as itype declarations in this context, to keep the loop going
3740 -- since we may well have generated such stuff in complex situations.
3741 -- Also done if no parent (probably an error condition, but no point
3742 -- in behaving nasty if we find it).
3743
3744 if No (P)
3745 or else (K not in N_Subexpr and then Comes_From_Source (P))
3746 then
3747 return True;
3748
3749 -- Or/Or Else case, where test is part of the right operand, or is
3750 -- part of one of the actions associated with the right operand, and
3751 -- the left operand is an equality test.
3752
3753 elsif K = N_Op_Or then
3754 exit when N = Right_Opnd (P)
3755 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3756
3757 elsif K = N_Or_Else then
3758 exit when (N = Right_Opnd (P)
3759 or else
3760 (Is_List_Member (N)
3761 and then List_Containing (N) = Actions (P)))
3762 and then Nkind (Left_Expression (P)) = N_Op_Eq;
3763
3764 -- Similar test for the And/And then case, where the left operand
3765 -- is an inequality test.
3766
3767 elsif K = N_Op_And then
3768 exit when N = Right_Opnd (P)
3769 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3770
3771 elsif K = N_And_Then then
3772 exit when (N = Right_Opnd (P)
3773 or else
3774 (Is_List_Member (N)
3775 and then List_Containing (N) = Actions (P)))
3776 and then Nkind (Left_Expression (P)) = N_Op_Ne;
3777 end if;
3778
3779 N := P;
3780 end loop;
3781
3782 -- If we fall through the loop, then we have a conditional with an
3783 -- appropriate test as its left operand, so look further.
3784
3785 L := Left_Expression (P);
3786
3787 -- L is an "=" or "/=" operator: extract its operands
3788
3789 R := Right_Opnd (L);
3790 L := Left_Opnd (L);
3791
3792 -- Left operand of test must match original variable
3793
3794 if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
3795 return True;
3796 end if;
3797
3798 -- Right operand of test must be key value (zero or null)
3799
3800 case Check is
3801 when Access_Check =>
3802 if not Known_Null (R) then
3803 return True;
3804 end if;
3805
3806 when Division_Check =>
3807 if not Compile_Time_Known_Value (R)
3808 or else Expr_Value (R) /= Uint_0
3809 then
3810 return True;
3811 end if;
3812
3813 when others =>
3814 raise Program_Error;
3815 end case;
3816
3817 -- Here we have the optimizable case, warn if not short-circuited
3818
3819 if K = N_Op_And or else K = N_Op_Or then
3820 Error_Msg_Warn := SPARK_Mode /= On;
3821
3822 case Check is
3823 when Access_Check =>
3824 if GNATprove_Mode then
3825 Error_Msg_N
3826 ("Constraint_Error might have been raised (access check)",
3827 Parent (Nod));
3828 else
3829 Error_Msg_N
3830 ("Constraint_Error may be raised (access check)??",
3831 Parent (Nod));
3832 end if;
3833
3834 when Division_Check =>
3835 if GNATprove_Mode then
3836 Error_Msg_N
3837 ("Constraint_Error might have been raised (zero divide)",
3838 Parent (Nod));
3839 else
3840 Error_Msg_N
3841 ("Constraint_Error may be raised (zero divide)??",
3842 Parent (Nod));
3843 end if;
3844
3845 when others =>
3846 raise Program_Error;
3847 end case;
3848
3849 if K = N_Op_And then
3850 Error_Msg_N -- CODEFIX
3851 ("use `AND THEN` instead of AND??", P);
3852 else
3853 Error_Msg_N -- CODEFIX
3854 ("use `OR ELSE` instead of OR??", P);
3855 end if;
3856
3857 -- If not short-circuited, we need the check
3858
3859 return True;
3860
3861 -- If short-circuited, we can omit the check
3862
3863 else
3864 return False;
3865 end if;
3866 end Check_Needed;
3867
3868 -----------------------------------
3869 -- Check_Valid_Lvalue_Subscripts --
3870 -----------------------------------
3871
3872 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
3873 begin
3874 -- Skip this if range checks are suppressed
3875
3876 if Range_Checks_Suppressed (Etype (Expr)) then
3877 return;
3878
3879 -- Only do this check for expressions that come from source. We assume
3880 -- that expander generated assignments explicitly include any necessary
3881 -- checks. Note that this is not just an optimization, it avoids
3882 -- infinite recursions.
3883
3884 elsif not Comes_From_Source (Expr) then
3885 return;
3886
3887 -- For a selected component, check the prefix
3888
3889 elsif Nkind (Expr) = N_Selected_Component then
3890 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3891 return;
3892
3893 -- Case of indexed component
3894
3895 elsif Nkind (Expr) = N_Indexed_Component then
3896 Apply_Subscript_Validity_Checks (Expr);
3897
3898 -- Prefix may itself be or contain an indexed component, and these
3899 -- subscripts need checking as well.
3900
3901 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
3902 end if;
3903 end Check_Valid_Lvalue_Subscripts;
3904
3905 ----------------------------------
3906 -- Null_Exclusion_Static_Checks --
3907 ----------------------------------
3908
3909 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
3910 Error_Node : Node_Id;
3911 Expr : Node_Id;
3912 Has_Null : constant Boolean := Has_Null_Exclusion (N);
3913 K : constant Node_Kind := Nkind (N);
3914 Typ : Entity_Id;
3915
3916 begin
3917 pragma Assert
3918 (Nkind_In (K, N_Component_Declaration,
3919 N_Discriminant_Specification,
3920 N_Function_Specification,
3921 N_Object_Declaration,
3922 N_Parameter_Specification));
3923
3924 if K = N_Function_Specification then
3925 Typ := Etype (Defining_Entity (N));
3926 else
3927 Typ := Etype (Defining_Identifier (N));
3928 end if;
3929
3930 case K is
3931 when N_Component_Declaration =>
3932 if Present (Access_Definition (Component_Definition (N))) then
3933 Error_Node := Component_Definition (N);
3934 else
3935 Error_Node := Subtype_Indication (Component_Definition (N));
3936 end if;
3937
3938 when N_Discriminant_Specification =>
3939 Error_Node := Discriminant_Type (N);
3940
3941 when N_Function_Specification =>
3942 Error_Node := Result_Definition (N);
3943
3944 when N_Object_Declaration =>
3945 Error_Node := Object_Definition (N);
3946
3947 when N_Parameter_Specification =>
3948 Error_Node := Parameter_Type (N);
3949
3950 when others =>
3951 raise Program_Error;
3952 end case;
3953
3954 if Has_Null then
3955
3956 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3957 -- applied to an access [sub]type.
3958
3959 if not Is_Access_Type (Typ) then
3960 Error_Msg_N
3961 ("`NOT NULL` allowed only for an access type", Error_Node);
3962
3963 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3964 -- be applied to a [sub]type that does not exclude null already.
3965
3966 elsif Can_Never_Be_Null (Typ)
3967 and then Comes_From_Source (Typ)
3968 then
3969 Error_Msg_NE
3970 ("`NOT NULL` not allowed (& already excludes null)",
3971 Error_Node, Typ);
3972 end if;
3973 end if;
3974
3975 -- Check that null-excluding objects are always initialized, except for
3976 -- deferred constants, for which the expression will appear in the full
3977 -- declaration.
3978
3979 if K = N_Object_Declaration
3980 and then No (Expression (N))
3981 and then not Constant_Present (N)
3982 and then not No_Initialization (N)
3983 then
3984 -- Add an expression that assigns null. This node is needed by
3985 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3986 -- a Constraint_Error node.
3987
3988 Set_Expression (N, Make_Null (Sloc (N)));
3989 Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
3990
3991 Apply_Compile_Time_Constraint_Error
3992 (N => Expression (N),
3993 Msg =>
3994 "(Ada 2005) null-excluding objects must be initialized??",
3995 Reason => CE_Null_Not_Allowed);
3996 end if;
3997
3998 -- Check that a null-excluding component, formal or object is not being
3999 -- assigned a null value. Otherwise generate a warning message and
4000 -- replace Expression (N) by an N_Constraint_Error node.
4001
4002 if K /= N_Function_Specification then
4003 Expr := Expression (N);
4004
4005 if Present (Expr) and then Known_Null (Expr) then
4006 case K is
4007 when N_Component_Declaration |
4008 N_Discriminant_Specification =>
4009 Apply_Compile_Time_Constraint_Error
4010 (N => Expr,
4011 Msg => "(Ada 2005) null not allowed "
4012 & "in null-excluding components??",
4013 Reason => CE_Null_Not_Allowed);
4014
4015 when N_Object_Declaration =>
4016 Apply_Compile_Time_Constraint_Error
4017 (N => Expr,
4018 Msg => "(Ada 2005) null not allowed "
4019 & "in null-excluding objects??",
4020 Reason => CE_Null_Not_Allowed);
4021
4022 when N_Parameter_Specification =>
4023 Apply_Compile_Time_Constraint_Error
4024 (N => Expr,
4025 Msg => "(Ada 2005) null not allowed "
4026 & "in null-excluding formals??",
4027 Reason => CE_Null_Not_Allowed);
4028
4029 when others =>
4030 null;
4031 end case;
4032 end if;
4033 end if;
4034 end Null_Exclusion_Static_Checks;
4035
4036 ----------------------------------
4037 -- Conditional_Statements_Begin --
4038 ----------------------------------
4039
4040 procedure Conditional_Statements_Begin is
4041 begin
4042 Saved_Checks_TOS := Saved_Checks_TOS + 1;
4043
4044 -- If stack overflows, kill all checks, that way we know to simply reset
4045 -- the number of saved checks to zero on return. This should never occur
4046 -- in practice.
4047
4048 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4049 Kill_All_Checks;
4050
4051 -- In the normal case, we just make a new stack entry saving the current
4052 -- number of saved checks for a later restore.
4053
4054 else
4055 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
4056
4057 if Debug_Flag_CC then
4058 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
4059 Num_Saved_Checks);
4060 end if;
4061 end if;
4062 end Conditional_Statements_Begin;
4063
4064 --------------------------------
4065 -- Conditional_Statements_End --
4066 --------------------------------
4067
4068 procedure Conditional_Statements_End is
4069 begin
4070 pragma Assert (Saved_Checks_TOS > 0);
4071
4072 -- If the saved checks stack overflowed, then we killed all checks, so
4073 -- setting the number of saved checks back to zero is correct. This
4074 -- should never occur in practice.
4075
4076 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
4077 Num_Saved_Checks := 0;
4078
4079 -- In the normal case, restore the number of saved checks from the top
4080 -- stack entry.
4081
4082 else
4083 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
4084
4085 if Debug_Flag_CC then
4086 w ("Conditional_Statements_End: Num_Saved_Checks = ",
4087 Num_Saved_Checks);
4088 end if;
4089 end if;
4090
4091 Saved_Checks_TOS := Saved_Checks_TOS - 1;
4092 end Conditional_Statements_End;
4093
4094 -------------------------
4095 -- Convert_From_Bignum --
4096 -------------------------
4097
4098 function Convert_From_Bignum (N : Node_Id) return Node_Id is
4099 Loc : constant Source_Ptr := Sloc (N);
4100
4101 begin
4102 pragma Assert (Is_RTE (Etype (N), RE_Bignum));
4103
4104 -- Construct call From Bignum
4105
4106 return
4107 Make_Function_Call (Loc,
4108 Name =>
4109 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4110 Parameter_Associations => New_List (Relocate_Node (N)));
4111 end Convert_From_Bignum;
4112
4113 -----------------------
4114 -- Convert_To_Bignum --
4115 -----------------------
4116
4117 function Convert_To_Bignum (N : Node_Id) return Node_Id is
4118 Loc : constant Source_Ptr := Sloc (N);
4119
4120 begin
4121 -- Nothing to do if Bignum already except call Relocate_Node
4122
4123 if Is_RTE (Etype (N), RE_Bignum) then
4124 return Relocate_Node (N);
4125
4126 -- Otherwise construct call to To_Bignum, converting the operand to the
4127 -- required Long_Long_Integer form.
4128
4129 else
4130 pragma Assert (Is_Signed_Integer_Type (Etype (N)));
4131 return
4132 Make_Function_Call (Loc,
4133 Name =>
4134 New_Occurrence_Of (RTE (RE_To_Bignum), Loc),
4135 Parameter_Associations => New_List (
4136 Convert_To (Standard_Long_Long_Integer, Relocate_Node (N))));
4137 end if;
4138 end Convert_To_Bignum;
4139
4140 ---------------------
4141 -- Determine_Range --
4142 ---------------------
4143
4144 Cache_Size : constant := 2 ** 10;
4145 type Cache_Index is range 0 .. Cache_Size - 1;
4146 -- Determine size of below cache (power of 2 is more efficient)
4147
4148 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
4149 Determine_Range_Cache_V : array (Cache_Index) of Boolean;
4150 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
4151 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
4152 Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
4153 Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
4154 -- The above arrays are used to implement a small direct cache for
4155 -- Determine_Range and Determine_Range_R calls. Because of the way these
4156 -- subprograms recursively traces subexpressions, and because overflow
4157 -- checking calls the routine on the way up the tree, a quadratic behavior
4158 -- can otherwise be encountered in large expressions. The cache entry for
4159 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4160 -- by checking the actual node value stored there. The Range_Cache_V array
4161 -- records the setting of Assume_Valid for the cache entry.
4162
4163 procedure Determine_Range
4164 (N : Node_Id;
4165 OK : out Boolean;
4166 Lo : out Uint;
4167 Hi : out Uint;
4168 Assume_Valid : Boolean := False)
4169 is
4170 Typ : Entity_Id := Etype (N);
4171 -- Type to use, may get reset to base type for possibly invalid entity
4172
4173 Lo_Left : Uint;
4174 Hi_Left : Uint;
4175 -- Lo and Hi bounds of left operand
4176
4177 Lo_Right : Uint;
4178 Hi_Right : Uint;
4179 -- Lo and Hi bounds of right (or only) operand
4180
4181 Bound : Node_Id;
4182 -- Temp variable used to hold a bound node
4183
4184 Hbound : Uint;
4185 -- High bound of base type of expression
4186
4187 Lor : Uint;
4188 Hir : Uint;
4189 -- Refined values for low and high bounds, after tightening
4190
4191 OK1 : Boolean;
4192 -- Used in lower level calls to indicate if call succeeded
4193
4194 Cindex : Cache_Index;
4195 -- Used to search cache
4196
4197 Btyp : Entity_Id;
4198 -- Base type
4199
4200 function OK_Operands return Boolean;
4201 -- Used for binary operators. Determines the ranges of the left and
4202 -- right operands, and if they are both OK, returns True, and puts
4203 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4204
4205 -----------------
4206 -- OK_Operands --
4207 -----------------
4208
4209 function OK_Operands return Boolean is
4210 begin
4211 Determine_Range
4212 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4213
4214 if not OK1 then
4215 return False;
4216 end if;
4217
4218 Determine_Range
4219 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4220 return OK1;
4221 end OK_Operands;
4222
4223 -- Start of processing for Determine_Range
4224
4225 begin
4226 -- Prevent junk warnings by initializing range variables
4227
4228 Lo := No_Uint;
4229 Hi := No_Uint;
4230 Lor := No_Uint;
4231 Hir := No_Uint;
4232
4233 -- For temporary constants internally generated to remove side effects
4234 -- we must use the corresponding expression to determine the range of
4235 -- the expression. But note that the expander can also generate
4236 -- constants in other cases, including deferred constants.
4237
4238 if Is_Entity_Name (N)
4239 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4240 and then Ekind (Entity (N)) = E_Constant
4241 and then Is_Internal_Name (Chars (Entity (N)))
4242 then
4243 if Present (Expression (Parent (Entity (N)))) then
4244 Determine_Range
4245 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4246
4247 elsif Present (Full_View (Entity (N))) then
4248 Determine_Range
4249 (Expression (Parent (Full_View (Entity (N)))),
4250 OK, Lo, Hi, Assume_Valid);
4251
4252 else
4253 OK := False;
4254 end if;
4255 return;
4256 end if;
4257
4258 -- If type is not defined, we can't determine its range
4259
4260 if No (Typ)
4261
4262 -- We don't deal with anything except discrete types
4263
4264 or else not Is_Discrete_Type (Typ)
4265
4266 -- Ignore type for which an error has been posted, since range in
4267 -- this case may well be a bogosity deriving from the error. Also
4268 -- ignore if error posted on the reference node.
4269
4270 or else Error_Posted (N) or else Error_Posted (Typ)
4271 then
4272 OK := False;
4273 return;
4274 end if;
4275
4276 -- For all other cases, we can determine the range
4277
4278 OK := True;
4279
4280 -- If value is compile time known, then the possible range is the one
4281 -- value that we know this expression definitely has.
4282
4283 if Compile_Time_Known_Value (N) then
4284 Lo := Expr_Value (N);
4285 Hi := Lo;
4286 return;
4287 end if;
4288
4289 -- Return if already in the cache
4290
4291 Cindex := Cache_Index (N mod Cache_Size);
4292
4293 if Determine_Range_Cache_N (Cindex) = N
4294 and then
4295 Determine_Range_Cache_V (Cindex) = Assume_Valid
4296 then
4297 Lo := Determine_Range_Cache_Lo (Cindex);
4298 Hi := Determine_Range_Cache_Hi (Cindex);
4299 return;
4300 end if;
4301
4302 -- Otherwise, start by finding the bounds of the type of the expression,
4303 -- the value cannot be outside this range (if it is, then we have an
4304 -- overflow situation, which is a separate check, we are talking here
4305 -- only about the expression value).
4306
4307 -- First a check, never try to find the bounds of a generic type, since
4308 -- these bounds are always junk values, and it is only valid to look at
4309 -- the bounds in an instance.
4310
4311 if Is_Generic_Type (Typ) then
4312 OK := False;
4313 return;
4314 end if;
4315
4316 -- First step, change to use base type unless we know the value is valid
4317
4318 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4319 or else Assume_No_Invalid_Values
4320 or else Assume_Valid
4321 then
4322 null;
4323 else
4324 Typ := Underlying_Type (Base_Type (Typ));
4325 end if;
4326
4327 -- Retrieve the base type. Handle the case where the base type is a
4328 -- private enumeration type.
4329
4330 Btyp := Base_Type (Typ);
4331
4332 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4333 Btyp := Full_View (Btyp);
4334 end if;
4335
4336 -- We use the actual bound unless it is dynamic, in which case use the
4337 -- corresponding base type bound if possible. If we can't get a bound
4338 -- then we figure we can't determine the range (a peculiar case, that
4339 -- perhaps cannot happen, but there is no point in bombing in this
4340 -- optimization circuit.
4341
4342 -- First the low bound
4343
4344 Bound := Type_Low_Bound (Typ);
4345
4346 if Compile_Time_Known_Value (Bound) then
4347 Lo := Expr_Value (Bound);
4348
4349 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4350 Lo := Expr_Value (Type_Low_Bound (Btyp));
4351
4352 else
4353 OK := False;
4354 return;
4355 end if;
4356
4357 -- Now the high bound
4358
4359 Bound := Type_High_Bound (Typ);
4360
4361 -- We need the high bound of the base type later on, and this should
4362 -- always be compile time known. Again, it is not clear that this
4363 -- can ever be false, but no point in bombing.
4364
4365 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4366 Hbound := Expr_Value (Type_High_Bound (Btyp));
4367 Hi := Hbound;
4368
4369 else
4370 OK := False;
4371 return;
4372 end if;
4373
4374 -- If we have a static subtype, then that may have a tighter bound so
4375 -- use the upper bound of the subtype instead in this case.
4376
4377 if Compile_Time_Known_Value (Bound) then
4378 Hi := Expr_Value (Bound);
4379 end if;
4380
4381 -- We may be able to refine this value in certain situations. If any
4382 -- refinement is possible, then Lor and Hir are set to possibly tighter
4383 -- bounds, and OK1 is set to True.
4384
4385 case Nkind (N) is
4386
4387 -- For unary plus, result is limited by range of operand
4388
4389 when N_Op_Plus =>
4390 Determine_Range
4391 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4392
4393 -- For unary minus, determine range of operand, and negate it
4394
4395 when N_Op_Minus =>
4396 Determine_Range
4397 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4398
4399 if OK1 then
4400 Lor := -Hi_Right;
4401 Hir := -Lo_Right;
4402 end if;
4403
4404 -- For binary addition, get range of each operand and do the
4405 -- addition to get the result range.
4406
4407 when N_Op_Add =>
4408 if OK_Operands then
4409 Lor := Lo_Left + Lo_Right;
4410 Hir := Hi_Left + Hi_Right;
4411 end if;
4412
4413 -- Division is tricky. The only case we consider is where the right
4414 -- operand is a positive constant, and in this case we simply divide
4415 -- the bounds of the left operand
4416
4417 when N_Op_Divide =>
4418 if OK_Operands then
4419 if Lo_Right = Hi_Right
4420 and then Lo_Right > 0
4421 then
4422 Lor := Lo_Left / Lo_Right;
4423 Hir := Hi_Left / Lo_Right;
4424 else
4425 OK1 := False;
4426 end if;
4427 end if;
4428
4429 -- For binary subtraction, get range of each operand and do the worst
4430 -- case subtraction to get the result range.
4431
4432 when N_Op_Subtract =>
4433 if OK_Operands then
4434 Lor := Lo_Left - Hi_Right;
4435 Hir := Hi_Left - Lo_Right;
4436 end if;
4437
4438 -- For MOD, if right operand is a positive constant, then result must
4439 -- be in the allowable range of mod results.
4440
4441 when N_Op_Mod =>
4442 if OK_Operands then
4443 if Lo_Right = Hi_Right
4444 and then Lo_Right /= 0
4445 then
4446 if Lo_Right > 0 then
4447 Lor := Uint_0;
4448 Hir := Lo_Right - 1;
4449
4450 else -- Lo_Right < 0
4451 Lor := Lo_Right + 1;
4452 Hir := Uint_0;
4453 end if;
4454
4455 else
4456 OK1 := False;
4457 end if;
4458 end if;
4459
4460 -- For REM, if right operand is a positive constant, then result must
4461 -- be in the allowable range of mod results.
4462
4463 when N_Op_Rem =>
4464 if OK_Operands then
4465 if Lo_Right = Hi_Right
4466 and then Lo_Right /= 0
4467 then
4468 declare
4469 Dval : constant Uint := (abs Lo_Right) - 1;
4470
4471 begin
4472 -- The sign of the result depends on the sign of the
4473 -- dividend (but not on the sign of the divisor, hence
4474 -- the abs operation above).
4475
4476 if Lo_Left < 0 then
4477 Lor := -Dval;
4478 else
4479 Lor := Uint_0;
4480 end if;
4481
4482 if Hi_Left < 0 then
4483 Hir := Uint_0;
4484 else
4485 Hir := Dval;
4486 end if;
4487 end;
4488
4489 else
4490 OK1 := False;
4491 end if;
4492 end if;
4493
4494 -- Attribute reference cases
4495
4496 when N_Attribute_Reference =>
4497 case Attribute_Name (N) is
4498
4499 -- For Pos/Val attributes, we can refine the range using the
4500 -- possible range of values of the attribute expression.
4501
4502 when Name_Pos | Name_Val =>
4503 Determine_Range
4504 (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
4505
4506 -- For Length attribute, use the bounds of the corresponding
4507 -- index type to refine the range.
4508
4509 when Name_Length =>
4510 declare
4511 Atyp : Entity_Id := Etype (Prefix (N));
4512 Inum : Nat;
4513 Indx : Node_Id;
4514
4515 LL, LU : Uint;
4516 UL, UU : Uint;
4517
4518 begin
4519 if Is_Access_Type (Atyp) then
4520 Atyp := Designated_Type (Atyp);
4521 end if;
4522
4523 -- For string literal, we know exact value
4524
4525 if Ekind (Atyp) = E_String_Literal_Subtype then
4526 OK := True;
4527 Lo := String_Literal_Length (Atyp);
4528 Hi := String_Literal_Length (Atyp);
4529 return;
4530 end if;
4531
4532 -- Otherwise check for expression given
4533
4534 if No (Expressions (N)) then
4535 Inum := 1;
4536 else
4537 Inum :=
4538 UI_To_Int (Expr_Value (First (Expressions (N))));
4539 end if;
4540
4541 Indx := First_Index (Atyp);
4542 for J in 2 .. Inum loop
4543 Indx := Next_Index (Indx);
4544 end loop;
4545
4546 -- If the index type is a formal type or derived from
4547 -- one, the bounds are not static.
4548
4549 if Is_Generic_Type (Root_Type (Etype (Indx))) then
4550 OK := False;
4551 return;
4552 end if;
4553
4554 Determine_Range
4555 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
4556 Assume_Valid);
4557
4558 if OK1 then
4559 Determine_Range
4560 (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
4561 Assume_Valid);
4562
4563 if OK1 then
4564
4565 -- The maximum value for Length is the biggest
4566 -- possible gap between the values of the bounds.
4567 -- But of course, this value cannot be negative.
4568
4569 Hir := UI_Max (Uint_0, UU - LL + 1);
4570
4571 -- For constrained arrays, the minimum value for
4572 -- Length is taken from the actual value of the
4573 -- bounds, since the index will be exactly of this
4574 -- subtype.
4575
4576 if Is_Constrained (Atyp) then
4577 Lor := UI_Max (Uint_0, UL - LU + 1);
4578
4579 -- For an unconstrained array, the minimum value
4580 -- for length is always zero.
4581
4582 else
4583 Lor := Uint_0;
4584 end if;
4585 end if;
4586 end if;
4587 end;
4588
4589 -- No special handling for other attributes
4590 -- Probably more opportunities exist here???
4591
4592 when others =>
4593 OK1 := False;
4594
4595 end case;
4596
4597 -- For type conversion from one discrete type to another, we can
4598 -- refine the range using the converted value.
4599
4600 when N_Type_Conversion =>
4601 Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
4602
4603 -- Nothing special to do for all other expression kinds
4604
4605 when others =>
4606 OK1 := False;
4607 Lor := No_Uint;
4608 Hir := No_Uint;
4609 end case;
4610
4611 -- At this stage, if OK1 is true, then we know that the actual result of
4612 -- the computed expression is in the range Lor .. Hir. We can use this
4613 -- to restrict the possible range of results.
4614
4615 if OK1 then
4616
4617 -- If the refined value of the low bound is greater than the type
4618 -- low bound, then reset it to the more restrictive value. However,
4619 -- we do NOT do this for the case of a modular type where the
4620 -- possible upper bound on the value is above the base type high
4621 -- bound, because that means the result could wrap.
4622
4623 if Lor > Lo
4624 and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound)
4625 then
4626 Lo := Lor;
4627 end if;
4628
4629 -- Similarly, if the refined value of the high bound is less than the
4630 -- value so far, then reset it to the more restrictive value. Again,
4631 -- we do not do this if the refined low bound is negative for a
4632 -- modular type, since this would wrap.
4633
4634 if Hir < Hi
4635 and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0)
4636 then
4637 Hi := Hir;
4638 end if;
4639 end if;
4640
4641 -- Set cache entry for future call and we are all done
4642
4643 Determine_Range_Cache_N (Cindex) := N;
4644 Determine_Range_Cache_V (Cindex) := Assume_Valid;
4645 Determine_Range_Cache_Lo (Cindex) := Lo;
4646 Determine_Range_Cache_Hi (Cindex) := Hi;
4647 return;
4648
4649 -- If any exception occurs, it means that we have some bug in the compiler,
4650 -- possibly triggered by a previous error, or by some unforeseen peculiar
4651 -- occurrence. However, this is only an optimization attempt, so there is
4652 -- really no point in crashing the compiler. Instead we just decide, too
4653 -- bad, we can't figure out a range in this case after all.
4654
4655 exception
4656 when others =>
4657
4658 -- Debug flag K disables this behavior (useful for debugging)
4659
4660 if Debug_Flag_K then
4661 raise;
4662 else
4663 OK := False;
4664 Lo := No_Uint;
4665 Hi := No_Uint;
4666 return;
4667 end if;
4668 end Determine_Range;
4669
4670 -----------------------
4671 -- Determine_Range_R --
4672 -----------------------
4673
4674 procedure Determine_Range_R
4675 (N : Node_Id;
4676 OK : out Boolean;
4677 Lo : out Ureal;
4678 Hi : out Ureal;
4679 Assume_Valid : Boolean := False)
4680 is
4681 Typ : Entity_Id := Etype (N);
4682 -- Type to use, may get reset to base type for possibly invalid entity
4683
4684 Lo_Left : Ureal;
4685 Hi_Left : Ureal;
4686 -- Lo and Hi bounds of left operand
4687
4688 Lo_Right : Ureal;
4689 Hi_Right : Ureal;
4690 -- Lo and Hi bounds of right (or only) operand
4691
4692 Bound : Node_Id;
4693 -- Temp variable used to hold a bound node
4694
4695 Hbound : Ureal;
4696 -- High bound of base type of expression
4697
4698 Lor : Ureal;
4699 Hir : Ureal;
4700 -- Refined values for low and high bounds, after tightening
4701
4702 OK1 : Boolean;
4703 -- Used in lower level calls to indicate if call succeeded
4704
4705 Cindex : Cache_Index;
4706 -- Used to search cache
4707
4708 Btyp : Entity_Id;
4709 -- Base type
4710
4711 function OK_Operands return Boolean;
4712 -- Used for binary operators. Determines the ranges of the left and
4713 -- right operands, and if they are both OK, returns True, and puts
4714 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4715
4716 function Round_Machine (B : Ureal) return Ureal;
4717 -- B is a real bound. Round it using mode Round_Even.
4718
4719 -----------------
4720 -- OK_Operands --
4721 -----------------
4722
4723 function OK_Operands return Boolean is
4724 begin
4725 Determine_Range_R
4726 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
4727
4728 if not OK1 then
4729 return False;
4730 end if;
4731
4732 Determine_Range_R
4733 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4734 return OK1;
4735 end OK_Operands;
4736
4737 -------------------
4738 -- Round_Machine --
4739 -------------------
4740
4741 function Round_Machine (B : Ureal) return Ureal is
4742 begin
4743 return Machine (Typ, B, Round_Even, N);
4744 end Round_Machine;
4745
4746 -- Start of processing for Determine_Range_R
4747
4748 begin
4749 -- Prevent junk warnings by initializing range variables
4750
4751 Lo := No_Ureal;
4752 Hi := No_Ureal;
4753 Lor := No_Ureal;
4754 Hir := No_Ureal;
4755
4756 -- For temporary constants internally generated to remove side effects
4757 -- we must use the corresponding expression to determine the range of
4758 -- the expression. But note that the expander can also generate
4759 -- constants in other cases, including deferred constants.
4760
4761 if Is_Entity_Name (N)
4762 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
4763 and then Ekind (Entity (N)) = E_Constant
4764 and then Is_Internal_Name (Chars (Entity (N)))
4765 then
4766 if Present (Expression (Parent (Entity (N)))) then
4767 Determine_Range_R
4768 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
4769
4770 elsif Present (Full_View (Entity (N))) then
4771 Determine_Range_R
4772 (Expression (Parent (Full_View (Entity (N)))),
4773 OK, Lo, Hi, Assume_Valid);
4774
4775 else
4776 OK := False;
4777 end if;
4778
4779 return;
4780 end if;
4781
4782 -- If type is not defined, we can't determine its range
4783
4784 if No (Typ)
4785
4786 -- We don't deal with anything except IEEE floating-point types
4787
4788 or else not Is_Floating_Point_Type (Typ)
4789 or else Float_Rep (Typ) /= IEEE_Binary
4790
4791 -- Ignore type for which an error has been posted, since range in
4792 -- this case may well be a bogosity deriving from the error. Also
4793 -- ignore if error posted on the reference node.
4794
4795 or else Error_Posted (N) or else Error_Posted (Typ)
4796 then
4797 OK := False;
4798 return;
4799 end if;
4800
4801 -- For all other cases, we can determine the range
4802
4803 OK := True;
4804
4805 -- If value is compile time known, then the possible range is the one
4806 -- value that we know this expression definitely has.
4807
4808 if Compile_Time_Known_Value (N) then
4809 Lo := Expr_Value_R (N);
4810 Hi := Lo;
4811 return;
4812 end if;
4813
4814 -- Return if already in the cache
4815
4816 Cindex := Cache_Index (N mod Cache_Size);
4817
4818 if Determine_Range_Cache_N (Cindex) = N
4819 and then
4820 Determine_Range_Cache_V (Cindex) = Assume_Valid
4821 then
4822 Lo := Determine_Range_Cache_Lo_R (Cindex);
4823 Hi := Determine_Range_Cache_Hi_R (Cindex);
4824 return;
4825 end if;
4826
4827 -- Otherwise, start by finding the bounds of the type of the expression,
4828 -- the value cannot be outside this range (if it is, then we have an
4829 -- overflow situation, which is a separate check, we are talking here
4830 -- only about the expression value).
4831
4832 -- First a check, never try to find the bounds of a generic type, since
4833 -- these bounds are always junk values, and it is only valid to look at
4834 -- the bounds in an instance.
4835
4836 if Is_Generic_Type (Typ) then
4837 OK := False;
4838 return;
4839 end if;
4840
4841 -- First step, change to use base type unless we know the value is valid
4842
4843 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
4844 or else Assume_No_Invalid_Values
4845 or else Assume_Valid
4846 then
4847 null;
4848 else
4849 Typ := Underlying_Type (Base_Type (Typ));
4850 end if;
4851
4852 -- Retrieve the base type. Handle the case where the base type is a
4853 -- private type.
4854
4855 Btyp := Base_Type (Typ);
4856
4857 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
4858 Btyp := Full_View (Btyp);
4859 end if;
4860
4861 -- We use the actual bound unless it is dynamic, in which case use the
4862 -- corresponding base type bound if possible. If we can't get a bound
4863 -- then we figure we can't determine the range (a peculiar case, that
4864 -- perhaps cannot happen, but there is no point in bombing in this
4865 -- optimization circuit).
4866
4867 -- First the low bound
4868
4869 Bound := Type_Low_Bound (Typ);
4870
4871 if Compile_Time_Known_Value (Bound) then
4872 Lo := Expr_Value_R (Bound);
4873
4874 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
4875 Lo := Expr_Value_R (Type_Low_Bound (Btyp));
4876
4877 else
4878 OK := False;
4879 return;
4880 end if;
4881
4882 -- Now the high bound
4883
4884 Bound := Type_High_Bound (Typ);
4885
4886 -- We need the high bound of the base type later on, and this should
4887 -- always be compile time known. Again, it is not clear that this
4888 -- can ever be false, but no point in bombing.
4889
4890 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
4891 Hbound := Expr_Value_R (Type_High_Bound (Btyp));
4892 Hi := Hbound;
4893
4894 else
4895 OK := False;
4896 return;
4897 end if;
4898
4899 -- If we have a static subtype, then that may have a tighter bound so
4900 -- use the upper bound of the subtype instead in this case.
4901
4902 if Compile_Time_Known_Value (Bound) then
4903 Hi := Expr_Value_R (Bound);
4904 end if;
4905
4906 -- We may be able to refine this value in certain situations. If any
4907 -- refinement is possible, then Lor and Hir are set to possibly tighter
4908 -- bounds, and OK1 is set to True.
4909
4910 case Nkind (N) is
4911
4912 -- For unary plus, result is limited by range of operand
4913
4914 when N_Op_Plus =>
4915 Determine_Range_R
4916 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
4917
4918 -- For unary minus, determine range of operand, and negate it
4919
4920 when N_Op_Minus =>
4921 Determine_Range_R
4922 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
4923
4924 if OK1 then
4925 Lor := -Hi_Right;
4926 Hir := -Lo_Right;
4927 end if;
4928
4929 -- For binary addition, get range of each operand and do the
4930 -- addition to get the result range.
4931
4932 when N_Op_Add =>
4933 if OK_Operands then
4934 Lor := Round_Machine (Lo_Left + Lo_Right);
4935 Hir := Round_Machine (Hi_Left + Hi_Right);
4936 end if;
4937
4938 -- For binary subtraction, get range of each operand and do the worst
4939 -- case subtraction to get the result range.
4940
4941 when N_Op_Subtract =>
4942 if OK_Operands then
4943 Lor := Round_Machine (Lo_Left - Hi_Right);
4944 Hir := Round_Machine (Hi_Left - Lo_Right);
4945 end if;
4946
4947 -- For multiplication, get range of each operand and do the
4948 -- four multiplications to get the result range.
4949
4950 when N_Op_Multiply =>
4951 if OK_Operands then
4952 declare
4953 M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
4954 M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
4955 M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
4956 M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
4957 begin
4958 Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
4959 Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
4960 end;
4961 end if;
4962
4963 -- For division, consider separately the cases where the right
4964 -- operand is positive or negative. Otherwise, the right operand
4965 -- can be arbitrarily close to zero, so the result is likely to
4966 -- be unbounded in one direction, do not attempt to compute it.
4967
4968 when N_Op_Divide =>
4969 if OK_Operands then
4970
4971 -- Right operand is positive
4972
4973 if Lo_Right > Ureal_0 then
4974
4975 -- If the low bound of the left operand is negative, obtain
4976 -- the overall low bound by dividing it by the smallest
4977 -- value of the right operand, and otherwise by the largest
4978 -- value of the right operand.
4979
4980 if Lo_Left < Ureal_0 then
4981 Lor := Round_Machine (Lo_Left / Lo_Right);
4982 else
4983 Lor := Round_Machine (Lo_Left / Hi_Right);
4984 end if;
4985
4986 -- If the high bound of the left operand is negative, obtain
4987 -- the overall high bound by dividing it by the largest
4988 -- value of the right operand, and otherwise by the
4989 -- smallest value of the right operand.
4990
4991 if Hi_Left < Ureal_0 then
4992 Hir := Round_Machine (Hi_Left / Hi_Right);
4993 else
4994 Hir := Round_Machine (Hi_Left / Lo_Right);
4995 end if;
4996
4997 -- Right operand is negative
4998
4999 elsif Hi_Right < Ureal_0 then
5000
5001 -- If the low bound of the left operand is negative, obtain
5002 -- the overall low bound by dividing it by the largest
5003 -- value of the right operand, and otherwise by the smallest
5004 -- value of the right operand.
5005
5006 if Lo_Left < Ureal_0 then
5007 Lor := Round_Machine (Lo_Left / Hi_Right);
5008 else
5009 Lor := Round_Machine (Lo_Left / Lo_Right);
5010 end if;
5011
5012 -- If the high bound of the left operand is negative, obtain
5013 -- the overall high bound by dividing it by the smallest
5014 -- value of the right operand, and otherwise by the
5015 -- largest value of the right operand.
5016
5017 if Hi_Left < Ureal_0 then
5018 Hir := Round_Machine (Hi_Left / Lo_Right);
5019 else
5020 Hir := Round_Machine (Hi_Left / Hi_Right);
5021 end if;
5022
5023 else
5024 OK1 := False;
5025 end if;
5026 end if;
5027
5028 -- For type conversion from one floating-point type to another, we
5029 -- can refine the range using the converted value.
5030
5031 when N_Type_Conversion =>
5032 Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
5033
5034 -- Nothing special to do for all other expression kinds
5035
5036 when others =>
5037 OK1 := False;
5038 Lor := No_Ureal;
5039 Hir := No_Ureal;
5040 end case;
5041
5042 -- At this stage, if OK1 is true, then we know that the actual result of
5043 -- the computed expression is in the range Lor .. Hir. We can use this
5044 -- to restrict the possible range of results.
5045
5046 if OK1 then
5047
5048 -- If the refined value of the low bound is greater than the type
5049 -- low bound, then reset it to the more restrictive value.
5050
5051 if Lor > Lo then
5052 Lo := Lor;
5053 end if;
5054
5055 -- Similarly, if the refined value of the high bound is less than the
5056 -- value so far, then reset it to the more restrictive value.
5057
5058 if Hir < Hi then
5059 Hi := Hir;
5060 end if;
5061 end if;
5062
5063 -- Set cache entry for future call and we are all done
5064
5065 Determine_Range_Cache_N (Cindex) := N;
5066 Determine_Range_Cache_V (Cindex) := Assume_Valid;
5067 Determine_Range_Cache_Lo_R (Cindex) := Lo;
5068 Determine_Range_Cache_Hi_R (Cindex) := Hi;
5069 return;
5070
5071 -- If any exception occurs, it means that we have some bug in the compiler,
5072 -- possibly triggered by a previous error, or by some unforeseen peculiar
5073 -- occurrence. However, this is only an optimization attempt, so there is
5074 -- really no point in crashing the compiler. Instead we just decide, too
5075 -- bad, we can't figure out a range in this case after all.
5076
5077 exception
5078 when others =>
5079
5080 -- Debug flag K disables this behavior (useful for debugging)
5081
5082 if Debug_Flag_K then
5083 raise;
5084 else
5085 OK := False;
5086 Lo := No_Ureal;
5087 Hi := No_Ureal;
5088 return;
5089 end if;
5090 end Determine_Range_R;
5091
5092 ------------------------------------
5093 -- Discriminant_Checks_Suppressed --
5094 ------------------------------------
5095
5096 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
5097 begin
5098 if Present (E) then
5099 if Is_Unchecked_Union (E) then
5100 return True;
5101 elsif Checks_May_Be_Suppressed (E) then
5102 return Is_Check_Suppressed (E, Discriminant_Check);
5103 end if;
5104 end if;
5105
5106 return Scope_Suppress.Suppress (Discriminant_Check);
5107 end Discriminant_Checks_Suppressed;
5108
5109 --------------------------------
5110 -- Division_Checks_Suppressed --
5111 --------------------------------
5112
5113 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
5114 begin
5115 if Present (E) and then Checks_May_Be_Suppressed (E) then
5116 return Is_Check_Suppressed (E, Division_Check);
5117 else
5118 return Scope_Suppress.Suppress (Division_Check);
5119 end if;
5120 end Division_Checks_Suppressed;
5121
5122 --------------------------------------
5123 -- Duplicated_Tag_Checks_Suppressed --
5124 --------------------------------------
5125
5126 function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
5127 begin
5128 if Present (E) and then Checks_May_Be_Suppressed (E) then
5129 return Is_Check_Suppressed (E, Duplicated_Tag_Check);
5130 else
5131 return Scope_Suppress.Suppress (Duplicated_Tag_Check);
5132 end if;
5133 end Duplicated_Tag_Checks_Suppressed;
5134
5135 -----------------------------------
5136 -- Elaboration_Checks_Suppressed --
5137 -----------------------------------
5138
5139 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
5140 begin
5141 -- The complication in this routine is that if we are in the dynamic
5142 -- model of elaboration, we also check All_Checks, since All_Checks
5143 -- does not set Elaboration_Check explicitly.
5144
5145 if Present (E) then
5146 if Kill_Elaboration_Checks (E) then
5147 return True;
5148
5149 elsif Checks_May_Be_Suppressed (E) then
5150 if Is_Check_Suppressed (E, Elaboration_Check) then
5151 return True;
5152 elsif Dynamic_Elaboration_Checks then
5153 return Is_Check_Suppressed (E, All_Checks);
5154 else
5155 return False;
5156 end if;
5157 end if;
5158 end if;
5159
5160 if Scope_Suppress.Suppress (Elaboration_Check) then
5161 return True;
5162 elsif Dynamic_Elaboration_Checks then
5163 return Scope_Suppress.Suppress (All_Checks);
5164 else
5165 return False;
5166 end if;
5167 end Elaboration_Checks_Suppressed;
5168
5169 ---------------------------
5170 -- Enable_Overflow_Check --
5171 ---------------------------
5172
5173 procedure Enable_Overflow_Check (N : Node_Id) is
5174 Typ : constant Entity_Id := Base_Type (Etype (N));
5175 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
5176 Chk : Nat;
5177 OK : Boolean;
5178 Ent : Entity_Id;
5179 Ofs : Uint;
5180 Lo : Uint;
5181 Hi : Uint;
5182
5183 Do_Ovflow_Check : Boolean;
5184
5185 begin
5186 if Debug_Flag_CC then
5187 w ("Enable_Overflow_Check for node ", Int (N));
5188 Write_Str (" Source location = ");
5189 wl (Sloc (N));
5190 pg (Union_Id (N));
5191 end if;
5192
5193 -- No check if overflow checks suppressed for type of node
5194
5195 if Overflow_Checks_Suppressed (Etype (N)) then
5196 return;
5197
5198 -- Nothing to do for unsigned integer types, which do not overflow
5199
5200 elsif Is_Modular_Integer_Type (Typ) then
5201 return;
5202 end if;
5203
5204 -- This is the point at which processing for STRICT mode diverges
5205 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5206 -- probably more extreme that it needs to be, but what is going on here
5207 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5208 -- to leave the processing for STRICT mode untouched. There were
5209 -- two reasons for this. First it avoided any incompatible change of
5210 -- behavior. Second, it guaranteed that STRICT mode continued to be
5211 -- legacy reliable.
5212
5213 -- The big difference is that in STRICT mode there is a fair amount of
5214 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5215 -- know that no check is needed. We skip all that in the two new modes,
5216 -- since really overflow checking happens over a whole subtree, and we
5217 -- do the corresponding optimizations later on when applying the checks.
5218
5219 if Mode in Minimized_Or_Eliminated then
5220 if not (Overflow_Checks_Suppressed (Etype (N)))
5221 and then not (Is_Entity_Name (N)
5222 and then Overflow_Checks_Suppressed (Entity (N)))
5223 then
5224 Activate_Overflow_Check (N);
5225 end if;
5226
5227 if Debug_Flag_CC then
5228 w ("Minimized/Eliminated mode");
5229 end if;
5230
5231 return;
5232 end if;
5233
5234 -- Remainder of processing is for STRICT case, and is unchanged from
5235 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5236
5237 -- Nothing to do if the range of the result is known OK. We skip this
5238 -- for conversions, since the caller already did the check, and in any
5239 -- case the condition for deleting the check for a type conversion is
5240 -- different.
5241
5242 if Nkind (N) /= N_Type_Conversion then
5243 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
5244
5245 -- Note in the test below that we assume that the range is not OK
5246 -- if a bound of the range is equal to that of the type. That's not
5247 -- quite accurate but we do this for the following reasons:
5248
5249 -- a) The way that Determine_Range works, it will typically report
5250 -- the bounds of the value as being equal to the bounds of the
5251 -- type, because it either can't tell anything more precise, or
5252 -- does not think it is worth the effort to be more precise.
5253
5254 -- b) It is very unusual to have a situation in which this would
5255 -- generate an unnecessary overflow check (an example would be
5256 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5257 -- literal value one is added).
5258
5259 -- c) The alternative is a lot of special casing in this routine
5260 -- which would partially duplicate Determine_Range processing.
5261
5262 if OK then
5263 Do_Ovflow_Check := True;
5264
5265 -- Note that the following checks are quite deliberately > and <
5266 -- rather than >= and <= as explained above.
5267
5268 if Lo > Expr_Value (Type_Low_Bound (Typ))
5269 and then
5270 Hi < Expr_Value (Type_High_Bound (Typ))
5271 then
5272 Do_Ovflow_Check := False;
5273
5274 -- Despite the comments above, it is worth dealing specially with
5275 -- division specially. The only case where integer division can
5276 -- overflow is (largest negative number) / (-1). So we will do
5277 -- an extra range analysis to see if this is possible.
5278
5279 elsif Nkind (N) = N_Op_Divide then
5280 Determine_Range
5281 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5282
5283 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then
5284 Do_Ovflow_Check := False;
5285
5286 else
5287 Determine_Range
5288 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
5289
5290 if OK and then (Lo > Uint_Minus_1
5291 or else
5292 Hi < Uint_Minus_1)
5293 then
5294 Do_Ovflow_Check := False;
5295 end if;
5296 end if;
5297 end if;
5298
5299 -- If no overflow check required, we are done
5300
5301 if not Do_Ovflow_Check then
5302 if Debug_Flag_CC then
5303 w ("No overflow check required");
5304 end if;
5305
5306 return;
5307 end if;
5308 end if;
5309 end if;
5310
5311 -- If not in optimizing mode, set flag and we are done. We are also done
5312 -- (and just set the flag) if the type is not a discrete type, since it
5313 -- is not worth the effort to eliminate checks for other than discrete
5314 -- types. In addition, we take this same path if we have stored the
5315 -- maximum number of checks possible already (a very unlikely situation,
5316 -- but we do not want to blow up).
5317
5318 if Optimization_Level = 0
5319 or else not Is_Discrete_Type (Etype (N))
5320 or else Num_Saved_Checks = Saved_Checks'Last
5321 then
5322 Activate_Overflow_Check (N);
5323
5324 if Debug_Flag_CC then
5325 w ("Optimization off");
5326 end if;
5327
5328 return;
5329 end if;
5330
5331 -- Otherwise evaluate and check the expression
5332
5333 Find_Check
5334 (Expr => N,
5335 Check_Type => 'O',
5336 Target_Type => Empty,
5337 Entry_OK => OK,
5338 Check_Num => Chk,
5339 Ent => Ent,
5340 Ofs => Ofs);
5341
5342 if Debug_Flag_CC then
5343 w ("Called Find_Check");
5344 w (" OK = ", OK);
5345
5346 if OK then
5347 w (" Check_Num = ", Chk);
5348 w (" Ent = ", Int (Ent));
5349 Write_Str (" Ofs = ");
5350 pid (Ofs);
5351 end if;
5352 end if;
5353
5354 -- If check is not of form to optimize, then set flag and we are done
5355
5356 if not OK then
5357 Activate_Overflow_Check (N);
5358 return;
5359 end if;
5360
5361 -- If check is already performed, then return without setting flag
5362
5363 if Chk /= 0 then
5364 if Debug_Flag_CC then
5365 w ("Check suppressed!");
5366 end if;
5367
5368 return;
5369 end if;
5370
5371 -- Here we will make a new entry for the new check
5372
5373 Activate_Overflow_Check (N);
5374 Num_Saved_Checks := Num_Saved_Checks + 1;
5375 Saved_Checks (Num_Saved_Checks) :=
5376 (Killed => False,
5377 Entity => Ent,
5378 Offset => Ofs,
5379 Check_Type => 'O',
5380 Target_Type => Empty);
5381
5382 if Debug_Flag_CC then
5383 w ("Make new entry, check number = ", Num_Saved_Checks);
5384 w (" Entity = ", Int (Ent));
5385 Write_Str (" Offset = ");
5386 pid (Ofs);
5387 w (" Check_Type = O");
5388 w (" Target_Type = Empty");
5389 end if;
5390
5391 -- If we get an exception, then something went wrong, probably because of
5392 -- an error in the structure of the tree due to an incorrect program. Or
5393 -- it may be a bug in the optimization circuit. In either case the safest
5394 -- thing is simply to set the check flag unconditionally.
5395
5396 exception
5397 when others =>
5398 Activate_Overflow_Check (N);
5399
5400 if Debug_Flag_CC then
5401 w (" exception occurred, overflow flag set");
5402 end if;
5403
5404 return;
5405 end Enable_Overflow_Check;
5406
5407 ------------------------
5408 -- Enable_Range_Check --
5409 ------------------------
5410
5411 procedure Enable_Range_Check (N : Node_Id) is
5412 Chk : Nat;
5413 OK : Boolean;
5414 Ent : Entity_Id;
5415 Ofs : Uint;
5416 Ttyp : Entity_Id;
5417 P : Node_Id;
5418
5419 begin
5420 -- Return if unchecked type conversion with range check killed. In this
5421 -- case we never set the flag (that's what Kill_Range_Check is about).
5422
5423 if Nkind (N) = N_Unchecked_Type_Conversion
5424 and then Kill_Range_Check (N)
5425 then
5426 return;
5427 end if;
5428
5429 -- Do not set range check flag if parent is assignment statement or
5430 -- object declaration with Suppress_Assignment_Checks flag set
5431
5432 if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
5433 and then Suppress_Assignment_Checks (Parent (N))
5434 then
5435 return;
5436 end if;
5437
5438 -- Check for various cases where we should suppress the range check
5439
5440 -- No check if range checks suppressed for type of node
5441
5442 if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then
5443 return;
5444
5445 -- No check if node is an entity name, and range checks are suppressed
5446 -- for this entity, or for the type of this entity.
5447
5448 elsif Is_Entity_Name (N)
5449 and then (Range_Checks_Suppressed (Entity (N))
5450 or else Range_Checks_Suppressed (Etype (Entity (N))))
5451 then
5452 return;
5453
5454 -- No checks if index of array, and index checks are suppressed for
5455 -- the array object or the type of the array.
5456
5457 elsif Nkind (Parent (N)) = N_Indexed_Component then
5458 declare
5459 Pref : constant Node_Id := Prefix (Parent (N));
5460 begin
5461 if Is_Entity_Name (Pref)
5462 and then Index_Checks_Suppressed (Entity (Pref))
5463 then
5464 return;
5465 elsif Index_Checks_Suppressed (Etype (Pref)) then
5466 return;
5467 end if;
5468 end;
5469 end if;
5470
5471 -- Debug trace output
5472
5473 if Debug_Flag_CC then
5474 w ("Enable_Range_Check for node ", Int (N));
5475 Write_Str (" Source location = ");
5476 wl (Sloc (N));
5477 pg (Union_Id (N));
5478 end if;
5479
5480 -- If not in optimizing mode, set flag and we are done. We are also done
5481 -- (and just set the flag) if the type is not a discrete type, since it
5482 -- is not worth the effort to eliminate checks for other than discrete
5483 -- types. In addition, we take this same path if we have stored the
5484 -- maximum number of checks possible already (a very unlikely situation,
5485 -- but we do not want to blow up).
5486
5487 if Optimization_Level = 0
5488 or else No (Etype (N))
5489 or else not Is_Discrete_Type (Etype (N))
5490 or else Num_Saved_Checks = Saved_Checks'Last
5491 then
5492 Activate_Range_Check (N);
5493
5494 if Debug_Flag_CC then
5495 w ("Optimization off");
5496 end if;
5497
5498 return;
5499 end if;
5500
5501 -- Otherwise find out the target type
5502
5503 P := Parent (N);
5504
5505 -- For assignment, use left side subtype
5506
5507 if Nkind (P) = N_Assignment_Statement
5508 and then Expression (P) = N
5509 then
5510 Ttyp := Etype (Name (P));
5511
5512 -- For indexed component, use subscript subtype
5513
5514 elsif Nkind (P) = N_Indexed_Component then
5515 declare
5516 Atyp : Entity_Id;
5517 Indx : Node_Id;
5518 Subs : Node_Id;
5519
5520 begin
5521 Atyp := Etype (Prefix (P));
5522
5523 if Is_Access_Type (Atyp) then
5524 Atyp := Designated_Type (Atyp);
5525
5526 -- If the prefix is an access to an unconstrained array,
5527 -- perform check unconditionally: it depends on the bounds of
5528 -- an object and we cannot currently recognize whether the test
5529 -- may be redundant.
5530
5531 if not Is_Constrained (Atyp) then
5532 Activate_Range_Check (N);
5533 return;
5534 end if;
5535
5536 -- Ditto if prefix is simply an unconstrained array. We used
5537 -- to think this case was OK, if the prefix was not an explicit
5538 -- dereference, but we have now seen a case where this is not
5539 -- true, so it is safer to just suppress the optimization in this
5540 -- case. The back end is getting better at eliminating redundant
5541 -- checks in any case, so the loss won't be important.
5542
5543 elsif Is_Array_Type (Atyp)
5544 and then not Is_Constrained (Atyp)
5545 then
5546 Activate_Range_Check (N);
5547 return;
5548 end if;
5549
5550 Indx := First_Index (Atyp);
5551 Subs := First (Expressions (P));
5552 loop
5553 if Subs = N then
5554 Ttyp := Etype (Indx);
5555 exit;
5556 end if;
5557
5558 Next_Index (Indx);
5559 Next (Subs);
5560 end loop;
5561 end;
5562
5563 -- For now, ignore all other cases, they are not so interesting
5564
5565 else
5566 if Debug_Flag_CC then
5567 w (" target type not found, flag set");
5568 end if;
5569
5570 Activate_Range_Check (N);
5571 return;
5572 end if;
5573
5574 -- Evaluate and check the expression
5575
5576 Find_Check
5577 (Expr => N,
5578 Check_Type => 'R',
5579 Target_Type => Ttyp,
5580 Entry_OK => OK,
5581 Check_Num => Chk,
5582 Ent => Ent,
5583 Ofs => Ofs);
5584
5585 if Debug_Flag_CC then
5586 w ("Called Find_Check");
5587 w ("Target_Typ = ", Int (Ttyp));
5588 w (" OK = ", OK);
5589
5590 if OK then
5591 w (" Check_Num = ", Chk);
5592 w (" Ent = ", Int (Ent));
5593 Write_Str (" Ofs = ");
5594 pid (Ofs);
5595 end if;
5596 end if;
5597
5598 -- If check is not of form to optimize, then set flag and we are done
5599
5600 if not OK then
5601 if Debug_Flag_CC then
5602 w (" expression not of optimizable type, flag set");
5603 end if;
5604
5605 Activate_Range_Check (N);
5606 return;
5607 end if;
5608
5609 -- If check is already performed, then return without setting flag
5610
5611 if Chk /= 0 then
5612 if Debug_Flag_CC then
5613 w ("Check suppressed!");
5614 end if;
5615
5616 return;
5617 end if;
5618
5619 -- Here we will make a new entry for the new check
5620
5621 Activate_Range_Check (N);
5622 Num_Saved_Checks := Num_Saved_Checks + 1;
5623 Saved_Checks (Num_Saved_Checks) :=
5624 (Killed => False,
5625 Entity => Ent,
5626 Offset => Ofs,
5627 Check_Type => 'R',
5628 Target_Type => Ttyp);
5629
5630 if Debug_Flag_CC then
5631 w ("Make new entry, check number = ", Num_Saved_Checks);
5632 w (" Entity = ", Int (Ent));
5633 Write_Str (" Offset = ");
5634 pid (Ofs);
5635 w (" Check_Type = R");
5636 w (" Target_Type = ", Int (Ttyp));
5637 pg (Union_Id (Ttyp));
5638 end if;
5639
5640 -- If we get an exception, then something went wrong, probably because of
5641 -- an error in the structure of the tree due to an incorrect program. Or
5642 -- it may be a bug in the optimization circuit. In either case the safest
5643 -- thing is simply to set the check flag unconditionally.
5644
5645 exception
5646 when others =>
5647 Activate_Range_Check (N);
5648
5649 if Debug_Flag_CC then
5650 w (" exception occurred, range flag set");
5651 end if;
5652
5653 return;
5654 end Enable_Range_Check;
5655
5656 ------------------
5657 -- Ensure_Valid --
5658 ------------------
5659
5660 procedure Ensure_Valid
5661 (Expr : Node_Id;
5662 Holes_OK : Boolean := False;
5663 Related_Id : Entity_Id := Empty;
5664 Is_Low_Bound : Boolean := False;
5665 Is_High_Bound : Boolean := False)
5666 is
5667 Typ : constant Entity_Id := Etype (Expr);
5668
5669 begin
5670 -- Ignore call if we are not doing any validity checking
5671
5672 if not Validity_Checks_On then
5673 return;
5674
5675 -- Ignore call if range or validity checks suppressed on entity or type
5676
5677 elsif Range_Or_Validity_Checks_Suppressed (Expr) then
5678 return;
5679
5680 -- No check required if expression is from the expander, we assume the
5681 -- expander will generate whatever checks are needed. Note that this is
5682 -- not just an optimization, it avoids infinite recursions.
5683
5684 -- Unchecked conversions must be checked, unless they are initialized
5685 -- scalar values, as in a component assignment in an init proc.
5686
5687 -- In addition, we force a check if Force_Validity_Checks is set
5688
5689 elsif not Comes_From_Source (Expr)
5690 and then not Force_Validity_Checks
5691 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
5692 or else Kill_Range_Check (Expr))
5693 then
5694 return;
5695
5696 -- No check required if expression is known to have valid value
5697
5698 elsif Expr_Known_Valid (Expr) then
5699 return;
5700
5701 -- Ignore case of enumeration with holes where the flag is set not to
5702 -- worry about holes, since no special validity check is needed
5703
5704 elsif Is_Enumeration_Type (Typ)
5705 and then Has_Non_Standard_Rep (Typ)
5706 and then Holes_OK
5707 then
5708 return;
5709
5710 -- No check required on the left-hand side of an assignment
5711
5712 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
5713 and then Expr = Name (Parent (Expr))
5714 then
5715 return;
5716
5717 -- No check on a universal real constant. The context will eventually
5718 -- convert it to a machine number for some target type, or report an
5719 -- illegality.
5720
5721 elsif Nkind (Expr) = N_Real_Literal
5722 and then Etype (Expr) = Universal_Real
5723 then
5724 return;
5725
5726 -- If the expression denotes a component of a packed boolean array,
5727 -- no possible check applies. We ignore the old ACATS chestnuts that
5728 -- involve Boolean range True..True.
5729
5730 -- Note: validity checks are generated for expressions that yield a
5731 -- scalar type, when it is possible to create a value that is outside of
5732 -- the type. If this is a one-bit boolean no such value exists. This is
5733 -- an optimization, and it also prevents compiler blowing up during the
5734 -- elaboration of improperly expanded packed array references.
5735
5736 elsif Nkind (Expr) = N_Indexed_Component
5737 and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
5738 and then Root_Type (Etype (Expr)) = Standard_Boolean
5739 then
5740 return;
5741
5742 -- For an expression with actions, we want to insert the validity check
5743 -- on the final Expression.
5744
5745 elsif Nkind (Expr) = N_Expression_With_Actions then
5746 Ensure_Valid (Expression (Expr));
5747 return;
5748
5749 -- An annoying special case. If this is an out parameter of a scalar
5750 -- type, then the value is not going to be accessed, therefore it is
5751 -- inappropriate to do any validity check at the call site.
5752
5753 else
5754 -- Only need to worry about scalar types
5755
5756 if Is_Scalar_Type (Typ) then
5757 declare
5758 P : Node_Id;
5759 N : Node_Id;
5760 E : Entity_Id;
5761 F : Entity_Id;
5762 A : Node_Id;
5763 L : List_Id;
5764
5765 begin
5766 -- Find actual argument (which may be a parameter association)
5767 -- and the parent of the actual argument (the call statement)
5768
5769 N := Expr;
5770 P := Parent (Expr);
5771
5772 if Nkind (P) = N_Parameter_Association then
5773 N := P;
5774 P := Parent (N);
5775 end if;
5776
5777 -- Only need to worry if we are argument of a procedure call
5778 -- since functions don't have out parameters. If this is an
5779 -- indirect or dispatching call, get signature from the
5780 -- subprogram type.
5781
5782 if Nkind (P) = N_Procedure_Call_Statement then
5783 L := Parameter_Associations (P);
5784
5785 if Is_Entity_Name (Name (P)) then
5786 E := Entity (Name (P));
5787 else
5788 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
5789 E := Etype (Name (P));
5790 end if;
5791
5792 -- Only need to worry if there are indeed actuals, and if
5793 -- this could be a procedure call, otherwise we cannot get a
5794 -- match (either we are not an argument, or the mode of the
5795 -- formal is not OUT). This test also filters out the
5796 -- generic case.
5797
5798 if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
5799
5800 -- This is the loop through parameters, looking for an
5801 -- OUT parameter for which we are the argument.
5802
5803 F := First_Formal (E);
5804 A := First (L);
5805 while Present (F) loop
5806 if Ekind (F) = E_Out_Parameter and then A = N then
5807 return;
5808 end if;
5809
5810 Next_Formal (F);
5811 Next (A);
5812 end loop;
5813 end if;
5814 end if;
5815 end;
5816 end if;
5817 end if;
5818
5819 -- If this is a boolean expression, only its elementary operands need
5820 -- checking: if they are valid, a boolean or short-circuit operation
5821 -- with them will be valid as well.
5822
5823 if Base_Type (Typ) = Standard_Boolean
5824 and then
5825 (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit)
5826 then
5827 return;
5828 end if;
5829
5830 -- If we fall through, a validity check is required
5831
5832 Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound);
5833
5834 if Is_Entity_Name (Expr)
5835 and then Safe_To_Capture_Value (Expr, Entity (Expr))
5836 then
5837 Set_Is_Known_Valid (Entity (Expr));
5838 end if;
5839 end Ensure_Valid;
5840
5841 ----------------------
5842 -- Expr_Known_Valid --
5843 ----------------------
5844
5845 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
5846 Typ : constant Entity_Id := Etype (Expr);
5847
5848 begin
5849 -- Non-scalar types are always considered valid, since they never give
5850 -- rise to the issues of erroneous or bounded error behavior that are
5851 -- the concern. In formal reference manual terms the notion of validity
5852 -- only applies to scalar types. Note that even when packed arrays are
5853 -- represented using modular types, they are still arrays semantically,
5854 -- so they are also always valid (in particular, the unused bits can be
5855 -- random rubbish without affecting the validity of the array value).
5856
5857 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then
5858 return True;
5859
5860 -- If no validity checking, then everything is considered valid
5861
5862 elsif not Validity_Checks_On then
5863 return True;
5864
5865 -- Floating-point types are considered valid unless floating-point
5866 -- validity checks have been specifically turned on.
5867
5868 elsif Is_Floating_Point_Type (Typ)
5869 and then not Validity_Check_Floating_Point
5870 then
5871 return True;
5872
5873 -- If the expression is the value of an object that is known to be
5874 -- valid, then clearly the expression value itself is valid.
5875
5876 elsif Is_Entity_Name (Expr)
5877 and then Is_Known_Valid (Entity (Expr))
5878
5879 -- Exclude volatile variables
5880
5881 and then not Treat_As_Volatile (Entity (Expr))
5882 then
5883 return True;
5884
5885 -- References to discriminants are always considered valid. The value
5886 -- of a discriminant gets checked when the object is built. Within the
5887 -- record, we consider it valid, and it is important to do so, since
5888 -- otherwise we can try to generate bogus validity checks which
5889 -- reference discriminants out of scope. Discriminants of concurrent
5890 -- types are excluded for the same reason.
5891
5892 elsif Is_Entity_Name (Expr)
5893 and then Denotes_Discriminant (Expr, Check_Concurrent => True)
5894 then
5895 return True;
5896
5897 -- If the type is one for which all values are known valid, then we are
5898 -- sure that the value is valid except in the slightly odd case where
5899 -- the expression is a reference to a variable whose size has been
5900 -- explicitly set to a value greater than the object size.
5901
5902 elsif Is_Known_Valid (Typ) then
5903 if Is_Entity_Name (Expr)
5904 and then Ekind (Entity (Expr)) = E_Variable
5905 and then Esize (Entity (Expr)) > Esize (Typ)
5906 then
5907 return False;
5908 else
5909 return True;
5910 end if;
5911
5912 -- Integer and character literals always have valid values, where
5913 -- appropriate these will be range checked in any case.
5914
5915 elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
5916 return True;
5917
5918 -- If we have a type conversion or a qualification of a known valid
5919 -- value, then the result will always be valid.
5920
5921 elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
5922 return Expr_Known_Valid (Expression (Expr));
5923
5924 -- Case of expression is a non-floating-point operator. In this case we
5925 -- can assume the result is valid the generated code for the operator
5926 -- will include whatever checks are needed (e.g. range checks) to ensure
5927 -- validity. This assumption does not hold for the floating-point case,
5928 -- since floating-point operators can generate Infinite or NaN results
5929 -- which are considered invalid.
5930
5931 -- Historical note: in older versions, the exemption of floating-point
5932 -- types from this assumption was done only in cases where the parent
5933 -- was an assignment, function call or parameter association. Presumably
5934 -- the idea was that in other contexts, the result would be checked
5935 -- elsewhere, but this list of cases was missing tests (at least the
5936 -- N_Object_Declaration case, as shown by a reported missing validity
5937 -- check), and it is not clear why function calls but not procedure
5938 -- calls were tested for. It really seems more accurate and much
5939 -- safer to recognize that expressions which are the result of a
5940 -- floating-point operator can never be assumed to be valid.
5941
5942 elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then
5943 return True;
5944
5945 -- The result of a membership test is always valid, since it is true or
5946 -- false, there are no other possibilities.
5947
5948 elsif Nkind (Expr) in N_Membership_Test then
5949 return True;
5950
5951 -- For all other cases, we do not know the expression is valid
5952
5953 else
5954 return False;
5955 end if;
5956 end Expr_Known_Valid;
5957
5958 ----------------
5959 -- Find_Check --
5960 ----------------
5961
5962 procedure Find_Check
5963 (Expr : Node_Id;
5964 Check_Type : Character;
5965 Target_Type : Entity_Id;
5966 Entry_OK : out Boolean;
5967 Check_Num : out Nat;
5968 Ent : out Entity_Id;
5969 Ofs : out Uint)
5970 is
5971 function Within_Range_Of
5972 (Target_Type : Entity_Id;
5973 Check_Type : Entity_Id) return Boolean;
5974 -- Given a requirement for checking a range against Target_Type, and
5975 -- and a range Check_Type against which a check has already been made,
5976 -- determines if the check against check type is sufficient to ensure
5977 -- that no check against Target_Type is required.
5978
5979 ---------------------
5980 -- Within_Range_Of --
5981 ---------------------
5982
5983 function Within_Range_Of
5984 (Target_Type : Entity_Id;
5985 Check_Type : Entity_Id) return Boolean
5986 is
5987 begin
5988 if Target_Type = Check_Type then
5989 return True;
5990
5991 else
5992 declare
5993 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
5994 Thi : constant Node_Id := Type_High_Bound (Target_Type);
5995 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
5996 Chi : constant Node_Id := Type_High_Bound (Check_Type);
5997
5998 begin
5999 if (Tlo = Clo
6000 or else (Compile_Time_Known_Value (Tlo)
6001 and then
6002 Compile_Time_Known_Value (Clo)
6003 and then
6004 Expr_Value (Clo) >= Expr_Value (Tlo)))
6005 and then
6006 (Thi = Chi
6007 or else (Compile_Time_Known_Value (Thi)
6008 and then
6009 Compile_Time_Known_Value (Chi)
6010 and then
6011 Expr_Value (Chi) <= Expr_Value (Clo)))
6012 then
6013 return True;
6014 else
6015 return False;
6016 end if;
6017 end;
6018 end if;
6019 end Within_Range_Of;
6020
6021 -- Start of processing for Find_Check
6022
6023 begin
6024 -- Establish default, in case no entry is found
6025
6026 Check_Num := 0;
6027
6028 -- Case of expression is simple entity reference
6029
6030 if Is_Entity_Name (Expr) then
6031 Ent := Entity (Expr);
6032 Ofs := Uint_0;
6033
6034 -- Case of expression is entity + known constant
6035
6036 elsif Nkind (Expr) = N_Op_Add
6037 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6038 and then Is_Entity_Name (Left_Opnd (Expr))
6039 then
6040 Ent := Entity (Left_Opnd (Expr));
6041 Ofs := Expr_Value (Right_Opnd (Expr));
6042
6043 -- Case of expression is entity - known constant
6044
6045 elsif Nkind (Expr) = N_Op_Subtract
6046 and then Compile_Time_Known_Value (Right_Opnd (Expr))
6047 and then Is_Entity_Name (Left_Opnd (Expr))
6048 then
6049 Ent := Entity (Left_Opnd (Expr));
6050 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
6051
6052 -- Any other expression is not of the right form
6053
6054 else
6055 Ent := Empty;
6056 Ofs := Uint_0;
6057 Entry_OK := False;
6058 return;
6059 end if;
6060
6061 -- Come here with expression of appropriate form, check if entity is an
6062 -- appropriate one for our purposes.
6063
6064 if (Ekind (Ent) = E_Variable
6065 or else Is_Constant_Object (Ent))
6066 and then not Is_Library_Level_Entity (Ent)
6067 then
6068 Entry_OK := True;
6069 else
6070 Entry_OK := False;
6071 return;
6072 end if;
6073
6074 -- See if there is matching check already
6075
6076 for J in reverse 1 .. Num_Saved_Checks loop
6077 declare
6078 SC : Saved_Check renames Saved_Checks (J);
6079 begin
6080 if SC.Killed = False
6081 and then SC.Entity = Ent
6082 and then SC.Offset = Ofs
6083 and then SC.Check_Type = Check_Type
6084 and then Within_Range_Of (Target_Type, SC.Target_Type)
6085 then
6086 Check_Num := J;
6087 return;
6088 end if;
6089 end;
6090 end loop;
6091
6092 -- If we fall through entry was not found
6093
6094 return;
6095 end Find_Check;
6096
6097 ---------------------------------
6098 -- Generate_Discriminant_Check --
6099 ---------------------------------
6100
6101 -- Note: the code for this procedure is derived from the
6102 -- Emit_Discriminant_Check Routine in trans.c.
6103
6104 procedure Generate_Discriminant_Check (N : Node_Id) is
6105 Loc : constant Source_Ptr := Sloc (N);
6106 Pref : constant Node_Id := Prefix (N);
6107 Sel : constant Node_Id := Selector_Name (N);
6108
6109 Orig_Comp : constant Entity_Id :=
6110 Original_Record_Component (Entity (Sel));
6111 -- The original component to be checked
6112
6113 Discr_Fct : constant Entity_Id :=
6114 Discriminant_Checking_Func (Orig_Comp);
6115 -- The discriminant checking function
6116
6117 Discr : Entity_Id;
6118 -- One discriminant to be checked in the type
6119
6120 Real_Discr : Entity_Id;
6121 -- Actual discriminant in the call
6122
6123 Pref_Type : Entity_Id;
6124 -- Type of relevant prefix (ignoring private/access stuff)
6125
6126 Args : List_Id;
6127 -- List of arguments for function call
6128
6129 Formal : Entity_Id;
6130 -- Keep track of the formal corresponding to the actual we build for
6131 -- each discriminant, in order to be able to perform the necessary type
6132 -- conversions.
6133
6134 Scomp : Node_Id;
6135 -- Selected component reference for checking function argument
6136
6137 begin
6138 Pref_Type := Etype (Pref);
6139
6140 -- Force evaluation of the prefix, so that it does not get evaluated
6141 -- twice (once for the check, once for the actual reference). Such a
6142 -- double evaluation is always a potential source of inefficiency, and
6143 -- is functionally incorrect in the volatile case, or when the prefix
6144 -- may have side effects. A nonvolatile entity or a component of a
6145 -- nonvolatile entity requires no evaluation.
6146
6147 if Is_Entity_Name (Pref) then
6148 if Treat_As_Volatile (Entity (Pref)) then
6149 Force_Evaluation (Pref, Name_Req => True);
6150 end if;
6151
6152 elsif Treat_As_Volatile (Etype (Pref)) then
6153 Force_Evaluation (Pref, Name_Req => True);
6154
6155 elsif Nkind (Pref) = N_Selected_Component
6156 and then Is_Entity_Name (Prefix (Pref))
6157 then
6158 null;
6159
6160 else
6161 Force_Evaluation (Pref, Name_Req => True);
6162 end if;
6163
6164 -- For a tagged type, use the scope of the original component to
6165 -- obtain the type, because ???
6166
6167 if Is_Tagged_Type (Scope (Orig_Comp)) then
6168 Pref_Type := Scope (Orig_Comp);
6169
6170 -- For an untagged derived type, use the discriminants of the parent
6171 -- which have been renamed in the derivation, possibly by a one-to-many
6172 -- discriminant constraint. For untagged type, initially get the Etype
6173 -- of the prefix
6174
6175 else
6176 if Is_Derived_Type (Pref_Type)
6177 and then Number_Discriminants (Pref_Type) /=
6178 Number_Discriminants (Etype (Base_Type (Pref_Type)))
6179 then
6180 Pref_Type := Etype (Base_Type (Pref_Type));
6181 end if;
6182 end if;
6183
6184 -- We definitely should have a checking function, This routine should
6185 -- not be called if no discriminant checking function is present.
6186
6187 pragma Assert (Present (Discr_Fct));
6188
6189 -- Create the list of the actual parameters for the call. This list
6190 -- is the list of the discriminant fields of the record expression to
6191 -- be discriminant checked.
6192
6193 Args := New_List;
6194 Formal := First_Formal (Discr_Fct);
6195 Discr := First_Discriminant (Pref_Type);
6196 while Present (Discr) loop
6197
6198 -- If we have a corresponding discriminant field, and a parent
6199 -- subtype is present, then we want to use the corresponding
6200 -- discriminant since this is the one with the useful value.
6201
6202 if Present (Corresponding_Discriminant (Discr))
6203 and then Ekind (Pref_Type) = E_Record_Type
6204 and then Present (Parent_Subtype (Pref_Type))
6205 then
6206 Real_Discr := Corresponding_Discriminant (Discr);
6207 else
6208 Real_Discr := Discr;
6209 end if;
6210
6211 -- Construct the reference to the discriminant
6212
6213 Scomp :=
6214 Make_Selected_Component (Loc,
6215 Prefix =>
6216 Unchecked_Convert_To (Pref_Type,
6217 Duplicate_Subexpr (Pref)),
6218 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
6219
6220 -- Manually analyze and resolve this selected component. We really
6221 -- want it just as it appears above, and do not want the expander
6222 -- playing discriminal games etc with this reference. Then we append
6223 -- the argument to the list we are gathering.
6224
6225 Set_Etype (Scomp, Etype (Real_Discr));
6226 Set_Analyzed (Scomp, True);
6227 Append_To (Args, Convert_To (Etype (Formal), Scomp));
6228
6229 Next_Formal_With_Extras (Formal);
6230 Next_Discriminant (Discr);
6231 end loop;
6232
6233 -- Now build and insert the call
6234
6235 Insert_Action (N,
6236 Make_Raise_Constraint_Error (Loc,
6237 Condition =>
6238 Make_Function_Call (Loc,
6239 Name => New_Occurrence_Of (Discr_Fct, Loc),
6240 Parameter_Associations => Args),
6241 Reason => CE_Discriminant_Check_Failed));
6242 end Generate_Discriminant_Check;
6243
6244 ---------------------------
6245 -- Generate_Index_Checks --
6246 ---------------------------
6247
6248 procedure Generate_Index_Checks (N : Node_Id) is
6249
6250 function Entity_Of_Prefix return Entity_Id;
6251 -- Returns the entity of the prefix of N (or Empty if not found)
6252
6253 ----------------------
6254 -- Entity_Of_Prefix --
6255 ----------------------
6256
6257 function Entity_Of_Prefix return Entity_Id is
6258 P : Node_Id;
6259
6260 begin
6261 P := Prefix (N);
6262 while not Is_Entity_Name (P) loop
6263 if not Nkind_In (P, N_Selected_Component,
6264 N_Indexed_Component)
6265 then
6266 return Empty;
6267 end if;
6268
6269 P := Prefix (P);
6270 end loop;
6271
6272 return Entity (P);
6273 end Entity_Of_Prefix;
6274
6275 -- Local variables
6276
6277 Loc : constant Source_Ptr := Sloc (N);
6278 A : constant Node_Id := Prefix (N);
6279 A_Ent : constant Entity_Id := Entity_Of_Prefix;
6280 Sub : Node_Id;
6281
6282 -- Start of processing for Generate_Index_Checks
6283
6284 begin
6285 -- Ignore call if the prefix is not an array since we have a serious
6286 -- error in the sources. Ignore it also if index checks are suppressed
6287 -- for array object or type.
6288
6289 if not Is_Array_Type (Etype (A))
6290 or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent))
6291 or else Index_Checks_Suppressed (Etype (A))
6292 then
6293 return;
6294
6295 -- The indexed component we are dealing with contains 'Loop_Entry in its
6296 -- prefix. This case arises when analysis has determined that constructs
6297 -- such as
6298
6299 -- Prefix'Loop_Entry (Expr)
6300 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6301
6302 -- require rewriting for error detection purposes. A side effect of this
6303 -- action is the generation of index checks that mention 'Loop_Entry.
6304 -- Delay the generation of the check until 'Loop_Entry has been properly
6305 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6306
6307 elsif Nkind (Prefix (N)) = N_Attribute_Reference
6308 and then Attribute_Name (Prefix (N)) = Name_Loop_Entry
6309 then
6310 return;
6311 end if;
6312
6313 -- Generate a raise of constraint error with the appropriate reason and
6314 -- a condition of the form:
6315
6316 -- Base_Type (Sub) not in Array'Range (Subscript)
6317
6318 -- Note that the reason we generate the conversion to the base type here
6319 -- is that we definitely want the range check to take place, even if it
6320 -- looks like the subtype is OK. Optimization considerations that allow
6321 -- us to omit the check have already been taken into account in the
6322 -- setting of the Do_Range_Check flag earlier on.
6323
6324 Sub := First (Expressions (N));
6325
6326 -- Handle string literals
6327
6328 if Ekind (Etype (A)) = E_String_Literal_Subtype then
6329 if Do_Range_Check (Sub) then
6330 Set_Do_Range_Check (Sub, False);
6331
6332 -- For string literals we obtain the bounds of the string from the
6333 -- associated subtype.
6334
6335 Insert_Action (N,
6336 Make_Raise_Constraint_Error (Loc,
6337 Condition =>
6338 Make_Not_In (Loc,
6339 Left_Opnd =>
6340 Convert_To (Base_Type (Etype (Sub)),
6341 Duplicate_Subexpr_Move_Checks (Sub)),
6342 Right_Opnd =>
6343 Make_Attribute_Reference (Loc,
6344 Prefix => New_Occurrence_Of (Etype (A), Loc),
6345 Attribute_Name => Name_Range)),
6346 Reason => CE_Index_Check_Failed));
6347 end if;
6348
6349 -- General case
6350
6351 else
6352 declare
6353 A_Idx : Node_Id := Empty;
6354 A_Range : Node_Id;
6355 Ind : Nat;
6356 Num : List_Id;
6357 Range_N : Node_Id;
6358
6359 begin
6360 A_Idx := First_Index (Etype (A));
6361 Ind := 1;
6362 while Present (Sub) loop
6363 if Do_Range_Check (Sub) then
6364 Set_Do_Range_Check (Sub, False);
6365
6366 -- Force evaluation except for the case of a simple name of
6367 -- a nonvolatile entity.
6368
6369 if not Is_Entity_Name (Sub)
6370 or else Treat_As_Volatile (Entity (Sub))
6371 then
6372 Force_Evaluation (Sub);
6373 end if;
6374
6375 if Nkind (A_Idx) = N_Range then
6376 A_Range := A_Idx;
6377
6378 elsif Nkind (A_Idx) = N_Identifier
6379 or else Nkind (A_Idx) = N_Expanded_Name
6380 then
6381 A_Range := Scalar_Range (Entity (A_Idx));
6382
6383 else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication);
6384 A_Range := Range_Expression (Constraint (A_Idx));
6385 end if;
6386
6387 -- For array objects with constant bounds we can generate
6388 -- the index check using the bounds of the type of the index
6389
6390 if Present (A_Ent)
6391 and then Ekind (A_Ent) = E_Variable
6392 and then Is_Constant_Bound (Low_Bound (A_Range))
6393 and then Is_Constant_Bound (High_Bound (A_Range))
6394 then
6395 Range_N :=
6396 Make_Attribute_Reference (Loc,
6397 Prefix =>
6398 New_Occurrence_Of (Etype (A_Idx), Loc),
6399 Attribute_Name => Name_Range);
6400
6401 -- For arrays with non-constant bounds we cannot generate
6402 -- the index check using the bounds of the type of the index
6403 -- since it may reference discriminants of some enclosing
6404 -- type. We obtain the bounds directly from the prefix
6405 -- object.
6406
6407 else
6408 if Ind = 1 then
6409 Num := No_List;
6410 else
6411 Num := New_List (Make_Integer_Literal (Loc, Ind));
6412 end if;
6413
6414 Range_N :=
6415 Make_Attribute_Reference (Loc,
6416 Prefix =>
6417 Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
6418 Attribute_Name => Name_Range,
6419 Expressions => Num);
6420 end if;
6421
6422 Insert_Action (N,
6423 Make_Raise_Constraint_Error (Loc,
6424 Condition =>
6425 Make_Not_In (Loc,
6426 Left_Opnd =>
6427 Convert_To (Base_Type (Etype (Sub)),
6428 Duplicate_Subexpr_Move_Checks (Sub)),
6429 Right_Opnd => Range_N),
6430 Reason => CE_Index_Check_Failed));
6431 end if;
6432
6433 A_Idx := Next_Index (A_Idx);
6434 Ind := Ind + 1;
6435 Next (Sub);
6436 end loop;
6437 end;
6438 end if;
6439 end Generate_Index_Checks;
6440
6441 --------------------------
6442 -- Generate_Range_Check --
6443 --------------------------
6444
6445 procedure Generate_Range_Check
6446 (N : Node_Id;
6447 Target_Type : Entity_Id;
6448 Reason : RT_Exception_Code)
6449 is
6450 Loc : constant Source_Ptr := Sloc (N);
6451 Source_Type : constant Entity_Id := Etype (N);
6452 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
6453 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
6454
6455 procedure Convert_And_Check_Range;
6456 -- Convert the conversion operand to the target base type and save in
6457 -- a temporary. Then check the converted value against the range of the
6458 -- target subtype.
6459
6460 -----------------------------
6461 -- Convert_And_Check_Range --
6462 -----------------------------
6463
6464 procedure Convert_And_Check_Range is
6465 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6466
6467 begin
6468 -- We make a temporary to hold the value of the converted value
6469 -- (converted to the base type), and then do the test against this
6470 -- temporary. The conversion itself is replaced by an occurrence of
6471 -- Tnn and followed by the explicit range check. Note that checks
6472 -- are suppressed for this code, since we don't want a recursive
6473 -- range check popping up.
6474
6475 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6476 -- [constraint_error when Tnn not in Target_Type]
6477
6478 Insert_Actions (N, New_List (
6479 Make_Object_Declaration (Loc,
6480 Defining_Identifier => Tnn,
6481 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
6482 Constant_Present => True,
6483 Expression =>
6484 Make_Type_Conversion (Loc,
6485 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
6486 Expression => Duplicate_Subexpr (N))),
6487
6488 Make_Raise_Constraint_Error (Loc,
6489 Condition =>
6490 Make_Not_In (Loc,
6491 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6492 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6493 Reason => Reason)),
6494 Suppress => All_Checks);
6495
6496 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6497
6498 -- Set the type of N, because the declaration for Tnn might not
6499 -- be analyzed yet, as is the case if N appears within a record
6500 -- declaration, as a discriminant constraint or expression.
6501
6502 Set_Etype (N, Target_Base_Type);
6503 end Convert_And_Check_Range;
6504
6505 -- Start of processing for Generate_Range_Check
6506
6507 begin
6508 -- First special case, if the source type is already within the range
6509 -- of the target type, then no check is needed (probably we should have
6510 -- stopped Do_Range_Check from being set in the first place, but better
6511 -- late than never in preventing junk code and junk flag settings.
6512
6513 if In_Subrange_Of (Source_Type, Target_Type)
6514
6515 -- We do NOT apply this if the source node is a literal, since in this
6516 -- case the literal has already been labeled as having the subtype of
6517 -- the target.
6518
6519 and then not
6520 (Nkind_In (N, N_Integer_Literal, N_Real_Literal, N_Character_Literal)
6521 or else
6522 (Is_Entity_Name (N)
6523 and then Ekind (Entity (N)) = E_Enumeration_Literal))
6524 then
6525 Set_Do_Range_Check (N, False);
6526 return;
6527 end if;
6528
6529 -- Here a check is needed. If the expander is not active, or if we are
6530 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6531 -- are done. In both these cases, we just want to see the range check
6532 -- flag set, we do not want to generate the explicit range check code.
6533
6534 if GNATprove_Mode or else not Expander_Active then
6535 Set_Do_Range_Check (N, True);
6536 return;
6537 end if;
6538
6539 -- Here we will generate an explicit range check, so we don't want to
6540 -- set the Do_Range check flag, since the range check is taken care of
6541 -- by the code we will generate.
6542
6543 Set_Do_Range_Check (N, False);
6544
6545 -- Force evaluation of the node, so that it does not get evaluated twice
6546 -- (once for the check, once for the actual reference). Such a double
6547 -- evaluation is always a potential source of inefficiency, and is
6548 -- functionally incorrect in the volatile case.
6549
6550 if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then
6551 Force_Evaluation (N);
6552 end if;
6553
6554 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6555 -- the same since in this case we can simply do a direct check of the
6556 -- value of N against the bounds of Target_Type.
6557
6558 -- [constraint_error when N not in Target_Type]
6559
6560 -- Note: this is by far the most common case, for example all cases of
6561 -- checks on the RHS of assignments are in this category, but not all
6562 -- cases are like this. Notably conversions can involve two types.
6563
6564 if Source_Base_Type = Target_Base_Type then
6565
6566 -- Insert the explicit range check. Note that we suppress checks for
6567 -- this code, since we don't want a recursive range check popping up.
6568
6569 Insert_Action (N,
6570 Make_Raise_Constraint_Error (Loc,
6571 Condition =>
6572 Make_Not_In (Loc,
6573 Left_Opnd => Duplicate_Subexpr (N),
6574 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
6575 Reason => Reason),
6576 Suppress => All_Checks);
6577
6578 -- Next test for the case where the target type is within the bounds
6579 -- of the base type of the source type, since in this case we can
6580 -- simply convert these bounds to the base type of T to do the test.
6581
6582 -- [constraint_error when N not in
6583 -- Source_Base_Type (Target_Type'First)
6584 -- ..
6585 -- Source_Base_Type(Target_Type'Last))]
6586
6587 -- The conversions will always work and need no check
6588
6589 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6590 -- of converting from an enumeration value to an integer type, such as
6591 -- occurs for the case of generating a range check on Enum'Val(Exp)
6592 -- (which used to be handled by gigi). This is OK, since the conversion
6593 -- itself does not require a check.
6594
6595 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
6596
6597 -- Insert the explicit range check. Note that we suppress checks for
6598 -- this code, since we don't want a recursive range check popping up.
6599
6600 if Is_Discrete_Type (Source_Base_Type)
6601 and then
6602 Is_Discrete_Type (Target_Base_Type)
6603 then
6604 Insert_Action (N,
6605 Make_Raise_Constraint_Error (Loc,
6606 Condition =>
6607 Make_Not_In (Loc,
6608 Left_Opnd => Duplicate_Subexpr (N),
6609
6610 Right_Opnd =>
6611 Make_Range (Loc,
6612 Low_Bound =>
6613 Unchecked_Convert_To (Source_Base_Type,
6614 Make_Attribute_Reference (Loc,
6615 Prefix =>
6616 New_Occurrence_Of (Target_Type, Loc),
6617 Attribute_Name => Name_First)),
6618
6619 High_Bound =>
6620 Unchecked_Convert_To (Source_Base_Type,
6621 Make_Attribute_Reference (Loc,
6622 Prefix =>
6623 New_Occurrence_Of (Target_Type, Loc),
6624 Attribute_Name => Name_Last)))),
6625 Reason => Reason),
6626 Suppress => All_Checks);
6627
6628 -- For conversions involving at least one type that is not discrete,
6629 -- first convert to target type and then generate the range check.
6630 -- This avoids problems with values that are close to a bound of the
6631 -- target type that would fail a range check when done in a larger
6632 -- source type before converting but would pass if converted with
6633 -- rounding and then checked (such as in float-to-float conversions).
6634
6635 else
6636 Convert_And_Check_Range;
6637 end if;
6638
6639 -- Note that at this stage we now that the Target_Base_Type is not in
6640 -- the range of the Source_Base_Type (since even the Target_Type itself
6641 -- is not in this range). It could still be the case that Source_Type is
6642 -- in range of the target base type since we have not checked that case.
6643
6644 -- If that is the case, we can freely convert the source to the target,
6645 -- and then test the target result against the bounds.
6646
6647 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
6648 Convert_And_Check_Range;
6649
6650 -- At this stage, we know that we have two scalar types, which are
6651 -- directly convertible, and where neither scalar type has a base
6652 -- range that is in the range of the other scalar type.
6653
6654 -- The only way this can happen is with a signed and unsigned type.
6655 -- So test for these two cases:
6656
6657 else
6658 -- Case of the source is unsigned and the target is signed
6659
6660 if Is_Unsigned_Type (Source_Base_Type)
6661 and then not Is_Unsigned_Type (Target_Base_Type)
6662 then
6663 -- If the source is unsigned and the target is signed, then we
6664 -- know that the source is not shorter than the target (otherwise
6665 -- the source base type would be in the target base type range).
6666
6667 -- In other words, the unsigned type is either the same size as
6668 -- the target, or it is larger. It cannot be smaller.
6669
6670 pragma Assert
6671 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
6672
6673 -- We only need to check the low bound if the low bound of the
6674 -- target type is non-negative. If the low bound of the target
6675 -- type is negative, then we know that we will fit fine.
6676
6677 -- If the high bound of the target type is negative, then we
6678 -- know we have a constraint error, since we can't possibly
6679 -- have a negative source.
6680
6681 -- With these two checks out of the way, we can do the check
6682 -- using the source type safely
6683
6684 -- This is definitely the most annoying case.
6685
6686 -- [constraint_error
6687 -- when (Target_Type'First >= 0
6688 -- and then
6689 -- N < Source_Base_Type (Target_Type'First))
6690 -- or else Target_Type'Last < 0
6691 -- or else N > Source_Base_Type (Target_Type'Last)];
6692
6693 -- We turn off all checks since we know that the conversions
6694 -- will work fine, given the guards for negative values.
6695
6696 Insert_Action (N,
6697 Make_Raise_Constraint_Error (Loc,
6698 Condition =>
6699 Make_Or_Else (Loc,
6700 Make_Or_Else (Loc,
6701 Left_Opnd =>
6702 Make_And_Then (Loc,
6703 Left_Opnd => Make_Op_Ge (Loc,
6704 Left_Opnd =>
6705 Make_Attribute_Reference (Loc,
6706 Prefix =>
6707 New_Occurrence_Of (Target_Type, Loc),
6708 Attribute_Name => Name_First),
6709 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6710
6711 Right_Opnd =>
6712 Make_Op_Lt (Loc,
6713 Left_Opnd => Duplicate_Subexpr (N),
6714 Right_Opnd =>
6715 Convert_To (Source_Base_Type,
6716 Make_Attribute_Reference (Loc,
6717 Prefix =>
6718 New_Occurrence_Of (Target_Type, Loc),
6719 Attribute_Name => Name_First)))),
6720
6721 Right_Opnd =>
6722 Make_Op_Lt (Loc,
6723 Left_Opnd =>
6724 Make_Attribute_Reference (Loc,
6725 Prefix => New_Occurrence_Of (Target_Type, Loc),
6726 Attribute_Name => Name_Last),
6727 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
6728
6729 Right_Opnd =>
6730 Make_Op_Gt (Loc,
6731 Left_Opnd => Duplicate_Subexpr (N),
6732 Right_Opnd =>
6733 Convert_To (Source_Base_Type,
6734 Make_Attribute_Reference (Loc,
6735 Prefix => New_Occurrence_Of (Target_Type, Loc),
6736 Attribute_Name => Name_Last)))),
6737
6738 Reason => Reason),
6739 Suppress => All_Checks);
6740
6741 -- Only remaining possibility is that the source is signed and
6742 -- the target is unsigned.
6743
6744 else
6745 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
6746 and then Is_Unsigned_Type (Target_Base_Type));
6747
6748 -- If the source is signed and the target is unsigned, then we
6749 -- know that the target is not shorter than the source (otherwise
6750 -- the target base type would be in the source base type range).
6751
6752 -- In other words, the unsigned type is either the same size as
6753 -- the target, or it is larger. It cannot be smaller.
6754
6755 -- Clearly we have an error if the source value is negative since
6756 -- no unsigned type can have negative values. If the source type
6757 -- is non-negative, then the check can be done using the target
6758 -- type.
6759
6760 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6761
6762 -- [constraint_error
6763 -- when N < 0 or else Tnn not in Target_Type];
6764
6765 -- We turn off all checks for the conversion of N to the target
6766 -- base type, since we generate the explicit check to ensure that
6767 -- the value is non-negative
6768
6769 declare
6770 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6771
6772 begin
6773 Insert_Actions (N, New_List (
6774 Make_Object_Declaration (Loc,
6775 Defining_Identifier => Tnn,
6776 Object_Definition =>
6777 New_Occurrence_Of (Target_Base_Type, Loc),
6778 Constant_Present => True,
6779 Expression =>
6780 Make_Unchecked_Type_Conversion (Loc,
6781 Subtype_Mark =>
6782 New_Occurrence_Of (Target_Base_Type, Loc),
6783 Expression => Duplicate_Subexpr (N))),
6784
6785 Make_Raise_Constraint_Error (Loc,
6786 Condition =>
6787 Make_Or_Else (Loc,
6788 Left_Opnd =>
6789 Make_Op_Lt (Loc,
6790 Left_Opnd => Duplicate_Subexpr (N),
6791 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
6792
6793 Right_Opnd =>
6794 Make_Not_In (Loc,
6795 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6796 Right_Opnd =>
6797 New_Occurrence_Of (Target_Type, Loc))),
6798
6799 Reason => Reason)),
6800 Suppress => All_Checks);
6801
6802 -- Set the Etype explicitly, because Insert_Actions may have
6803 -- placed the declaration in the freeze list for an enclosing
6804 -- construct, and thus it is not analyzed yet.
6805
6806 Set_Etype (Tnn, Target_Base_Type);
6807 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6808 end;
6809 end if;
6810 end if;
6811 end Generate_Range_Check;
6812
6813 ------------------
6814 -- Get_Check_Id --
6815 ------------------
6816
6817 function Get_Check_Id (N : Name_Id) return Check_Id is
6818 begin
6819 -- For standard check name, we can do a direct computation
6820
6821 if N in First_Check_Name .. Last_Check_Name then
6822 return Check_Id (N - (First_Check_Name - 1));
6823
6824 -- For non-standard names added by pragma Check_Name, search table
6825
6826 else
6827 for J in All_Checks + 1 .. Check_Names.Last loop
6828 if Check_Names.Table (J) = N then
6829 return J;
6830 end if;
6831 end loop;
6832 end if;
6833
6834 -- No matching name found
6835
6836 return No_Check_Id;
6837 end Get_Check_Id;
6838
6839 ---------------------
6840 -- Get_Discriminal --
6841 ---------------------
6842
6843 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
6844 Loc : constant Source_Ptr := Sloc (E);
6845 D : Entity_Id;
6846 Sc : Entity_Id;
6847
6848 begin
6849 -- The bound can be a bona fide parameter of a protected operation,
6850 -- rather than a prival encoded as an in-parameter.
6851
6852 if No (Discriminal_Link (Entity (Bound))) then
6853 return Bound;
6854 end if;
6855
6856 -- Climb the scope stack looking for an enclosing protected type. If
6857 -- we run out of scopes, return the bound itself.
6858
6859 Sc := Scope (E);
6860 while Present (Sc) loop
6861 if Sc = Standard_Standard then
6862 return Bound;
6863 elsif Ekind (Sc) = E_Protected_Type then
6864 exit;
6865 end if;
6866
6867 Sc := Scope (Sc);
6868 end loop;
6869
6870 D := First_Discriminant (Sc);
6871 while Present (D) loop
6872 if Chars (D) = Chars (Bound) then
6873 return New_Occurrence_Of (Discriminal (D), Loc);
6874 end if;
6875
6876 Next_Discriminant (D);
6877 end loop;
6878
6879 return Bound;
6880 end Get_Discriminal;
6881
6882 ----------------------
6883 -- Get_Range_Checks --
6884 ----------------------
6885
6886 function Get_Range_Checks
6887 (Ck_Node : Node_Id;
6888 Target_Typ : Entity_Id;
6889 Source_Typ : Entity_Id := Empty;
6890 Warn_Node : Node_Id := Empty) return Check_Result
6891 is
6892 begin
6893 return
6894 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
6895 end Get_Range_Checks;
6896
6897 ------------------
6898 -- Guard_Access --
6899 ------------------
6900
6901 function Guard_Access
6902 (Cond : Node_Id;
6903 Loc : Source_Ptr;
6904 Ck_Node : Node_Id) return Node_Id
6905 is
6906 begin
6907 if Nkind (Cond) = N_Or_Else then
6908 Set_Paren_Count (Cond, 1);
6909 end if;
6910
6911 if Nkind (Ck_Node) = N_Allocator then
6912 return Cond;
6913
6914 else
6915 return
6916 Make_And_Then (Loc,
6917 Left_Opnd =>
6918 Make_Op_Ne (Loc,
6919 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
6920 Right_Opnd => Make_Null (Loc)),
6921 Right_Opnd => Cond);
6922 end if;
6923 end Guard_Access;
6924
6925 -----------------------------
6926 -- Index_Checks_Suppressed --
6927 -----------------------------
6928
6929 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
6930 begin
6931 if Present (E) and then Checks_May_Be_Suppressed (E) then
6932 return Is_Check_Suppressed (E, Index_Check);
6933 else
6934 return Scope_Suppress.Suppress (Index_Check);
6935 end if;
6936 end Index_Checks_Suppressed;
6937
6938 ----------------
6939 -- Initialize --
6940 ----------------
6941
6942 procedure Initialize is
6943 begin
6944 for J in Determine_Range_Cache_N'Range loop
6945 Determine_Range_Cache_N (J) := Empty;
6946 end loop;
6947
6948 Check_Names.Init;
6949
6950 for J in Int range 1 .. All_Checks loop
6951 Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
6952 end loop;
6953 end Initialize;
6954
6955 -------------------------
6956 -- Insert_Range_Checks --
6957 -------------------------
6958
6959 procedure Insert_Range_Checks
6960 (Checks : Check_Result;
6961 Node : Node_Id;
6962 Suppress_Typ : Entity_Id;
6963 Static_Sloc : Source_Ptr := No_Location;
6964 Flag_Node : Node_Id := Empty;
6965 Do_Before : Boolean := False)
6966 is
6967 Internal_Flag_Node : Node_Id := Flag_Node;
6968 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
6969
6970 Check_Node : Node_Id;
6971 Checks_On : constant Boolean :=
6972 (not Index_Checks_Suppressed (Suppress_Typ))
6973 or else (not Range_Checks_Suppressed (Suppress_Typ));
6974
6975 begin
6976 -- For now we just return if Checks_On is false, however this should be
6977 -- enhanced to check for an always True value in the condition and to
6978 -- generate a compilation warning???
6979
6980 if not Expander_Active or not Checks_On then
6981 return;
6982 end if;
6983
6984 if Static_Sloc = No_Location then
6985 Internal_Static_Sloc := Sloc (Node);
6986 end if;
6987
6988 if No (Flag_Node) then
6989 Internal_Flag_Node := Node;
6990 end if;
6991
6992 for J in 1 .. 2 loop
6993 exit when No (Checks (J));
6994
6995 if Nkind (Checks (J)) = N_Raise_Constraint_Error
6996 and then Present (Condition (Checks (J)))
6997 then
6998 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
6999 Check_Node := Checks (J);
7000 Mark_Rewrite_Insertion (Check_Node);
7001
7002 if Do_Before then
7003 Insert_Before_And_Analyze (Node, Check_Node);
7004 else
7005 Insert_After_And_Analyze (Node, Check_Node);
7006 end if;
7007
7008 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
7009 end if;
7010
7011 else
7012 Check_Node :=
7013 Make_Raise_Constraint_Error (Internal_Static_Sloc,
7014 Reason => CE_Range_Check_Failed);
7015 Mark_Rewrite_Insertion (Check_Node);
7016
7017 if Do_Before then
7018 Insert_Before_And_Analyze (Node, Check_Node);
7019 else
7020 Insert_After_And_Analyze (Node, Check_Node);
7021 end if;
7022 end if;
7023 end loop;
7024 end Insert_Range_Checks;
7025
7026 ------------------------
7027 -- Insert_Valid_Check --
7028 ------------------------
7029
7030 procedure Insert_Valid_Check
7031 (Expr : Node_Id;
7032 Related_Id : Entity_Id := Empty;
7033 Is_Low_Bound : Boolean := False;
7034 Is_High_Bound : Boolean := False)
7035 is
7036 Loc : constant Source_Ptr := Sloc (Expr);
7037 Typ : constant Entity_Id := Etype (Expr);
7038 Exp : Node_Id;
7039
7040 begin
7041 -- Do not insert if checks off, or if not checking validity or if
7042 -- expression is known to be valid.
7043
7044 if not Validity_Checks_On
7045 or else Range_Or_Validity_Checks_Suppressed (Expr)
7046 or else Expr_Known_Valid (Expr)
7047 then
7048 return;
7049 end if;
7050
7051 -- Do not insert checks within a predicate function. This will arise
7052 -- if the current unit and the predicate function are being compiled
7053 -- with validity checks enabled.
7054
7055 if Present (Predicate_Function (Typ))
7056 and then Current_Scope = Predicate_Function (Typ)
7057 then
7058 return;
7059 end if;
7060
7061 -- If the expression is a packed component of a modular type of the
7062 -- right size, the data is always valid.
7063
7064 if Nkind (Expr) = N_Selected_Component
7065 and then Present (Component_Clause (Entity (Selector_Name (Expr))))
7066 and then Is_Modular_Integer_Type (Typ)
7067 and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr)))
7068 then
7069 return;
7070 end if;
7071
7072 -- If we have a checked conversion, then validity check applies to
7073 -- the expression inside the conversion, not the result, since if
7074 -- the expression inside is valid, then so is the conversion result.
7075
7076 Exp := Expr;
7077 while Nkind (Exp) = N_Type_Conversion loop
7078 Exp := Expression (Exp);
7079 end loop;
7080
7081 -- We are about to insert the validity check for Exp. We save and
7082 -- reset the Do_Range_Check flag over this validity check, and then
7083 -- put it back for the final original reference (Exp may be rewritten).
7084
7085 declare
7086 DRC : constant Boolean := Do_Range_Check (Exp);
7087 PV : Node_Id;
7088 CE : Node_Id;
7089
7090 begin
7091 Set_Do_Range_Check (Exp, False);
7092
7093 -- Force evaluation to avoid multiple reads for atomic/volatile
7094
7095 -- Note: we set Name_Req to False. We used to set it to True, with
7096 -- the thinking that a name is required as the prefix of the 'Valid
7097 -- call, but in fact the check that the prefix of an attribute is
7098 -- a name is in the parser, and we just don't require it here.
7099 -- Moreover, when we set Name_Req to True, that interfered with the
7100 -- checking for Volatile, since we couldn't just capture the value.
7101
7102 if Is_Entity_Name (Exp)
7103 and then Is_Volatile (Entity (Exp))
7104 then
7105 -- Same reasoning as above for setting Name_Req to False
7106
7107 Force_Evaluation (Exp, Name_Req => False);
7108 end if;
7109
7110 -- Build the prefix for the 'Valid call
7111
7112 PV :=
7113 Duplicate_Subexpr_No_Checks
7114 (Exp => Exp,
7115 Name_Req => False,
7116 Related_Id => Related_Id,
7117 Is_Low_Bound => Is_Low_Bound,
7118 Is_High_Bound => Is_High_Bound);
7119
7120 -- A rather specialized test. If PV is an analyzed expression which
7121 -- is an indexed component of a packed array that has not been
7122 -- properly expanded, turn off its Analyzed flag to make sure it
7123 -- gets properly reexpanded. If the prefix is an access value,
7124 -- the dereference will be added later.
7125
7126 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7127 -- an analyze with the old parent pointer. This may point e.g. to
7128 -- a subprogram call, which deactivates this expansion.
7129
7130 if Analyzed (PV)
7131 and then Nkind (PV) = N_Indexed_Component
7132 and then Is_Array_Type (Etype (Prefix (PV)))
7133 and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV))))
7134 then
7135 Set_Analyzed (PV, False);
7136 end if;
7137
7138 -- Build the raise CE node to check for validity. We build a type
7139 -- qualification for the prefix, since it may not be of the form of
7140 -- a name, and we don't care in this context!
7141
7142 CE :=
7143 Make_Raise_Constraint_Error (Loc,
7144 Condition =>
7145 Make_Op_Not (Loc,
7146 Right_Opnd =>
7147 Make_Attribute_Reference (Loc,
7148 Prefix => PV,
7149 Attribute_Name => Name_Valid)),
7150 Reason => CE_Invalid_Data);
7151
7152 -- Insert the validity check. Note that we do this with validity
7153 -- checks turned off, to avoid recursion, we do not want validity
7154 -- checks on the validity checking code itself.
7155
7156 Insert_Action (Expr, CE, Suppress => Validity_Check);
7157
7158 -- If the expression is a reference to an element of a bit-packed
7159 -- array, then it is rewritten as a renaming declaration. If the
7160 -- expression is an actual in a call, it has not been expanded,
7161 -- waiting for the proper point at which to do it. The same happens
7162 -- with renamings, so that we have to force the expansion now. This
7163 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7164 -- and exp_ch6.adb.
7165
7166 if Is_Entity_Name (Exp)
7167 and then Nkind (Parent (Entity (Exp))) =
7168 N_Object_Renaming_Declaration
7169 then
7170 declare
7171 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
7172 begin
7173 if Nkind (Old_Exp) = N_Indexed_Component
7174 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
7175 then
7176 Expand_Packed_Element_Reference (Old_Exp);
7177 end if;
7178 end;
7179 end if;
7180
7181 -- Put back the Do_Range_Check flag on the resulting (possibly
7182 -- rewritten) expression.
7183
7184 -- Note: it might be thought that a validity check is not required
7185 -- when a range check is present, but that's not the case, because
7186 -- the back end is allowed to assume for the range check that the
7187 -- operand is within its declared range (an assumption that validity
7188 -- checking is all about NOT assuming).
7189
7190 -- Note: no need to worry about Possible_Local_Raise here, it will
7191 -- already have been called if original node has Do_Range_Check set.
7192
7193 Set_Do_Range_Check (Exp, DRC);
7194 end;
7195 end Insert_Valid_Check;
7196
7197 -------------------------------------
7198 -- Is_Signed_Integer_Arithmetic_Op --
7199 -------------------------------------
7200
7201 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
7202 begin
7203 case Nkind (N) is
7204 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
7205 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
7206 N_Op_Rem | N_Op_Subtract =>
7207 return Is_Signed_Integer_Type (Etype (N));
7208
7209 when N_If_Expression | N_Case_Expression =>
7210 return Is_Signed_Integer_Type (Etype (N));
7211
7212 when others =>
7213 return False;
7214 end case;
7215 end Is_Signed_Integer_Arithmetic_Op;
7216
7217 ----------------------------------
7218 -- Install_Null_Excluding_Check --
7219 ----------------------------------
7220
7221 procedure Install_Null_Excluding_Check (N : Node_Id) is
7222 Loc : constant Source_Ptr := Sloc (Parent (N));
7223 Typ : constant Entity_Id := Etype (N);
7224
7225 function Safe_To_Capture_In_Parameter_Value return Boolean;
7226 -- Determines if it is safe to capture Known_Non_Null status for an
7227 -- the entity referenced by node N. The caller ensures that N is indeed
7228 -- an entity name. It is safe to capture the non-null status for an IN
7229 -- parameter when the reference occurs within a declaration that is sure
7230 -- to be executed as part of the declarative region.
7231
7232 procedure Mark_Non_Null;
7233 -- After installation of check, if the node in question is an entity
7234 -- name, then mark this entity as non-null if possible.
7235
7236 function Safe_To_Capture_In_Parameter_Value return Boolean is
7237 E : constant Entity_Id := Entity (N);
7238 S : constant Entity_Id := Current_Scope;
7239 S_Par : Node_Id;
7240
7241 begin
7242 if Ekind (E) /= E_In_Parameter then
7243 return False;
7244 end if;
7245
7246 -- Two initial context checks. We must be inside a subprogram body
7247 -- with declarations and reference must not appear in nested scopes.
7248
7249 if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure)
7250 or else Scope (E) /= S
7251 then
7252 return False;
7253 end if;
7254
7255 S_Par := Parent (Parent (S));
7256
7257 if Nkind (S_Par) /= N_Subprogram_Body
7258 or else No (Declarations (S_Par))
7259 then
7260 return False;
7261 end if;
7262
7263 declare
7264 N_Decl : Node_Id;
7265 P : Node_Id;
7266
7267 begin
7268 -- Retrieve the declaration node of N (if any). Note that N
7269 -- may be a part of a complex initialization expression.
7270
7271 P := Parent (N);
7272 N_Decl := Empty;
7273 while Present (P) loop
7274
7275 -- If we have a short circuit form, and we are within the right
7276 -- hand expression, we return false, since the right hand side
7277 -- is not guaranteed to be elaborated.
7278
7279 if Nkind (P) in N_Short_Circuit
7280 and then N = Right_Opnd (P)
7281 then
7282 return False;
7283 end if;
7284
7285 -- Similarly, if we are in an if expression and not part of the
7286 -- condition, then we return False, since neither the THEN or
7287 -- ELSE dependent expressions will always be elaborated.
7288
7289 if Nkind (P) = N_If_Expression
7290 and then N /= First (Expressions (P))
7291 then
7292 return False;
7293 end if;
7294
7295 -- If within a case expression, and not part of the expression,
7296 -- then return False, since a particular dependent expression
7297 -- may not always be elaborated
7298
7299 if Nkind (P) = N_Case_Expression
7300 and then N /= Expression (P)
7301 then
7302 return False;
7303 end if;
7304
7305 -- While traversing the parent chain, if node N belongs to a
7306 -- statement, then it may never appear in a declarative region.
7307
7308 if Nkind (P) in N_Statement_Other_Than_Procedure_Call
7309 or else Nkind (P) = N_Procedure_Call_Statement
7310 then
7311 return False;
7312 end if;
7313
7314 -- If we are at a declaration, record it and exit
7315
7316 if Nkind (P) in N_Declaration
7317 and then Nkind (P) not in N_Subprogram_Specification
7318 then
7319 N_Decl := P;
7320 exit;
7321 end if;
7322
7323 P := Parent (P);
7324 end loop;
7325
7326 if No (N_Decl) then
7327 return False;
7328 end if;
7329
7330 return List_Containing (N_Decl) = Declarations (S_Par);
7331 end;
7332 end Safe_To_Capture_In_Parameter_Value;
7333
7334 -------------------
7335 -- Mark_Non_Null --
7336 -------------------
7337
7338 procedure Mark_Non_Null is
7339 begin
7340 -- Only case of interest is if node N is an entity name
7341
7342 if Is_Entity_Name (N) then
7343
7344 -- For sure, we want to clear an indication that this is known to
7345 -- be null, since if we get past this check, it definitely is not.
7346
7347 Set_Is_Known_Null (Entity (N), False);
7348
7349 -- We can mark the entity as known to be non-null if either it is
7350 -- safe to capture the value, or in the case of an IN parameter,
7351 -- which is a constant, if the check we just installed is in the
7352 -- declarative region of the subprogram body. In this latter case,
7353 -- a check is decisive for the rest of the body if the expression
7354 -- is sure to be elaborated, since we know we have to elaborate
7355 -- all declarations before executing the body.
7356
7357 -- Couldn't this always be part of Safe_To_Capture_Value ???
7358
7359 if Safe_To_Capture_Value (N, Entity (N))
7360 or else Safe_To_Capture_In_Parameter_Value
7361 then
7362 Set_Is_Known_Non_Null (Entity (N));
7363 end if;
7364 end if;
7365 end Mark_Non_Null;
7366
7367 -- Start of processing for Install_Null_Excluding_Check
7368
7369 begin
7370 pragma Assert (Is_Access_Type (Typ));
7371
7372 -- No check inside a generic, check will be emitted in instance
7373
7374 if Inside_A_Generic then
7375 return;
7376 end if;
7377
7378 -- No check needed if known to be non-null
7379
7380 if Known_Non_Null (N) then
7381 return;
7382 end if;
7383
7384 -- If known to be null, here is where we generate a compile time check
7385
7386 if Known_Null (N) then
7387
7388 -- Avoid generating warning message inside init procs. In SPARK mode
7389 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7390 -- since it will be turned into an error in any case.
7391
7392 if (not Inside_Init_Proc or else SPARK_Mode = On)
7393
7394 -- Do not emit the warning within a conditional expression,
7395 -- where the expression might not be evaluated, and the warning
7396 -- appear as extraneous noise.
7397
7398 and then not Within_Case_Or_If_Expression (N)
7399 then
7400 Apply_Compile_Time_Constraint_Error
7401 (N, "null value not allowed here??", CE_Access_Check_Failed);
7402
7403 -- Remaining cases, where we silently insert the raise
7404
7405 else
7406 Insert_Action (N,
7407 Make_Raise_Constraint_Error (Loc,
7408 Reason => CE_Access_Check_Failed));
7409 end if;
7410
7411 Mark_Non_Null;
7412 return;
7413 end if;
7414
7415 -- If entity is never assigned, for sure a warning is appropriate
7416
7417 if Is_Entity_Name (N) then
7418 Check_Unset_Reference (N);
7419 end if;
7420
7421 -- No check needed if checks are suppressed on the range. Note that we
7422 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7423 -- so, since the program is erroneous, but we don't like to casually
7424 -- propagate such conclusions from erroneosity).
7425
7426 if Access_Checks_Suppressed (Typ) then
7427 return;
7428 end if;
7429
7430 -- No check needed for access to concurrent record types generated by
7431 -- the expander. This is not just an optimization (though it does indeed
7432 -- remove junk checks). It also avoids generation of junk warnings.
7433
7434 if Nkind (N) in N_Has_Chars
7435 and then Chars (N) = Name_uObject
7436 and then Is_Concurrent_Record_Type
7437 (Directly_Designated_Type (Etype (N)))
7438 then
7439 return;
7440 end if;
7441
7442 -- No check needed in interface thunks since the runtime check is
7443 -- already performed at the caller side.
7444
7445 if Is_Thunk (Current_Scope) then
7446 return;
7447 end if;
7448
7449 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7450 -- the expander within exception handlers, since we know that the value
7451 -- can never be null.
7452
7453 -- Is this really the right way to do this? Normally we generate such
7454 -- code in the expander with checks off, and that's how we suppress this
7455 -- kind of junk check ???
7456
7457 if Nkind (N) = N_Function_Call
7458 and then Nkind (Name (N)) = N_Explicit_Dereference
7459 and then Nkind (Prefix (Name (N))) = N_Identifier
7460 and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
7461 then
7462 return;
7463 end if;
7464
7465 -- Otherwise install access check
7466
7467 Insert_Action (N,
7468 Make_Raise_Constraint_Error (Loc,
7469 Condition =>
7470 Make_Op_Eq (Loc,
7471 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
7472 Right_Opnd => Make_Null (Loc)),
7473 Reason => CE_Access_Check_Failed));
7474
7475 Mark_Non_Null;
7476 end Install_Null_Excluding_Check;
7477
7478 --------------------------
7479 -- Install_Static_Check --
7480 --------------------------
7481
7482 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
7483 Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
7484 Typ : constant Entity_Id := Etype (R_Cno);
7485
7486 begin
7487 Rewrite (R_Cno,
7488 Make_Raise_Constraint_Error (Loc,
7489 Reason => CE_Range_Check_Failed));
7490 Set_Analyzed (R_Cno);
7491 Set_Etype (R_Cno, Typ);
7492 Set_Raises_Constraint_Error (R_Cno);
7493 Set_Is_Static_Expression (R_Cno, Stat);
7494
7495 -- Now deal with possible local raise handling
7496
7497 Possible_Local_Raise (R_Cno, Standard_Constraint_Error);
7498 end Install_Static_Check;
7499
7500 -------------------------
7501 -- Is_Check_Suppressed --
7502 -------------------------
7503
7504 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
7505 Ptr : Suppress_Stack_Entry_Ptr;
7506
7507 begin
7508 -- First search the local entity suppress stack. We search this from the
7509 -- top of the stack down so that we get the innermost entry that applies
7510 -- to this case if there are nested entries.
7511
7512 Ptr := Local_Suppress_Stack_Top;
7513 while Ptr /= null loop
7514 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7515 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7516 then
7517 return Ptr.Suppress;
7518 end if;
7519
7520 Ptr := Ptr.Prev;
7521 end loop;
7522
7523 -- Now search the global entity suppress table for a matching entry.
7524 -- We also search this from the top down so that if there are multiple
7525 -- pragmas for the same entity, the last one applies (not clear what
7526 -- or whether the RM specifies this handling, but it seems reasonable).
7527
7528 Ptr := Global_Suppress_Stack_Top;
7529 while Ptr /= null loop
7530 if (Ptr.Entity = Empty or else Ptr.Entity = E)
7531 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
7532 then
7533 return Ptr.Suppress;
7534 end if;
7535
7536 Ptr := Ptr.Prev;
7537 end loop;
7538
7539 -- If we did not find a matching entry, then use the normal scope
7540 -- suppress value after all (actually this will be the global setting
7541 -- since it clearly was not overridden at any point). For a predefined
7542 -- check, we test the specific flag. For a user defined check, we check
7543 -- the All_Checks flag. The Overflow flag requires special handling to
7544 -- deal with the General vs Assertion case
7545
7546 if C = Overflow_Check then
7547 return Overflow_Checks_Suppressed (Empty);
7548 elsif C in Predefined_Check_Id then
7549 return Scope_Suppress.Suppress (C);
7550 else
7551 return Scope_Suppress.Suppress (All_Checks);
7552 end if;
7553 end Is_Check_Suppressed;
7554
7555 ---------------------
7556 -- Kill_All_Checks --
7557 ---------------------
7558
7559 procedure Kill_All_Checks is
7560 begin
7561 if Debug_Flag_CC then
7562 w ("Kill_All_Checks");
7563 end if;
7564
7565 -- We reset the number of saved checks to zero, and also modify all
7566 -- stack entries for statement ranges to indicate that the number of
7567 -- checks at each level is now zero.
7568
7569 Num_Saved_Checks := 0;
7570
7571 -- Note: the Int'Min here avoids any possibility of J being out of
7572 -- range when called from e.g. Conditional_Statements_Begin.
7573
7574 for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
7575 Saved_Checks_Stack (J) := 0;
7576 end loop;
7577 end Kill_All_Checks;
7578
7579 -----------------
7580 -- Kill_Checks --
7581 -----------------
7582
7583 procedure Kill_Checks (V : Entity_Id) is
7584 begin
7585 if Debug_Flag_CC then
7586 w ("Kill_Checks for entity", Int (V));
7587 end if;
7588
7589 for J in 1 .. Num_Saved_Checks loop
7590 if Saved_Checks (J).Entity = V then
7591 if Debug_Flag_CC then
7592 w (" Checks killed for saved check ", J);
7593 end if;
7594
7595 Saved_Checks (J).Killed := True;
7596 end if;
7597 end loop;
7598 end Kill_Checks;
7599
7600 ------------------------------
7601 -- Length_Checks_Suppressed --
7602 ------------------------------
7603
7604 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
7605 begin
7606 if Present (E) and then Checks_May_Be_Suppressed (E) then
7607 return Is_Check_Suppressed (E, Length_Check);
7608 else
7609 return Scope_Suppress.Suppress (Length_Check);
7610 end if;
7611 end Length_Checks_Suppressed;
7612
7613 -----------------------
7614 -- Make_Bignum_Block --
7615 -----------------------
7616
7617 function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is
7618 M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM);
7619 begin
7620 return
7621 Make_Block_Statement (Loc,
7622 Declarations =>
7623 New_List (Build_SS_Mark_Call (Loc, M)),
7624 Handled_Statement_Sequence =>
7625 Make_Handled_Sequence_Of_Statements (Loc,
7626 Statements => New_List (Build_SS_Release_Call (Loc, M))));
7627 end Make_Bignum_Block;
7628
7629 ----------------------------------
7630 -- Minimize_Eliminate_Overflows --
7631 ----------------------------------
7632
7633 -- This is a recursive routine that is called at the top of an expression
7634 -- tree to properly process overflow checking for a whole subtree by making
7635 -- recursive calls to process operands. This processing may involve the use
7636 -- of bignum or long long integer arithmetic, which will change the types
7637 -- of operands and results. That's why we can't do this bottom up (since
7638 -- it would interfere with semantic analysis).
7639
7640 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
7641 -- the operator expansion routines, as well as the expansion routines for
7642 -- if/case expression, do nothing (for the moment) except call the routine
7643 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
7644 -- routine does nothing for non top-level nodes, so at the point where the
7645 -- call is made for the top level node, the entire expression subtree has
7646 -- not been expanded, or processed for overflow. All that has to happen as
7647 -- a result of the top level call to this routine.
7648
7649 -- As noted above, the overflow processing works by making recursive calls
7650 -- for the operands, and figuring out what to do, based on the processing
7651 -- of these operands (e.g. if a bignum operand appears, the parent op has
7652 -- to be done in bignum mode), and the determined ranges of the operands.
7653
7654 -- After possible rewriting of a constituent subexpression node, a call is
7655 -- made to either reexpand the node (if nothing has changed) or reanalyze
7656 -- the node (if it has been modified by the overflow check processing). The
7657 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
7658 -- a recursive call into the whole overflow apparatus, an important rule
7659 -- for this call is that the overflow handling mode must be temporarily set
7660 -- to STRICT.
7661
7662 procedure Minimize_Eliminate_Overflows
7663 (N : Node_Id;
7664 Lo : out Uint;
7665 Hi : out Uint;
7666 Top_Level : Boolean)
7667 is
7668 Rtyp : constant Entity_Id := Etype (N);
7669 pragma Assert (Is_Signed_Integer_Type (Rtyp));
7670 -- Result type, must be a signed integer type
7671
7672 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
7673 pragma Assert (Check_Mode in Minimized_Or_Eliminated);
7674
7675 Loc : constant Source_Ptr := Sloc (N);
7676
7677 Rlo, Rhi : Uint;
7678 -- Ranges of values for right operand (operator case)
7679
7680 Llo, Lhi : Uint;
7681 -- Ranges of values for left operand (operator case)
7682
7683 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
7684 -- Operands and results are of this type when we convert
7685
7686 LLLo : constant Uint := Intval (Type_Low_Bound (LLIB));
7687 LLHi : constant Uint := Intval (Type_High_Bound (LLIB));
7688 -- Bounds of Long_Long_Integer
7689
7690 Binary : constant Boolean := Nkind (N) in N_Binary_Op;
7691 -- Indicates binary operator case
7692
7693 OK : Boolean;
7694 -- Used in call to Determine_Range
7695
7696 Bignum_Operands : Boolean;
7697 -- Set True if one or more operands is already of type Bignum, meaning
7698 -- that for sure (regardless of Top_Level setting) we are committed to
7699 -- doing the operation in Bignum mode (or in the case of a case or if
7700 -- expression, converting all the dependent expressions to Bignum).
7701
7702 Long_Long_Integer_Operands : Boolean;
7703 -- Set True if one or more operands is already of type Long_Long_Integer
7704 -- which means that if the result is known to be in the result type
7705 -- range, then we must convert such operands back to the result type.
7706
7707 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False);
7708 -- This is called when we have modified the node and we therefore need
7709 -- to reanalyze it. It is important that we reset the mode to STRICT for
7710 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7711 -- we would reenter this routine recursively which would not be good.
7712 -- The argument Suppress is set True if we also want to suppress
7713 -- overflow checking for the reexpansion (this is set when we know
7714 -- overflow is not possible). Typ is the type for the reanalysis.
7715
7716 procedure Reexpand (Suppress : Boolean := False);
7717 -- This is like Reanalyze, but does not do the Analyze step, it only
7718 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7719 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7720 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7721 -- Note that skipping reanalysis is not just an optimization, testing
7722 -- has showed up several complex cases in which reanalyzing an already
7723 -- analyzed node causes incorrect behavior.
7724
7725 function In_Result_Range return Boolean;
7726 -- Returns True iff Lo .. Hi are within range of the result type
7727
7728 procedure Max (A : in out Uint; B : Uint);
7729 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7730
7731 procedure Min (A : in out Uint; B : Uint);
7732 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7733
7734 ---------------------
7735 -- In_Result_Range --
7736 ---------------------
7737
7738 function In_Result_Range return Boolean is
7739 begin
7740 if Lo = No_Uint or else Hi = No_Uint then
7741 return False;
7742
7743 elsif Is_OK_Static_Subtype (Etype (N)) then
7744 return Lo >= Expr_Value (Type_Low_Bound (Rtyp))
7745 and then
7746 Hi <= Expr_Value (Type_High_Bound (Rtyp));
7747
7748 else
7749 return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp)))
7750 and then
7751 Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp)));
7752 end if;
7753 end In_Result_Range;
7754
7755 ---------
7756 -- Max --
7757 ---------
7758
7759 procedure Max (A : in out Uint; B : Uint) is
7760 begin
7761 if A = No_Uint or else B > A then
7762 A := B;
7763 end if;
7764 end Max;
7765
7766 ---------
7767 -- Min --
7768 ---------
7769
7770 procedure Min (A : in out Uint; B : Uint) is
7771 begin
7772 if A = No_Uint or else B < A then
7773 A := B;
7774 end if;
7775 end Min;
7776
7777 ---------------
7778 -- Reanalyze --
7779 ---------------
7780
7781 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is
7782 Svg : constant Overflow_Mode_Type :=
7783 Scope_Suppress.Overflow_Mode_General;
7784 Sva : constant Overflow_Mode_Type :=
7785 Scope_Suppress.Overflow_Mode_Assertions;
7786 Svo : constant Boolean :=
7787 Scope_Suppress.Suppress (Overflow_Check);
7788
7789 begin
7790 Scope_Suppress.Overflow_Mode_General := Strict;
7791 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7792
7793 if Suppress then
7794 Scope_Suppress.Suppress (Overflow_Check) := True;
7795 end if;
7796
7797 Analyze_And_Resolve (N, Typ);
7798
7799 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7800 Scope_Suppress.Overflow_Mode_General := Svg;
7801 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7802 end Reanalyze;
7803
7804 --------------
7805 -- Reexpand --
7806 --------------
7807
7808 procedure Reexpand (Suppress : Boolean := False) is
7809 Svg : constant Overflow_Mode_Type :=
7810 Scope_Suppress.Overflow_Mode_General;
7811 Sva : constant Overflow_Mode_Type :=
7812 Scope_Suppress.Overflow_Mode_Assertions;
7813 Svo : constant Boolean :=
7814 Scope_Suppress.Suppress (Overflow_Check);
7815
7816 begin
7817 Scope_Suppress.Overflow_Mode_General := Strict;
7818 Scope_Suppress.Overflow_Mode_Assertions := Strict;
7819 Set_Analyzed (N, False);
7820
7821 if Suppress then
7822 Scope_Suppress.Suppress (Overflow_Check) := True;
7823 end if;
7824
7825 Expand (N);
7826
7827 Scope_Suppress.Suppress (Overflow_Check) := Svo;
7828 Scope_Suppress.Overflow_Mode_General := Svg;
7829 Scope_Suppress.Overflow_Mode_Assertions := Sva;
7830 end Reexpand;
7831
7832 -- Start of processing for Minimize_Eliminate_Overflows
7833
7834 begin
7835 -- Case where we do not have a signed integer arithmetic operation
7836
7837 if not Is_Signed_Integer_Arithmetic_Op (N) then
7838
7839 -- Use the normal Determine_Range routine to get the range. We
7840 -- don't require operands to be valid, invalid values may result in
7841 -- rubbish results where the result has not been properly checked for
7842 -- overflow, that's fine.
7843
7844 Determine_Range (N, OK, Lo, Hi, Assume_Valid => False);
7845
7846 -- If Determine_Range did not work (can this in fact happen? Not
7847 -- clear but might as well protect), use type bounds.
7848
7849 if not OK then
7850 Lo := Intval (Type_Low_Bound (Base_Type (Etype (N))));
7851 Hi := Intval (Type_High_Bound (Base_Type (Etype (N))));
7852 end if;
7853
7854 -- If we don't have a binary operator, all we have to do is to set
7855 -- the Hi/Lo range, so we are done.
7856
7857 return;
7858
7859 -- Processing for if expression
7860
7861 elsif Nkind (N) = N_If_Expression then
7862 declare
7863 Then_DE : constant Node_Id := Next (First (Expressions (N)));
7864 Else_DE : constant Node_Id := Next (Then_DE);
7865
7866 begin
7867 Bignum_Operands := False;
7868
7869 Minimize_Eliminate_Overflows
7870 (Then_DE, Lo, Hi, Top_Level => False);
7871
7872 if Lo = No_Uint then
7873 Bignum_Operands := True;
7874 end if;
7875
7876 Minimize_Eliminate_Overflows
7877 (Else_DE, Rlo, Rhi, Top_Level => False);
7878
7879 if Rlo = No_Uint then
7880 Bignum_Operands := True;
7881 else
7882 Long_Long_Integer_Operands :=
7883 Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB;
7884
7885 Min (Lo, Rlo);
7886 Max (Hi, Rhi);
7887 end if;
7888
7889 -- If at least one of our operands is now Bignum, we must rebuild
7890 -- the if expression to use Bignum operands. We will analyze the
7891 -- rebuilt if expression with overflow checks off, since once we
7892 -- are in bignum mode, we are all done with overflow checks.
7893
7894 if Bignum_Operands then
7895 Rewrite (N,
7896 Make_If_Expression (Loc,
7897 Expressions => New_List (
7898 Remove_Head (Expressions (N)),
7899 Convert_To_Bignum (Then_DE),
7900 Convert_To_Bignum (Else_DE)),
7901 Is_Elsif => Is_Elsif (N)));
7902
7903 Reanalyze (RTE (RE_Bignum), Suppress => True);
7904
7905 -- If we have no Long_Long_Integer operands, then we are in result
7906 -- range, since it means that none of our operands felt the need
7907 -- to worry about overflow (otherwise it would have already been
7908 -- converted to long long integer or bignum). We reexpand to
7909 -- complete the expansion of the if expression (but we do not
7910 -- need to reanalyze).
7911
7912 elsif not Long_Long_Integer_Operands then
7913 Set_Do_Overflow_Check (N, False);
7914 Reexpand;
7915
7916 -- Otherwise convert us to long long integer mode. Note that we
7917 -- don't need any further overflow checking at this level.
7918
7919 else
7920 Convert_To_And_Rewrite (LLIB, Then_DE);
7921 Convert_To_And_Rewrite (LLIB, Else_DE);
7922 Set_Etype (N, LLIB);
7923
7924 -- Now reanalyze with overflow checks off
7925
7926 Set_Do_Overflow_Check (N, False);
7927 Reanalyze (LLIB, Suppress => True);
7928 end if;
7929 end;
7930
7931 return;
7932
7933 -- Here for case expression
7934
7935 elsif Nkind (N) = N_Case_Expression then
7936 Bignum_Operands := False;
7937 Long_Long_Integer_Operands := False;
7938
7939 declare
7940 Alt : Node_Id;
7941
7942 begin
7943 -- Loop through expressions applying recursive call
7944
7945 Alt := First (Alternatives (N));
7946 while Present (Alt) loop
7947 declare
7948 Aexp : constant Node_Id := Expression (Alt);
7949
7950 begin
7951 Minimize_Eliminate_Overflows
7952 (Aexp, Lo, Hi, Top_Level => False);
7953
7954 if Lo = No_Uint then
7955 Bignum_Operands := True;
7956 elsif Etype (Aexp) = LLIB then
7957 Long_Long_Integer_Operands := True;
7958 end if;
7959 end;
7960
7961 Next (Alt);
7962 end loop;
7963
7964 -- If we have no bignum or long long integer operands, it means
7965 -- that none of our dependent expressions could raise overflow.
7966 -- In this case, we simply return with no changes except for
7967 -- resetting the overflow flag, since we are done with overflow
7968 -- checks for this node. We will reexpand to get the needed
7969 -- expansion for the case expression, but we do not need to
7970 -- reanalyze, since nothing has changed.
7971
7972 if not (Bignum_Operands or Long_Long_Integer_Operands) then
7973 Set_Do_Overflow_Check (N, False);
7974 Reexpand (Suppress => True);
7975
7976 -- Otherwise we are going to rebuild the case expression using
7977 -- either bignum or long long integer operands throughout.
7978
7979 else
7980 declare
7981 Rtype : Entity_Id;
7982 New_Alts : List_Id;
7983 New_Exp : Node_Id;
7984
7985 begin
7986 New_Alts := New_List;
7987 Alt := First (Alternatives (N));
7988 while Present (Alt) loop
7989 if Bignum_Operands then
7990 New_Exp := Convert_To_Bignum (Expression (Alt));
7991 Rtype := RTE (RE_Bignum);
7992 else
7993 New_Exp := Convert_To (LLIB, Expression (Alt));
7994 Rtype := LLIB;
7995 end if;
7996
7997 Append_To (New_Alts,
7998 Make_Case_Expression_Alternative (Sloc (Alt),
7999 Actions => No_List,
8000 Discrete_Choices => Discrete_Choices (Alt),
8001 Expression => New_Exp));
8002
8003 Next (Alt);
8004 end loop;
8005
8006 Rewrite (N,
8007 Make_Case_Expression (Loc,
8008 Expression => Expression (N),
8009 Alternatives => New_Alts));
8010
8011 Reanalyze (Rtype, Suppress => True);
8012 end;
8013 end if;
8014 end;
8015
8016 return;
8017 end if;
8018
8019 -- If we have an arithmetic operator we make recursive calls on the
8020 -- operands to get the ranges (and to properly process the subtree
8021 -- that lies below us).
8022
8023 Minimize_Eliminate_Overflows
8024 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
8025
8026 if Binary then
8027 Minimize_Eliminate_Overflows
8028 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
8029 end if;
8030
8031 -- Record if we have Long_Long_Integer operands
8032
8033 Long_Long_Integer_Operands :=
8034 Etype (Right_Opnd (N)) = LLIB
8035 or else (Binary and then Etype (Left_Opnd (N)) = LLIB);
8036
8037 -- If either operand is a bignum, then result will be a bignum and we
8038 -- don't need to do any range analysis. As previously discussed we could
8039 -- do range analysis in such cases, but it could mean working with giant
8040 -- numbers at compile time for very little gain (the number of cases
8041 -- in which we could slip back from bignum mode is small).
8042
8043 if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
8044 Lo := No_Uint;
8045 Hi := No_Uint;
8046 Bignum_Operands := True;
8047
8048 -- Otherwise compute result range
8049
8050 else
8051 Bignum_Operands := False;
8052
8053 case Nkind (N) is
8054
8055 -- Absolute value
8056
8057 when N_Op_Abs =>
8058 Lo := Uint_0;
8059 Hi := UI_Max (abs Rlo, abs Rhi);
8060
8061 -- Addition
8062
8063 when N_Op_Add =>
8064 Lo := Llo + Rlo;
8065 Hi := Lhi + Rhi;
8066
8067 -- Division
8068
8069 when N_Op_Divide =>
8070
8071 -- If the right operand can only be zero, set 0..0
8072
8073 if Rlo = 0 and then Rhi = 0 then
8074 Lo := Uint_0;
8075 Hi := Uint_0;
8076
8077 -- Possible bounds of division must come from dividing end
8078 -- values of the input ranges (four possibilities), provided
8079 -- zero is not included in the possible values of the right
8080 -- operand.
8081
8082 -- Otherwise, we just consider two intervals of values for
8083 -- the right operand: the interval of negative values (up to
8084 -- -1) and the interval of positive values (starting at 1).
8085 -- Since division by 1 is the identity, and division by -1
8086 -- is negation, we get all possible bounds of division in that
8087 -- case by considering:
8088 -- - all values from the division of end values of input
8089 -- ranges;
8090 -- - the end values of the left operand;
8091 -- - the negation of the end values of the left operand.
8092
8093 else
8094 declare
8095 Mrk : constant Uintp.Save_Mark := Mark;
8096 -- Mark so we can release the RR and Ev values
8097
8098 Ev1 : Uint;
8099 Ev2 : Uint;
8100 Ev3 : Uint;
8101 Ev4 : Uint;
8102
8103 begin
8104 -- Discard extreme values of zero for the divisor, since
8105 -- they will simply result in an exception in any case.
8106
8107 if Rlo = 0 then
8108 Rlo := Uint_1;
8109 elsif Rhi = 0 then
8110 Rhi := -Uint_1;
8111 end if;
8112
8113 -- Compute possible bounds coming from dividing end
8114 -- values of the input ranges.
8115
8116 Ev1 := Llo / Rlo;
8117 Ev2 := Llo / Rhi;
8118 Ev3 := Lhi / Rlo;
8119 Ev4 := Lhi / Rhi;
8120
8121 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8122 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8123
8124 -- If the right operand can be both negative or positive,
8125 -- include the end values of the left operand in the
8126 -- extreme values, as well as their negation.
8127
8128 if Rlo < 0 and then Rhi > 0 then
8129 Ev1 := Llo;
8130 Ev2 := -Llo;
8131 Ev3 := Lhi;
8132 Ev4 := -Lhi;
8133
8134 Min (Lo,
8135 UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)));
8136 Max (Hi,
8137 UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)));
8138 end if;
8139
8140 -- Release the RR and Ev values
8141
8142 Release_And_Save (Mrk, Lo, Hi);
8143 end;
8144 end if;
8145
8146 -- Exponentiation
8147
8148 when N_Op_Expon =>
8149
8150 -- Discard negative values for the exponent, since they will
8151 -- simply result in an exception in any case.
8152
8153 if Rhi < 0 then
8154 Rhi := Uint_0;
8155 elsif Rlo < 0 then
8156 Rlo := Uint_0;
8157 end if;
8158
8159 -- Estimate number of bits in result before we go computing
8160 -- giant useless bounds. Basically the number of bits in the
8161 -- result is the number of bits in the base multiplied by the
8162 -- value of the exponent. If this is big enough that the result
8163 -- definitely won't fit in Long_Long_Integer, switch to bignum
8164 -- mode immediately, and avoid computing giant bounds.
8165
8166 -- The comparison here is approximate, but conservative, it
8167 -- only clicks on cases that are sure to exceed the bounds.
8168
8169 if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
8170 Lo := No_Uint;
8171 Hi := No_Uint;
8172
8173 -- If right operand is zero then result is 1
8174
8175 elsif Rhi = 0 then
8176 Lo := Uint_1;
8177 Hi := Uint_1;
8178
8179 else
8180 -- High bound comes either from exponentiation of largest
8181 -- positive value to largest exponent value, or from
8182 -- the exponentiation of most negative value to an
8183 -- even exponent.
8184
8185 declare
8186 Hi1, Hi2 : Uint;
8187
8188 begin
8189 if Lhi > 0 then
8190 Hi1 := Lhi ** Rhi;
8191 else
8192 Hi1 := Uint_0;
8193 end if;
8194
8195 if Llo < 0 then
8196 if Rhi mod 2 = 0 then
8197 Hi2 := Llo ** Rhi;
8198 else
8199 Hi2 := Llo ** (Rhi - 1);
8200 end if;
8201 else
8202 Hi2 := Uint_0;
8203 end if;
8204
8205 Hi := UI_Max (Hi1, Hi2);
8206 end;
8207
8208 -- Result can only be negative if base can be negative
8209
8210 if Llo < 0 then
8211 if Rhi mod 2 = 0 then
8212 Lo := Llo ** (Rhi - 1);
8213 else
8214 Lo := Llo ** Rhi;
8215 end if;
8216
8217 -- Otherwise low bound is minimum ** minimum
8218
8219 else
8220 Lo := Llo ** Rlo;
8221 end if;
8222 end if;
8223
8224 -- Negation
8225
8226 when N_Op_Minus =>
8227 Lo := -Rhi;
8228 Hi := -Rlo;
8229
8230 -- Mod
8231
8232 when N_Op_Mod =>
8233 declare
8234 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8235 -- This is the maximum absolute value of the result
8236
8237 begin
8238 Lo := Uint_0;
8239 Hi := Uint_0;
8240
8241 -- The result depends only on the sign and magnitude of
8242 -- the right operand, it does not depend on the sign or
8243 -- magnitude of the left operand.
8244
8245 if Rlo < 0 then
8246 Lo := -Maxabs;
8247 end if;
8248
8249 if Rhi > 0 then
8250 Hi := Maxabs;
8251 end if;
8252 end;
8253
8254 -- Multiplication
8255
8256 when N_Op_Multiply =>
8257
8258 -- Possible bounds of multiplication must come from multiplying
8259 -- end values of the input ranges (four possibilities).
8260
8261 declare
8262 Mrk : constant Uintp.Save_Mark := Mark;
8263 -- Mark so we can release the Ev values
8264
8265 Ev1 : constant Uint := Llo * Rlo;
8266 Ev2 : constant Uint := Llo * Rhi;
8267 Ev3 : constant Uint := Lhi * Rlo;
8268 Ev4 : constant Uint := Lhi * Rhi;
8269
8270 begin
8271 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
8272 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
8273
8274 -- Release the Ev values
8275
8276 Release_And_Save (Mrk, Lo, Hi);
8277 end;
8278
8279 -- Plus operator (affirmation)
8280
8281 when N_Op_Plus =>
8282 Lo := Rlo;
8283 Hi := Rhi;
8284
8285 -- Remainder
8286
8287 when N_Op_Rem =>
8288 declare
8289 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1;
8290 -- This is the maximum absolute value of the result. Note
8291 -- that the result range does not depend on the sign of the
8292 -- right operand.
8293
8294 begin
8295 Lo := Uint_0;
8296 Hi := Uint_0;
8297
8298 -- Case of left operand negative, which results in a range
8299 -- of -Maxabs .. 0 for those negative values. If there are
8300 -- no negative values then Lo value of result is always 0.
8301
8302 if Llo < 0 then
8303 Lo := -Maxabs;
8304 end if;
8305
8306 -- Case of left operand positive
8307
8308 if Lhi > 0 then
8309 Hi := Maxabs;
8310 end if;
8311 end;
8312
8313 -- Subtract
8314
8315 when N_Op_Subtract =>
8316 Lo := Llo - Rhi;
8317 Hi := Lhi - Rlo;
8318
8319 -- Nothing else should be possible
8320
8321 when others =>
8322 raise Program_Error;
8323 end case;
8324 end if;
8325
8326 -- Here for the case where we have not rewritten anything (no bignum
8327 -- operands or long long integer operands), and we know the result.
8328 -- If we know we are in the result range, and we do not have Bignum
8329 -- operands or Long_Long_Integer operands, we can just reexpand with
8330 -- overflow checks turned off (since we know we cannot have overflow).
8331 -- As always the reexpansion is required to complete expansion of the
8332 -- operator, but we do not need to reanalyze, and we prevent recursion
8333 -- by suppressing the check.
8334
8335 if not (Bignum_Operands or Long_Long_Integer_Operands)
8336 and then In_Result_Range
8337 then
8338 Set_Do_Overflow_Check (N, False);
8339 Reexpand (Suppress => True);
8340 return;
8341
8342 -- Here we know that we are not in the result range, and in the general
8343 -- case we will move into either the Bignum or Long_Long_Integer domain
8344 -- to compute the result. However, there is one exception. If we are
8345 -- at the top level, and we do not have Bignum or Long_Long_Integer
8346 -- operands, we will have to immediately convert the result back to
8347 -- the result type, so there is no point in Bignum/Long_Long_Integer
8348 -- fiddling.
8349
8350 elsif Top_Level
8351 and then not (Bignum_Operands or Long_Long_Integer_Operands)
8352
8353 -- One further refinement. If we are at the top level, but our parent
8354 -- is a type conversion, then go into bignum or long long integer node
8355 -- since the result will be converted to that type directly without
8356 -- going through the result type, and we may avoid an overflow. This
8357 -- is the case for example of Long_Long_Integer (A ** 4), where A is
8358 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
8359 -- but does not fit in Integer.
8360
8361 and then Nkind (Parent (N)) /= N_Type_Conversion
8362 then
8363 -- Here keep original types, but we need to complete analysis
8364
8365 -- One subtlety. We can't just go ahead and do an analyze operation
8366 -- here because it will cause recursion into the whole MINIMIZED/
8367 -- ELIMINATED overflow processing which is not what we want. Here
8368 -- we are at the top level, and we need a check against the result
8369 -- mode (i.e. we want to use STRICT mode). So do exactly that.
8370 -- Also, we have not modified the node, so this is a case where
8371 -- we need to reexpand, but not reanalyze.
8372
8373 Reexpand;
8374 return;
8375
8376 -- Cases where we do the operation in Bignum mode. This happens either
8377 -- because one of our operands is in Bignum mode already, or because
8378 -- the computed bounds are outside the bounds of Long_Long_Integer,
8379 -- which in some cases can be indicated by Hi and Lo being No_Uint.
8380
8381 -- Note: we could do better here and in some cases switch back from
8382 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
8383 -- 0 .. 1, but the cases are rare and it is not worth the effort.
8384 -- Failing to do this switching back is only an efficiency issue.
8385
8386 elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
8387
8388 -- OK, we are definitely outside the range of Long_Long_Integer. The
8389 -- question is whether to move to Bignum mode, or stay in the domain
8390 -- of Long_Long_Integer, signalling that an overflow check is needed.
8391
8392 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
8393 -- the Bignum business. In ELIMINATED mode, we will normally move
8394 -- into Bignum mode, but there is an exception if neither of our
8395 -- operands is Bignum now, and we are at the top level (Top_Level
8396 -- set True). In this case, there is no point in moving into Bignum
8397 -- mode to prevent overflow if the caller will immediately convert
8398 -- the Bignum value back to LLI with an overflow check. It's more
8399 -- efficient to stay in LLI mode with an overflow check (if needed)
8400
8401 if Check_Mode = Minimized
8402 or else (Top_Level and not Bignum_Operands)
8403 then
8404 if Do_Overflow_Check (N) then
8405 Enable_Overflow_Check (N);
8406 end if;
8407
8408 -- The result now has to be in Long_Long_Integer mode, so adjust
8409 -- the possible range to reflect this. Note these calls also
8410 -- change No_Uint values from the top level case to LLI bounds.
8411
8412 Max (Lo, LLLo);
8413 Min (Hi, LLHi);
8414
8415 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
8416
8417 else
8418 pragma Assert (Check_Mode = Eliminated);
8419
8420 declare
8421 Fent : Entity_Id;
8422 Args : List_Id;
8423
8424 begin
8425 case Nkind (N) is
8426 when N_Op_Abs =>
8427 Fent := RTE (RE_Big_Abs);
8428
8429 when N_Op_Add =>
8430 Fent := RTE (RE_Big_Add);
8431
8432 when N_Op_Divide =>
8433 Fent := RTE (RE_Big_Div);
8434
8435 when N_Op_Expon =>
8436 Fent := RTE (RE_Big_Exp);
8437
8438 when N_Op_Minus =>
8439 Fent := RTE (RE_Big_Neg);
8440
8441 when N_Op_Mod =>
8442 Fent := RTE (RE_Big_Mod);
8443
8444 when N_Op_Multiply =>
8445 Fent := RTE (RE_Big_Mul);
8446
8447 when N_Op_Rem =>
8448 Fent := RTE (RE_Big_Rem);
8449
8450 when N_Op_Subtract =>
8451 Fent := RTE (RE_Big_Sub);
8452
8453 -- Anything else is an internal error, this includes the
8454 -- N_Op_Plus case, since how can plus cause the result
8455 -- to be out of range if the operand is in range?
8456
8457 when others =>
8458 raise Program_Error;
8459 end case;
8460
8461 -- Construct argument list for Bignum call, converting our
8462 -- operands to Bignum form if they are not already there.
8463
8464 Args := New_List;
8465
8466 if Binary then
8467 Append_To (Args, Convert_To_Bignum (Left_Opnd (N)));
8468 end if;
8469
8470 Append_To (Args, Convert_To_Bignum (Right_Opnd (N)));
8471
8472 -- Now rewrite the arithmetic operator with a call to the
8473 -- corresponding bignum function.
8474
8475 Rewrite (N,
8476 Make_Function_Call (Loc,
8477 Name => New_Occurrence_Of (Fent, Loc),
8478 Parameter_Associations => Args));
8479 Reanalyze (RTE (RE_Bignum), Suppress => True);
8480
8481 -- Indicate result is Bignum mode
8482
8483 Lo := No_Uint;
8484 Hi := No_Uint;
8485 return;
8486 end;
8487 end if;
8488
8489 -- Otherwise we are in range of Long_Long_Integer, so no overflow
8490 -- check is required, at least not yet.
8491
8492 else
8493 Set_Do_Overflow_Check (N, False);
8494 end if;
8495
8496 -- Here we are not in Bignum territory, but we may have long long
8497 -- integer operands that need special handling. First a special check:
8498 -- If an exponentiation operator exponent is of type Long_Long_Integer,
8499 -- it means we converted it to prevent overflow, but exponentiation
8500 -- requires a Natural right operand, so convert it back to Natural.
8501 -- This conversion may raise an exception which is fine.
8502
8503 if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then
8504 Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N));
8505 end if;
8506
8507 -- Here we will do the operation in Long_Long_Integer. We do this even
8508 -- if we know an overflow check is required, better to do this in long
8509 -- long integer mode, since we are less likely to overflow.
8510
8511 -- Convert right or only operand to Long_Long_Integer, except that
8512 -- we do not touch the exponentiation right operand.
8513
8514 if Nkind (N) /= N_Op_Expon then
8515 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
8516 end if;
8517
8518 -- Convert left operand to Long_Long_Integer for binary case
8519
8520 if Binary then
8521 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
8522 end if;
8523
8524 -- Reset node to unanalyzed
8525
8526 Set_Analyzed (N, False);
8527 Set_Etype (N, Empty);
8528 Set_Entity (N, Empty);
8529
8530 -- Now analyze this new node. This reanalysis will complete processing
8531 -- for the node. In particular we will complete the expansion of an
8532 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
8533 -- we will complete any division checks (since we have not changed the
8534 -- setting of the Do_Division_Check flag).
8535
8536 -- We do this reanalysis in STRICT mode to avoid recursion into the
8537 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
8538
8539 declare
8540 SG : constant Overflow_Mode_Type :=
8541 Scope_Suppress.Overflow_Mode_General;
8542 SA : constant Overflow_Mode_Type :=
8543 Scope_Suppress.Overflow_Mode_Assertions;
8544
8545 begin
8546 Scope_Suppress.Overflow_Mode_General := Strict;
8547 Scope_Suppress.Overflow_Mode_Assertions := Strict;
8548
8549 if not Do_Overflow_Check (N) then
8550 Reanalyze (LLIB, Suppress => True);
8551 else
8552 Reanalyze (LLIB);
8553 end if;
8554
8555 Scope_Suppress.Overflow_Mode_General := SG;
8556 Scope_Suppress.Overflow_Mode_Assertions := SA;
8557 end;
8558 end Minimize_Eliminate_Overflows;
8559
8560 -------------------------
8561 -- Overflow_Check_Mode --
8562 -------------------------
8563
8564 function Overflow_Check_Mode return Overflow_Mode_Type is
8565 begin
8566 if In_Assertion_Expr = 0 then
8567 return Scope_Suppress.Overflow_Mode_General;
8568 else
8569 return Scope_Suppress.Overflow_Mode_Assertions;
8570 end if;
8571 end Overflow_Check_Mode;
8572
8573 --------------------------------
8574 -- Overflow_Checks_Suppressed --
8575 --------------------------------
8576
8577 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
8578 begin
8579 if Present (E) and then Checks_May_Be_Suppressed (E) then
8580 return Is_Check_Suppressed (E, Overflow_Check);
8581 else
8582 return Scope_Suppress.Suppress (Overflow_Check);
8583 end if;
8584 end Overflow_Checks_Suppressed;
8585
8586 ---------------------------------
8587 -- Predicate_Checks_Suppressed --
8588 ---------------------------------
8589
8590 function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is
8591 begin
8592 if Present (E) and then Checks_May_Be_Suppressed (E) then
8593 return Is_Check_Suppressed (E, Predicate_Check);
8594 else
8595 return Scope_Suppress.Suppress (Predicate_Check);
8596 end if;
8597 end Predicate_Checks_Suppressed;
8598
8599 -----------------------------
8600 -- Range_Checks_Suppressed --
8601 -----------------------------
8602
8603 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
8604 begin
8605 if Present (E) then
8606 if Kill_Range_Checks (E) then
8607 return True;
8608
8609 elsif Checks_May_Be_Suppressed (E) then
8610 return Is_Check_Suppressed (E, Range_Check);
8611 end if;
8612 end if;
8613
8614 return Scope_Suppress.Suppress (Range_Check);
8615 end Range_Checks_Suppressed;
8616
8617 -----------------------------------------
8618 -- Range_Or_Validity_Checks_Suppressed --
8619 -----------------------------------------
8620
8621 -- Note: the coding would be simpler here if we simply made appropriate
8622 -- calls to Range/Validity_Checks_Suppressed, but that would result in
8623 -- duplicated checks which we prefer to avoid.
8624
8625 function Range_Or_Validity_Checks_Suppressed
8626 (Expr : Node_Id) return Boolean
8627 is
8628 begin
8629 -- Immediate return if scope checks suppressed for either check
8630
8631 if Scope_Suppress.Suppress (Range_Check)
8632 or
8633 Scope_Suppress.Suppress (Validity_Check)
8634 then
8635 return True;
8636 end if;
8637
8638 -- If no expression, that's odd, decide that checks are suppressed,
8639 -- since we don't want anyone trying to do checks in this case, which
8640 -- is most likely the result of some other error.
8641
8642 if No (Expr) then
8643 return True;
8644 end if;
8645
8646 -- Expression is present, so perform suppress checks on type
8647
8648 declare
8649 Typ : constant Entity_Id := Etype (Expr);
8650 begin
8651 if Checks_May_Be_Suppressed (Typ)
8652 and then (Is_Check_Suppressed (Typ, Range_Check)
8653 or else
8654 Is_Check_Suppressed (Typ, Validity_Check))
8655 then
8656 return True;
8657 end if;
8658 end;
8659
8660 -- If expression is an entity name, perform checks on this entity
8661
8662 if Is_Entity_Name (Expr) then
8663 declare
8664 Ent : constant Entity_Id := Entity (Expr);
8665 begin
8666 if Checks_May_Be_Suppressed (Ent) then
8667 return Is_Check_Suppressed (Ent, Range_Check)
8668 or else Is_Check_Suppressed (Ent, Validity_Check);
8669 end if;
8670 end;
8671 end if;
8672
8673 -- If we fall through, no checks suppressed
8674
8675 return False;
8676 end Range_Or_Validity_Checks_Suppressed;
8677
8678 -------------------
8679 -- Remove_Checks --
8680 -------------------
8681
8682 procedure Remove_Checks (Expr : Node_Id) is
8683 function Process (N : Node_Id) return Traverse_Result;
8684 -- Process a single node during the traversal
8685
8686 procedure Traverse is new Traverse_Proc (Process);
8687 -- The traversal procedure itself
8688
8689 -------------
8690 -- Process --
8691 -------------
8692
8693 function Process (N : Node_Id) return Traverse_Result is
8694 begin
8695 if Nkind (N) not in N_Subexpr then
8696 return Skip;
8697 end if;
8698
8699 Set_Do_Range_Check (N, False);
8700
8701 case Nkind (N) is
8702 when N_And_Then =>
8703 Traverse (Left_Opnd (N));
8704 return Skip;
8705
8706 when N_Attribute_Reference =>
8707 Set_Do_Overflow_Check (N, False);
8708
8709 when N_Function_Call =>
8710 Set_Do_Tag_Check (N, False);
8711
8712 when N_Op =>
8713 Set_Do_Overflow_Check (N, False);
8714
8715 case Nkind (N) is
8716 when N_Op_Divide =>
8717 Set_Do_Division_Check (N, False);
8718
8719 when N_Op_And =>
8720 Set_Do_Length_Check (N, False);
8721
8722 when N_Op_Mod =>
8723 Set_Do_Division_Check (N, False);
8724
8725 when N_Op_Or =>
8726 Set_Do_Length_Check (N, False);
8727
8728 when N_Op_Rem =>
8729 Set_Do_Division_Check (N, False);
8730
8731 when N_Op_Xor =>
8732 Set_Do_Length_Check (N, False);
8733
8734 when others =>
8735 null;
8736 end case;
8737
8738 when N_Or_Else =>
8739 Traverse (Left_Opnd (N));
8740 return Skip;
8741
8742 when N_Selected_Component =>
8743 Set_Do_Discriminant_Check (N, False);
8744
8745 when N_Type_Conversion =>
8746 Set_Do_Length_Check (N, False);
8747 Set_Do_Tag_Check (N, False);
8748 Set_Do_Overflow_Check (N, False);
8749
8750 when others =>
8751 null;
8752 end case;
8753
8754 return OK;
8755 end Process;
8756
8757 -- Start of processing for Remove_Checks
8758
8759 begin
8760 Traverse (Expr);
8761 end Remove_Checks;
8762
8763 ----------------------------
8764 -- Selected_Length_Checks --
8765 ----------------------------
8766
8767 function Selected_Length_Checks
8768 (Ck_Node : Node_Id;
8769 Target_Typ : Entity_Id;
8770 Source_Typ : Entity_Id;
8771 Warn_Node : Node_Id) return Check_Result
8772 is
8773 Loc : constant Source_Ptr := Sloc (Ck_Node);
8774 S_Typ : Entity_Id;
8775 T_Typ : Entity_Id;
8776 Expr_Actual : Node_Id;
8777 Exptyp : Entity_Id;
8778 Cond : Node_Id := Empty;
8779 Do_Access : Boolean := False;
8780 Wnode : Node_Id := Warn_Node;
8781 Ret_Result : Check_Result := (Empty, Empty);
8782 Num_Checks : Natural := 0;
8783
8784 procedure Add_Check (N : Node_Id);
8785 -- Adds the action given to Ret_Result if N is non-Empty
8786
8787 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
8788 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
8789 -- Comments required ???
8790
8791 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
8792 -- True for equal literals and for nodes that denote the same constant
8793 -- entity, even if its value is not a static constant. This includes the
8794 -- case of a discriminal reference within an init proc. Removes some
8795 -- obviously superfluous checks.
8796
8797 function Length_E_Cond
8798 (Exptyp : Entity_Id;
8799 Typ : Entity_Id;
8800 Indx : Nat) return Node_Id;
8801 -- Returns expression to compute:
8802 -- Typ'Length /= Exptyp'Length
8803
8804 function Length_N_Cond
8805 (Expr : Node_Id;
8806 Typ : Entity_Id;
8807 Indx : Nat) return Node_Id;
8808 -- Returns expression to compute:
8809 -- Typ'Length /= Expr'Length
8810
8811 ---------------
8812 -- Add_Check --
8813 ---------------
8814
8815 procedure Add_Check (N : Node_Id) is
8816 begin
8817 if Present (N) then
8818
8819 -- For now, ignore attempt to place more than two checks ???
8820 -- This is really worrisome, are we really discarding checks ???
8821
8822 if Num_Checks = 2 then
8823 return;
8824 end if;
8825
8826 pragma Assert (Num_Checks <= 1);
8827 Num_Checks := Num_Checks + 1;
8828 Ret_Result (Num_Checks) := N;
8829 end if;
8830 end Add_Check;
8831
8832 ------------------
8833 -- Get_E_Length --
8834 ------------------
8835
8836 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
8837 SE : constant Entity_Id := Scope (E);
8838 N : Node_Id;
8839 E1 : Entity_Id := E;
8840
8841 begin
8842 if Ekind (Scope (E)) = E_Record_Type
8843 and then Has_Discriminants (Scope (E))
8844 then
8845 N := Build_Discriminal_Subtype_Of_Component (E);
8846
8847 if Present (N) then
8848 Insert_Action (Ck_Node, N);
8849 E1 := Defining_Identifier (N);
8850 end if;
8851 end if;
8852
8853 if Ekind (E1) = E_String_Literal_Subtype then
8854 return
8855 Make_Integer_Literal (Loc,
8856 Intval => String_Literal_Length (E1));
8857
8858 elsif SE /= Standard_Standard
8859 and then Ekind (Scope (SE)) = E_Protected_Type
8860 and then Has_Discriminants (Scope (SE))
8861 and then Has_Completion (Scope (SE))
8862 and then not Inside_Init_Proc
8863 then
8864 -- If the type whose length is needed is a private component
8865 -- constrained by a discriminant, we must expand the 'Length
8866 -- attribute into an explicit computation, using the discriminal
8867 -- of the current protected operation. This is because the actual
8868 -- type of the prival is constructed after the protected opera-
8869 -- tion has been fully expanded.
8870
8871 declare
8872 Indx_Type : Node_Id;
8873 Lo : Node_Id;
8874 Hi : Node_Id;
8875 Do_Expand : Boolean := False;
8876
8877 begin
8878 Indx_Type := First_Index (E);
8879
8880 for J in 1 .. Indx - 1 loop
8881 Next_Index (Indx_Type);
8882 end loop;
8883
8884 Get_Index_Bounds (Indx_Type, Lo, Hi);
8885
8886 if Nkind (Lo) = N_Identifier
8887 and then Ekind (Entity (Lo)) = E_In_Parameter
8888 then
8889 Lo := Get_Discriminal (E, Lo);
8890 Do_Expand := True;
8891 end if;
8892
8893 if Nkind (Hi) = N_Identifier
8894 and then Ekind (Entity (Hi)) = E_In_Parameter
8895 then
8896 Hi := Get_Discriminal (E, Hi);
8897 Do_Expand := True;
8898 end if;
8899
8900 if Do_Expand then
8901 if not Is_Entity_Name (Lo) then
8902 Lo := Duplicate_Subexpr_No_Checks (Lo);
8903 end if;
8904
8905 if not Is_Entity_Name (Hi) then
8906 Lo := Duplicate_Subexpr_No_Checks (Hi);
8907 end if;
8908
8909 N :=
8910 Make_Op_Add (Loc,
8911 Left_Opnd =>
8912 Make_Op_Subtract (Loc,
8913 Left_Opnd => Hi,
8914 Right_Opnd => Lo),
8915
8916 Right_Opnd => Make_Integer_Literal (Loc, 1));
8917 return N;
8918
8919 else
8920 N :=
8921 Make_Attribute_Reference (Loc,
8922 Attribute_Name => Name_Length,
8923 Prefix =>
8924 New_Occurrence_Of (E1, Loc));
8925
8926 if Indx > 1 then
8927 Set_Expressions (N, New_List (
8928 Make_Integer_Literal (Loc, Indx)));
8929 end if;
8930
8931 return N;
8932 end if;
8933 end;
8934
8935 else
8936 N :=
8937 Make_Attribute_Reference (Loc,
8938 Attribute_Name => Name_Length,
8939 Prefix =>
8940 New_Occurrence_Of (E1, Loc));
8941
8942 if Indx > 1 then
8943 Set_Expressions (N, New_List (
8944 Make_Integer_Literal (Loc, Indx)));
8945 end if;
8946
8947 return N;
8948 end if;
8949 end Get_E_Length;
8950
8951 ------------------
8952 -- Get_N_Length --
8953 ------------------
8954
8955 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
8956 begin
8957 return
8958 Make_Attribute_Reference (Loc,
8959 Attribute_Name => Name_Length,
8960 Prefix =>
8961 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
8962 Expressions => New_List (
8963 Make_Integer_Literal (Loc, Indx)));
8964 end Get_N_Length;
8965
8966 -------------------
8967 -- Length_E_Cond --
8968 -------------------
8969
8970 function Length_E_Cond
8971 (Exptyp : Entity_Id;
8972 Typ : Entity_Id;
8973 Indx : Nat) return Node_Id
8974 is
8975 begin
8976 return
8977 Make_Op_Ne (Loc,
8978 Left_Opnd => Get_E_Length (Typ, Indx),
8979 Right_Opnd => Get_E_Length (Exptyp, Indx));
8980 end Length_E_Cond;
8981
8982 -------------------
8983 -- Length_N_Cond --
8984 -------------------
8985
8986 function Length_N_Cond
8987 (Expr : Node_Id;
8988 Typ : Entity_Id;
8989 Indx : Nat) return Node_Id
8990 is
8991 begin
8992 return
8993 Make_Op_Ne (Loc,
8994 Left_Opnd => Get_E_Length (Typ, Indx),
8995 Right_Opnd => Get_N_Length (Expr, Indx));
8996 end Length_N_Cond;
8997
8998 -----------------
8999 -- Same_Bounds --
9000 -----------------
9001
9002 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
9003 begin
9004 return
9005 (Nkind (L) = N_Integer_Literal
9006 and then Nkind (R) = N_Integer_Literal
9007 and then Intval (L) = Intval (R))
9008
9009 or else
9010 (Is_Entity_Name (L)
9011 and then Ekind (Entity (L)) = E_Constant
9012 and then ((Is_Entity_Name (R)
9013 and then Entity (L) = Entity (R))
9014 or else
9015 (Nkind (R) = N_Type_Conversion
9016 and then Is_Entity_Name (Expression (R))
9017 and then Entity (L) = Entity (Expression (R)))))
9018
9019 or else
9020 (Is_Entity_Name (R)
9021 and then Ekind (Entity (R)) = E_Constant
9022 and then Nkind (L) = N_Type_Conversion
9023 and then Is_Entity_Name (Expression (L))
9024 and then Entity (R) = Entity (Expression (L)))
9025
9026 or else
9027 (Is_Entity_Name (L)
9028 and then Is_Entity_Name (R)
9029 and then Entity (L) = Entity (R)
9030 and then Ekind (Entity (L)) = E_In_Parameter
9031 and then Inside_Init_Proc);
9032 end Same_Bounds;
9033
9034 -- Start of processing for Selected_Length_Checks
9035
9036 begin
9037 if not Expander_Active then
9038 return Ret_Result;
9039 end if;
9040
9041 if Target_Typ = Any_Type
9042 or else Target_Typ = Any_Composite
9043 or else Raises_Constraint_Error (Ck_Node)
9044 then
9045 return Ret_Result;
9046 end if;
9047
9048 if No (Wnode) then
9049 Wnode := Ck_Node;
9050 end if;
9051
9052 T_Typ := Target_Typ;
9053
9054 if No (Source_Typ) then
9055 S_Typ := Etype (Ck_Node);
9056 else
9057 S_Typ := Source_Typ;
9058 end if;
9059
9060 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9061 return Ret_Result;
9062 end if;
9063
9064 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9065 S_Typ := Designated_Type (S_Typ);
9066 T_Typ := Designated_Type (T_Typ);
9067 Do_Access := True;
9068
9069 -- A simple optimization for the null case
9070
9071 if Known_Null (Ck_Node) then
9072 return Ret_Result;
9073 end if;
9074 end if;
9075
9076 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9077 if Is_Constrained (T_Typ) then
9078
9079 -- The checking code to be generated will freeze the corresponding
9080 -- array type. However, we must freeze the type now, so that the
9081 -- freeze node does not appear within the generated if expression,
9082 -- but ahead of it.
9083
9084 Freeze_Before (Ck_Node, T_Typ);
9085
9086 Expr_Actual := Get_Referenced_Object (Ck_Node);
9087 Exptyp := Get_Actual_Subtype (Ck_Node);
9088
9089 if Is_Access_Type (Exptyp) then
9090 Exptyp := Designated_Type (Exptyp);
9091 end if;
9092
9093 -- String_Literal case. This needs to be handled specially be-
9094 -- cause no index types are available for string literals. The
9095 -- condition is simply:
9096
9097 -- T_Typ'Length = string-literal-length
9098
9099 if Nkind (Expr_Actual) = N_String_Literal
9100 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
9101 then
9102 Cond :=
9103 Make_Op_Ne (Loc,
9104 Left_Opnd => Get_E_Length (T_Typ, 1),
9105 Right_Opnd =>
9106 Make_Integer_Literal (Loc,
9107 Intval =>
9108 String_Literal_Length (Etype (Expr_Actual))));
9109
9110 -- General array case. Here we have a usable actual subtype for
9111 -- the expression, and the condition is built from the two types
9112 -- (Do_Length):
9113
9114 -- T_Typ'Length /= Exptyp'Length or else
9115 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9116 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9117 -- ...
9118
9119 elsif Is_Constrained (Exptyp) then
9120 declare
9121 Ndims : constant Nat := Number_Dimensions (T_Typ);
9122
9123 L_Index : Node_Id;
9124 R_Index : Node_Id;
9125 L_Low : Node_Id;
9126 L_High : Node_Id;
9127 R_Low : Node_Id;
9128 R_High : Node_Id;
9129 L_Length : Uint;
9130 R_Length : Uint;
9131 Ref_Node : Node_Id;
9132
9133 begin
9134 -- At the library level, we need to ensure that the type of
9135 -- the object is elaborated before the check itself is
9136 -- emitted. This is only done if the object is in the
9137 -- current compilation unit, otherwise the type is frozen
9138 -- and elaborated in its unit.
9139
9140 if Is_Itype (Exptyp)
9141 and then
9142 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
9143 and then
9144 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
9145 and then In_Open_Scopes (Scope (Exptyp))
9146 then
9147 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
9148 Set_Itype (Ref_Node, Exptyp);
9149 Insert_Action (Ck_Node, Ref_Node);
9150 end if;
9151
9152 L_Index := First_Index (T_Typ);
9153 R_Index := First_Index (Exptyp);
9154
9155 for Indx in 1 .. Ndims loop
9156 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9157 or else
9158 Nkind (R_Index) = N_Raise_Constraint_Error)
9159 then
9160 Get_Index_Bounds (L_Index, L_Low, L_High);
9161 Get_Index_Bounds (R_Index, R_Low, R_High);
9162
9163 -- Deal with compile time length check. Note that we
9164 -- skip this in the access case, because the access
9165 -- value may be null, so we cannot know statically.
9166
9167 if not Do_Access
9168 and then Compile_Time_Known_Value (L_Low)
9169 and then Compile_Time_Known_Value (L_High)
9170 and then Compile_Time_Known_Value (R_Low)
9171 and then Compile_Time_Known_Value (R_High)
9172 then
9173 if Expr_Value (L_High) >= Expr_Value (L_Low) then
9174 L_Length := Expr_Value (L_High) -
9175 Expr_Value (L_Low) + 1;
9176 else
9177 L_Length := UI_From_Int (0);
9178 end if;
9179
9180 if Expr_Value (R_High) >= Expr_Value (R_Low) then
9181 R_Length := Expr_Value (R_High) -
9182 Expr_Value (R_Low) + 1;
9183 else
9184 R_Length := UI_From_Int (0);
9185 end if;
9186
9187 if L_Length > R_Length then
9188 Add_Check
9189 (Compile_Time_Constraint_Error
9190 (Wnode, "too few elements for}??", T_Typ));
9191
9192 elsif L_Length < R_Length then
9193 Add_Check
9194 (Compile_Time_Constraint_Error
9195 (Wnode, "too many elements for}??", T_Typ));
9196 end if;
9197
9198 -- The comparison for an individual index subtype
9199 -- is omitted if the corresponding index subtypes
9200 -- statically match, since the result is known to
9201 -- be true. Note that this test is worth while even
9202 -- though we do static evaluation, because non-static
9203 -- subtypes can statically match.
9204
9205 elsif not
9206 Subtypes_Statically_Match
9207 (Etype (L_Index), Etype (R_Index))
9208
9209 and then not
9210 (Same_Bounds (L_Low, R_Low)
9211 and then Same_Bounds (L_High, R_High))
9212 then
9213 Evolve_Or_Else
9214 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
9215 end if;
9216
9217 Next (L_Index);
9218 Next (R_Index);
9219 end if;
9220 end loop;
9221 end;
9222
9223 -- Handle cases where we do not get a usable actual subtype that
9224 -- is constrained. This happens for example in the function call
9225 -- and explicit dereference cases. In these cases, we have to get
9226 -- the length or range from the expression itself, making sure we
9227 -- do not evaluate it more than once.
9228
9229 -- Here Ck_Node is the original expression, or more properly the
9230 -- result of applying Duplicate_Expr to the original tree, forcing
9231 -- the result to be a name.
9232
9233 else
9234 declare
9235 Ndims : constant Nat := Number_Dimensions (T_Typ);
9236
9237 begin
9238 -- Build the condition for the explicit dereference case
9239
9240 for Indx in 1 .. Ndims loop
9241 Evolve_Or_Else
9242 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
9243 end loop;
9244 end;
9245 end if;
9246 end if;
9247 end if;
9248
9249 -- Construct the test and insert into the tree
9250
9251 if Present (Cond) then
9252 if Do_Access then
9253 Cond := Guard_Access (Cond, Loc, Ck_Node);
9254 end if;
9255
9256 Add_Check
9257 (Make_Raise_Constraint_Error (Loc,
9258 Condition => Cond,
9259 Reason => CE_Length_Check_Failed));
9260 end if;
9261
9262 return Ret_Result;
9263 end Selected_Length_Checks;
9264
9265 ---------------------------
9266 -- Selected_Range_Checks --
9267 ---------------------------
9268
9269 function Selected_Range_Checks
9270 (Ck_Node : Node_Id;
9271 Target_Typ : Entity_Id;
9272 Source_Typ : Entity_Id;
9273 Warn_Node : Node_Id) return Check_Result
9274 is
9275 Loc : constant Source_Ptr := Sloc (Ck_Node);
9276 S_Typ : Entity_Id;
9277 T_Typ : Entity_Id;
9278 Expr_Actual : Node_Id;
9279 Exptyp : Entity_Id;
9280 Cond : Node_Id := Empty;
9281 Do_Access : Boolean := False;
9282 Wnode : Node_Id := Warn_Node;
9283 Ret_Result : Check_Result := (Empty, Empty);
9284 Num_Checks : Integer := 0;
9285
9286 procedure Add_Check (N : Node_Id);
9287 -- Adds the action given to Ret_Result if N is non-Empty
9288
9289 function Discrete_Range_Cond
9290 (Expr : Node_Id;
9291 Typ : Entity_Id) return Node_Id;
9292 -- Returns expression to compute:
9293 -- Low_Bound (Expr) < Typ'First
9294 -- or else
9295 -- High_Bound (Expr) > Typ'Last
9296
9297 function Discrete_Expr_Cond
9298 (Expr : Node_Id;
9299 Typ : Entity_Id) return Node_Id;
9300 -- Returns expression to compute:
9301 -- Expr < Typ'First
9302 -- or else
9303 -- Expr > Typ'Last
9304
9305 function Get_E_First_Or_Last
9306 (Loc : Source_Ptr;
9307 E : Entity_Id;
9308 Indx : Nat;
9309 Nam : Name_Id) return Node_Id;
9310 -- Returns an attribute reference
9311 -- E'First or E'Last
9312 -- with a source location of Loc.
9313 --
9314 -- Nam is Name_First or Name_Last, according to which attribute is
9315 -- desired. If Indx is non-zero, it is passed as a literal in the
9316 -- Expressions of the attribute reference (identifying the desired
9317 -- array dimension).
9318
9319 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
9320 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
9321 -- Returns expression to compute:
9322 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9323
9324 function Range_E_Cond
9325 (Exptyp : Entity_Id;
9326 Typ : Entity_Id;
9327 Indx : Nat)
9328 return Node_Id;
9329 -- Returns expression to compute:
9330 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9331
9332 function Range_Equal_E_Cond
9333 (Exptyp : Entity_Id;
9334 Typ : Entity_Id;
9335 Indx : Nat) return Node_Id;
9336 -- Returns expression to compute:
9337 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9338
9339 function Range_N_Cond
9340 (Expr : Node_Id;
9341 Typ : Entity_Id;
9342 Indx : Nat) return Node_Id;
9343 -- Return expression to compute:
9344 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
9345
9346 ---------------
9347 -- Add_Check --
9348 ---------------
9349
9350 procedure Add_Check (N : Node_Id) is
9351 begin
9352 if Present (N) then
9353
9354 -- For now, ignore attempt to place more than 2 checks ???
9355
9356 if Num_Checks = 2 then
9357 return;
9358 end if;
9359
9360 pragma Assert (Num_Checks <= 1);
9361 Num_Checks := Num_Checks + 1;
9362 Ret_Result (Num_Checks) := N;
9363 end if;
9364 end Add_Check;
9365
9366 -------------------------
9367 -- Discrete_Expr_Cond --
9368 -------------------------
9369
9370 function Discrete_Expr_Cond
9371 (Expr : Node_Id;
9372 Typ : Entity_Id) return Node_Id
9373 is
9374 begin
9375 return
9376 Make_Or_Else (Loc,
9377 Left_Opnd =>
9378 Make_Op_Lt (Loc,
9379 Left_Opnd =>
9380 Convert_To (Base_Type (Typ),
9381 Duplicate_Subexpr_No_Checks (Expr)),
9382 Right_Opnd =>
9383 Convert_To (Base_Type (Typ),
9384 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
9385
9386 Right_Opnd =>
9387 Make_Op_Gt (Loc,
9388 Left_Opnd =>
9389 Convert_To (Base_Type (Typ),
9390 Duplicate_Subexpr_No_Checks (Expr)),
9391 Right_Opnd =>
9392 Convert_To
9393 (Base_Type (Typ),
9394 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
9395 end Discrete_Expr_Cond;
9396
9397 -------------------------
9398 -- Discrete_Range_Cond --
9399 -------------------------
9400
9401 function Discrete_Range_Cond
9402 (Expr : Node_Id;
9403 Typ : Entity_Id) return Node_Id
9404 is
9405 LB : Node_Id := Low_Bound (Expr);
9406 HB : Node_Id := High_Bound (Expr);
9407
9408 Left_Opnd : Node_Id;
9409 Right_Opnd : Node_Id;
9410
9411 begin
9412 if Nkind (LB) = N_Identifier
9413 and then Ekind (Entity (LB)) = E_Discriminant
9414 then
9415 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9416 end if;
9417
9418 Left_Opnd :=
9419 Make_Op_Lt (Loc,
9420 Left_Opnd =>
9421 Convert_To
9422 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
9423
9424 Right_Opnd =>
9425 Convert_To
9426 (Base_Type (Typ),
9427 Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
9428
9429 if Nkind (HB) = N_Identifier
9430 and then Ekind (Entity (HB)) = E_Discriminant
9431 then
9432 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9433 end if;
9434
9435 Right_Opnd :=
9436 Make_Op_Gt (Loc,
9437 Left_Opnd =>
9438 Convert_To
9439 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
9440
9441 Right_Opnd =>
9442 Convert_To
9443 (Base_Type (Typ),
9444 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
9445
9446 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
9447 end Discrete_Range_Cond;
9448
9449 -------------------------
9450 -- Get_E_First_Or_Last --
9451 -------------------------
9452
9453 function Get_E_First_Or_Last
9454 (Loc : Source_Ptr;
9455 E : Entity_Id;
9456 Indx : Nat;
9457 Nam : Name_Id) return Node_Id
9458 is
9459 Exprs : List_Id;
9460 begin
9461 if Indx > 0 then
9462 Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
9463 else
9464 Exprs := No_List;
9465 end if;
9466
9467 return Make_Attribute_Reference (Loc,
9468 Prefix => New_Occurrence_Of (E, Loc),
9469 Attribute_Name => Nam,
9470 Expressions => Exprs);
9471 end Get_E_First_Or_Last;
9472
9473 -----------------
9474 -- Get_N_First --
9475 -----------------
9476
9477 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
9478 begin
9479 return
9480 Make_Attribute_Reference (Loc,
9481 Attribute_Name => Name_First,
9482 Prefix =>
9483 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9484 Expressions => New_List (
9485 Make_Integer_Literal (Loc, Indx)));
9486 end Get_N_First;
9487
9488 ----------------
9489 -- Get_N_Last --
9490 ----------------
9491
9492 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
9493 begin
9494 return
9495 Make_Attribute_Reference (Loc,
9496 Attribute_Name => Name_Last,
9497 Prefix =>
9498 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
9499 Expressions => New_List (
9500 Make_Integer_Literal (Loc, Indx)));
9501 end Get_N_Last;
9502
9503 ------------------
9504 -- Range_E_Cond --
9505 ------------------
9506
9507 function Range_E_Cond
9508 (Exptyp : Entity_Id;
9509 Typ : Entity_Id;
9510 Indx : Nat) return Node_Id
9511 is
9512 begin
9513 return
9514 Make_Or_Else (Loc,
9515 Left_Opnd =>
9516 Make_Op_Lt (Loc,
9517 Left_Opnd =>
9518 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9519 Right_Opnd =>
9520 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9521
9522 Right_Opnd =>
9523 Make_Op_Gt (Loc,
9524 Left_Opnd =>
9525 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9526 Right_Opnd =>
9527 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9528 end Range_E_Cond;
9529
9530 ------------------------
9531 -- Range_Equal_E_Cond --
9532 ------------------------
9533
9534 function Range_Equal_E_Cond
9535 (Exptyp : Entity_Id;
9536 Typ : Entity_Id;
9537 Indx : Nat) return Node_Id
9538 is
9539 begin
9540 return
9541 Make_Or_Else (Loc,
9542 Left_Opnd =>
9543 Make_Op_Ne (Loc,
9544 Left_Opnd =>
9545 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
9546 Right_Opnd =>
9547 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9548
9549 Right_Opnd =>
9550 Make_Op_Ne (Loc,
9551 Left_Opnd =>
9552 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
9553 Right_Opnd =>
9554 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9555 end Range_Equal_E_Cond;
9556
9557 ------------------
9558 -- Range_N_Cond --
9559 ------------------
9560
9561 function Range_N_Cond
9562 (Expr : Node_Id;
9563 Typ : Entity_Id;
9564 Indx : Nat) return Node_Id
9565 is
9566 begin
9567 return
9568 Make_Or_Else (Loc,
9569 Left_Opnd =>
9570 Make_Op_Lt (Loc,
9571 Left_Opnd =>
9572 Get_N_First (Expr, Indx),
9573 Right_Opnd =>
9574 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
9575
9576 Right_Opnd =>
9577 Make_Op_Gt (Loc,
9578 Left_Opnd =>
9579 Get_N_Last (Expr, Indx),
9580 Right_Opnd =>
9581 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
9582 end Range_N_Cond;
9583
9584 -- Start of processing for Selected_Range_Checks
9585
9586 begin
9587 if not Expander_Active then
9588 return Ret_Result;
9589 end if;
9590
9591 if Target_Typ = Any_Type
9592 or else Target_Typ = Any_Composite
9593 or else Raises_Constraint_Error (Ck_Node)
9594 then
9595 return Ret_Result;
9596 end if;
9597
9598 if No (Wnode) then
9599 Wnode := Ck_Node;
9600 end if;
9601
9602 T_Typ := Target_Typ;
9603
9604 if No (Source_Typ) then
9605 S_Typ := Etype (Ck_Node);
9606 else
9607 S_Typ := Source_Typ;
9608 end if;
9609
9610 if S_Typ = Any_Type or else S_Typ = Any_Composite then
9611 return Ret_Result;
9612 end if;
9613
9614 -- The order of evaluating T_Typ before S_Typ seems to be critical
9615 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
9616 -- in, and since Node can be an N_Range node, it might be invalid.
9617 -- Should there be an assert check somewhere for taking the Etype of
9618 -- an N_Range node ???
9619
9620 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
9621 S_Typ := Designated_Type (S_Typ);
9622 T_Typ := Designated_Type (T_Typ);
9623 Do_Access := True;
9624
9625 -- A simple optimization for the null case
9626
9627 if Known_Null (Ck_Node) then
9628 return Ret_Result;
9629 end if;
9630 end if;
9631
9632 -- For an N_Range Node, check for a null range and then if not
9633 -- null generate a range check action.
9634
9635 if Nkind (Ck_Node) = N_Range then
9636
9637 -- There's no point in checking a range against itself
9638
9639 if Ck_Node = Scalar_Range (T_Typ) then
9640 return Ret_Result;
9641 end if;
9642
9643 declare
9644 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
9645 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
9646 Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
9647 Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
9648
9649 LB : Node_Id := Low_Bound (Ck_Node);
9650 HB : Node_Id := High_Bound (Ck_Node);
9651 Known_LB : Boolean := False;
9652 Known_HB : Boolean := False;
9653
9654 Null_Range : Boolean;
9655 Out_Of_Range_L : Boolean;
9656 Out_Of_Range_H : Boolean;
9657
9658 begin
9659 -- Compute what is known at compile time
9660
9661 if Known_T_LB and Known_T_HB then
9662 if Compile_Time_Known_Value (LB) then
9663 Known_LB := True;
9664
9665 -- There's no point in checking that a bound is within its
9666 -- own range so pretend that it is known in this case. First
9667 -- deal with low bound.
9668
9669 elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype
9670 and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ)
9671 then
9672 LB := T_LB;
9673 Known_LB := True;
9674 end if;
9675
9676 -- Likewise for the high bound
9677
9678 if Compile_Time_Known_Value (HB) then
9679 Known_HB := True;
9680
9681 elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype
9682 and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ)
9683 then
9684 HB := T_HB;
9685 Known_HB := True;
9686 end if;
9687 end if;
9688
9689 -- Check for case where everything is static and we can do the
9690 -- check at compile time. This is skipped if we have an access
9691 -- type, since the access value may be null.
9692
9693 -- ??? This code can be improved since you only need to know that
9694 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9695 -- compile time to emit pertinent messages.
9696
9697 if Known_T_LB and Known_T_HB and Known_LB and Known_HB
9698 and not Do_Access
9699 then
9700 -- Floating-point case
9701
9702 if Is_Floating_Point_Type (S_Typ) then
9703 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
9704 Out_Of_Range_L :=
9705 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
9706 or else
9707 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
9708
9709 Out_Of_Range_H :=
9710 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
9711 or else
9712 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
9713
9714 -- Fixed or discrete type case
9715
9716 else
9717 Null_Range := Expr_Value (HB) < Expr_Value (LB);
9718 Out_Of_Range_L :=
9719 (Expr_Value (LB) < Expr_Value (T_LB))
9720 or else
9721 (Expr_Value (LB) > Expr_Value (T_HB));
9722
9723 Out_Of_Range_H :=
9724 (Expr_Value (HB) > Expr_Value (T_HB))
9725 or else
9726 (Expr_Value (HB) < Expr_Value (T_LB));
9727 end if;
9728
9729 if not Null_Range then
9730 if Out_Of_Range_L then
9731 if No (Warn_Node) then
9732 Add_Check
9733 (Compile_Time_Constraint_Error
9734 (Low_Bound (Ck_Node),
9735 "static value out of range of}??", T_Typ));
9736
9737 else
9738 Add_Check
9739 (Compile_Time_Constraint_Error
9740 (Wnode,
9741 "static range out of bounds of}??", T_Typ));
9742 end if;
9743 end if;
9744
9745 if Out_Of_Range_H then
9746 if No (Warn_Node) then
9747 Add_Check
9748 (Compile_Time_Constraint_Error
9749 (High_Bound (Ck_Node),
9750 "static value out of range of}??", T_Typ));
9751
9752 else
9753 Add_Check
9754 (Compile_Time_Constraint_Error
9755 (Wnode,
9756 "static range out of bounds of}??", T_Typ));
9757 end if;
9758 end if;
9759 end if;
9760
9761 else
9762 declare
9763 LB : Node_Id := Low_Bound (Ck_Node);
9764 HB : Node_Id := High_Bound (Ck_Node);
9765
9766 begin
9767 -- If either bound is a discriminant and we are within the
9768 -- record declaration, it is a use of the discriminant in a
9769 -- constraint of a component, and nothing can be checked
9770 -- here. The check will be emitted within the init proc.
9771 -- Before then, the discriminal has no real meaning.
9772 -- Similarly, if the entity is a discriminal, there is no
9773 -- check to perform yet.
9774
9775 -- The same holds within a discriminated synchronized type,
9776 -- where the discriminant may constrain a component or an
9777 -- entry family.
9778
9779 if Nkind (LB) = N_Identifier
9780 and then Denotes_Discriminant (LB, True)
9781 then
9782 if Current_Scope = Scope (Entity (LB))
9783 or else Is_Concurrent_Type (Current_Scope)
9784 or else Ekind (Entity (LB)) /= E_Discriminant
9785 then
9786 return Ret_Result;
9787 else
9788 LB :=
9789 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
9790 end if;
9791 end if;
9792
9793 if Nkind (HB) = N_Identifier
9794 and then Denotes_Discriminant (HB, True)
9795 then
9796 if Current_Scope = Scope (Entity (HB))
9797 or else Is_Concurrent_Type (Current_Scope)
9798 or else Ekind (Entity (HB)) /= E_Discriminant
9799 then
9800 return Ret_Result;
9801 else
9802 HB :=
9803 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
9804 end if;
9805 end if;
9806
9807 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
9808 Set_Paren_Count (Cond, 1);
9809
9810 Cond :=
9811 Make_And_Then (Loc,
9812 Left_Opnd =>
9813 Make_Op_Ge (Loc,
9814 Left_Opnd =>
9815 Convert_To (Base_Type (Etype (HB)),
9816 Duplicate_Subexpr_No_Checks (HB)),
9817 Right_Opnd =>
9818 Convert_To (Base_Type (Etype (LB)),
9819 Duplicate_Subexpr_No_Checks (LB))),
9820 Right_Opnd => Cond);
9821 end;
9822 end if;
9823 end;
9824
9825 elsif Is_Scalar_Type (S_Typ) then
9826
9827 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9828 -- except the above simply sets a flag in the node and lets
9829 -- gigi generate the check base on the Etype of the expression.
9830 -- Sometimes, however we want to do a dynamic check against an
9831 -- arbitrary target type, so we do that here.
9832
9833 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
9834 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9835
9836 -- For literals, we can tell if the constraint error will be
9837 -- raised at compile time, so we never need a dynamic check, but
9838 -- if the exception will be raised, then post the usual warning,
9839 -- and replace the literal with a raise constraint error
9840 -- expression. As usual, skip this for access types
9841
9842 elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
9843 declare
9844 LB : constant Node_Id := Type_Low_Bound (T_Typ);
9845 UB : constant Node_Id := Type_High_Bound (T_Typ);
9846
9847 Out_Of_Range : Boolean;
9848 Static_Bounds : constant Boolean :=
9849 Compile_Time_Known_Value (LB)
9850 and Compile_Time_Known_Value (UB);
9851
9852 begin
9853 -- Following range tests should use Sem_Eval routine ???
9854
9855 if Static_Bounds then
9856 if Is_Floating_Point_Type (S_Typ) then
9857 Out_Of_Range :=
9858 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
9859 or else
9860 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
9861
9862 -- Fixed or discrete type
9863
9864 else
9865 Out_Of_Range :=
9866 Expr_Value (Ck_Node) < Expr_Value (LB)
9867 or else
9868 Expr_Value (Ck_Node) > Expr_Value (UB);
9869 end if;
9870
9871 -- Bounds of the type are static and the literal is out of
9872 -- range so output a warning message.
9873
9874 if Out_Of_Range then
9875 if No (Warn_Node) then
9876 Add_Check
9877 (Compile_Time_Constraint_Error
9878 (Ck_Node,
9879 "static value out of range of}??", T_Typ));
9880
9881 else
9882 Add_Check
9883 (Compile_Time_Constraint_Error
9884 (Wnode,
9885 "static value out of range of}??", T_Typ));
9886 end if;
9887 end if;
9888
9889 else
9890 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9891 end if;
9892 end;
9893
9894 -- Here for the case of a non-static expression, we need a runtime
9895 -- check unless the source type range is guaranteed to be in the
9896 -- range of the target type.
9897
9898 else
9899 if not In_Subrange_Of (S_Typ, T_Typ) then
9900 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
9901 end if;
9902 end if;
9903 end if;
9904
9905 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
9906 if Is_Constrained (T_Typ) then
9907
9908 Expr_Actual := Get_Referenced_Object (Ck_Node);
9909 Exptyp := Get_Actual_Subtype (Expr_Actual);
9910
9911 if Is_Access_Type (Exptyp) then
9912 Exptyp := Designated_Type (Exptyp);
9913 end if;
9914
9915 -- String_Literal case. This needs to be handled specially be-
9916 -- cause no index types are available for string literals. The
9917 -- condition is simply:
9918
9919 -- T_Typ'Length = string-literal-length
9920
9921 if Nkind (Expr_Actual) = N_String_Literal then
9922 null;
9923
9924 -- General array case. Here we have a usable actual subtype for
9925 -- the expression, and the condition is built from the two types
9926
9927 -- T_Typ'First < Exptyp'First or else
9928 -- T_Typ'Last > Exptyp'Last or else
9929 -- T_Typ'First(1) < Exptyp'First(1) or else
9930 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9931 -- ...
9932
9933 elsif Is_Constrained (Exptyp) then
9934 declare
9935 Ndims : constant Nat := Number_Dimensions (T_Typ);
9936
9937 L_Index : Node_Id;
9938 R_Index : Node_Id;
9939
9940 begin
9941 L_Index := First_Index (T_Typ);
9942 R_Index := First_Index (Exptyp);
9943
9944 for Indx in 1 .. Ndims loop
9945 if not (Nkind (L_Index) = N_Raise_Constraint_Error
9946 or else
9947 Nkind (R_Index) = N_Raise_Constraint_Error)
9948 then
9949 -- Deal with compile time length check. Note that we
9950 -- skip this in the access case, because the access
9951 -- value may be null, so we cannot know statically.
9952
9953 if not
9954 Subtypes_Statically_Match
9955 (Etype (L_Index), Etype (R_Index))
9956 then
9957 -- If the target type is constrained then we
9958 -- have to check for exact equality of bounds
9959 -- (required for qualified expressions).
9960
9961 if Is_Constrained (T_Typ) then
9962 Evolve_Or_Else
9963 (Cond,
9964 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
9965 else
9966 Evolve_Or_Else
9967 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
9968 end if;
9969 end if;
9970
9971 Next (L_Index);
9972 Next (R_Index);
9973 end if;
9974 end loop;
9975 end;
9976
9977 -- Handle cases where we do not get a usable actual subtype that
9978 -- is constrained. This happens for example in the function call
9979 -- and explicit dereference cases. In these cases, we have to get
9980 -- the length or range from the expression itself, making sure we
9981 -- do not evaluate it more than once.
9982
9983 -- Here Ck_Node is the original expression, or more properly the
9984 -- result of applying Duplicate_Expr to the original tree,
9985 -- forcing the result to be a name.
9986
9987 else
9988 declare
9989 Ndims : constant Nat := Number_Dimensions (T_Typ);
9990
9991 begin
9992 -- Build the condition for the explicit dereference case
9993
9994 for Indx in 1 .. Ndims loop
9995 Evolve_Or_Else
9996 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
9997 end loop;
9998 end;
9999 end if;
10000
10001 else
10002 -- For a conversion to an unconstrained array type, generate an
10003 -- Action to check that the bounds of the source value are within
10004 -- the constraints imposed by the target type (RM 4.6(38)). No
10005 -- check is needed for a conversion to an access to unconstrained
10006 -- array type, as 4.6(24.15/2) requires the designated subtypes
10007 -- of the two access types to statically match.
10008
10009 if Nkind (Parent (Ck_Node)) = N_Type_Conversion
10010 and then not Do_Access
10011 then
10012 declare
10013 Opnd_Index : Node_Id;
10014 Targ_Index : Node_Id;
10015 Opnd_Range : Node_Id;
10016
10017 begin
10018 Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
10019 Targ_Index := First_Index (T_Typ);
10020 while Present (Opnd_Index) loop
10021
10022 -- If the index is a range, use its bounds. If it is an
10023 -- entity (as will be the case if it is a named subtype
10024 -- or an itype created for a slice) retrieve its range.
10025
10026 if Is_Entity_Name (Opnd_Index)
10027 and then Is_Type (Entity (Opnd_Index))
10028 then
10029 Opnd_Range := Scalar_Range (Entity (Opnd_Index));
10030 else
10031 Opnd_Range := Opnd_Index;
10032 end if;
10033
10034 if Nkind (Opnd_Range) = N_Range then
10035 if Is_In_Range
10036 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10037 Assume_Valid => True)
10038 and then
10039 Is_In_Range
10040 (High_Bound (Opnd_Range), Etype (Targ_Index),
10041 Assume_Valid => True)
10042 then
10043 null;
10044
10045 -- If null range, no check needed
10046
10047 elsif
10048 Compile_Time_Known_Value (High_Bound (Opnd_Range))
10049 and then
10050 Compile_Time_Known_Value (Low_Bound (Opnd_Range))
10051 and then
10052 Expr_Value (High_Bound (Opnd_Range)) <
10053 Expr_Value (Low_Bound (Opnd_Range))
10054 then
10055 null;
10056
10057 elsif Is_Out_Of_Range
10058 (Low_Bound (Opnd_Range), Etype (Targ_Index),
10059 Assume_Valid => True)
10060 or else
10061 Is_Out_Of_Range
10062 (High_Bound (Opnd_Range), Etype (Targ_Index),
10063 Assume_Valid => True)
10064 then
10065 Add_Check
10066 (Compile_Time_Constraint_Error
10067 (Wnode, "value out of range of}??", T_Typ));
10068
10069 else
10070 Evolve_Or_Else
10071 (Cond,
10072 Discrete_Range_Cond
10073 (Opnd_Range, Etype (Targ_Index)));
10074 end if;
10075 end if;
10076
10077 Next_Index (Opnd_Index);
10078 Next_Index (Targ_Index);
10079 end loop;
10080 end;
10081 end if;
10082 end if;
10083 end if;
10084
10085 -- Construct the test and insert into the tree
10086
10087 if Present (Cond) then
10088 if Do_Access then
10089 Cond := Guard_Access (Cond, Loc, Ck_Node);
10090 end if;
10091
10092 Add_Check
10093 (Make_Raise_Constraint_Error (Loc,
10094 Condition => Cond,
10095 Reason => CE_Range_Check_Failed));
10096 end if;
10097
10098 return Ret_Result;
10099 end Selected_Range_Checks;
10100
10101 -------------------------------
10102 -- Storage_Checks_Suppressed --
10103 -------------------------------
10104
10105 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
10106 begin
10107 if Present (E) and then Checks_May_Be_Suppressed (E) then
10108 return Is_Check_Suppressed (E, Storage_Check);
10109 else
10110 return Scope_Suppress.Suppress (Storage_Check);
10111 end if;
10112 end Storage_Checks_Suppressed;
10113
10114 ---------------------------
10115 -- Tag_Checks_Suppressed --
10116 ---------------------------
10117
10118 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
10119 begin
10120 if Present (E)
10121 and then Checks_May_Be_Suppressed (E)
10122 then
10123 return Is_Check_Suppressed (E, Tag_Check);
10124 else
10125 return Scope_Suppress.Suppress (Tag_Check);
10126 end if;
10127 end Tag_Checks_Suppressed;
10128
10129 ---------------------------------------
10130 -- Validate_Alignment_Check_Warnings --
10131 ---------------------------------------
10132
10133 procedure Validate_Alignment_Check_Warnings is
10134 begin
10135 for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop
10136 declare
10137 AWR : Alignment_Warnings_Record
10138 renames Alignment_Warnings.Table (J);
10139 begin
10140 if Known_Alignment (AWR.E)
10141 and then AWR.A mod Alignment (AWR.E) = 0
10142 then
10143 Delete_Warning_And_Continuations (AWR.W);
10144 end if;
10145 end;
10146 end loop;
10147 end Validate_Alignment_Check_Warnings;
10148
10149 --------------------------
10150 -- Validity_Check_Range --
10151 --------------------------
10152
10153 procedure Validity_Check_Range
10154 (N : Node_Id;
10155 Related_Id : Entity_Id := Empty)
10156 is
10157 begin
10158 if Validity_Checks_On and Validity_Check_Operands then
10159 if Nkind (N) = N_Range then
10160 Ensure_Valid
10161 (Expr => Low_Bound (N),
10162 Related_Id => Related_Id,
10163 Is_Low_Bound => True);
10164
10165 Ensure_Valid
10166 (Expr => High_Bound (N),
10167 Related_Id => Related_Id,
10168 Is_High_Bound => True);
10169 end if;
10170 end if;
10171 end Validity_Check_Range;
10172
10173 --------------------------------
10174 -- Validity_Checks_Suppressed --
10175 --------------------------------
10176
10177 function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
10178 begin
10179 if Present (E) and then Checks_May_Be_Suppressed (E) then
10180 return Is_Check_Suppressed (E, Validity_Check);
10181 else
10182 return Scope_Suppress.Suppress (Validity_Check);
10183 end if;
10184 end Validity_Checks_Suppressed;
10185
10186 end Checks;