]>
Commit | Line | Data |
---|---|---|
ee6ba406 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- C H E C K S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
ee6ba406 | 9 | -- -- |
f15731c4 | 10 | -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- |
ee6ba406 | 11 | -- -- |
12 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
13 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
14 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
18 | -- for more details. You should have received a copy of the GNU General -- | |
19 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
20 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
21 | -- MA 02111-1307, USA. -- | |
22 | -- -- | |
23 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
24 | -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- | |
25 | -- -- | |
26 | ------------------------------------------------------------------------------ | |
27 | ||
28 | with Atree; use Atree; | |
29 | with Debug; use Debug; | |
30 | with Einfo; use Einfo; | |
31 | with Errout; use Errout; | |
32 | with Exp_Ch2; use Exp_Ch2; | |
33 | with Exp_Util; use Exp_Util; | |
34 | with Elists; use Elists; | |
35 | with Freeze; use Freeze; | |
36 | with Nlists; use Nlists; | |
37 | with Nmake; use Nmake; | |
38 | with Opt; use Opt; | |
c2b56224 | 39 | with Restrict; use Restrict; |
ee6ba406 | 40 | with Rtsfind; use Rtsfind; |
41 | with Sem; use Sem; | |
42 | with Sem_Eval; use Sem_Eval; | |
43 | with Sem_Res; use Sem_Res; | |
44 | with Sem_Util; use Sem_Util; | |
45 | with Sem_Warn; use Sem_Warn; | |
46 | with Sinfo; use Sinfo; | |
47 | with Snames; use Snames; | |
48 | with Stand; use Stand; | |
f15731c4 | 49 | with Targparm; use Targparm; |
ee6ba406 | 50 | with Tbuild; use Tbuild; |
51 | with Ttypes; use Ttypes; | |
52 | with Urealp; use Urealp; | |
53 | with Validsw; use Validsw; | |
54 | ||
55 | package body Checks is | |
56 | ||
57 | -- General note: many of these routines are concerned with generating | |
58 | -- checking code to make sure that constraint error is raised at runtime. | |
59 | -- Clearly this code is only needed if the expander is active, since | |
60 | -- otherwise we will not be generating code or going into the runtime | |
61 | -- execution anyway. | |
62 | ||
63 | -- We therefore disconnect most of these checks if the expander is | |
64 | -- inactive. This has the additional benefit that we do not need to | |
65 | -- worry about the tree being messed up by previous errors (since errors | |
66 | -- turn off expansion anyway). | |
67 | ||
68 | -- There are a few exceptions to the above rule. For instance routines | |
69 | -- such as Apply_Scalar_Range_Check that do not insert any code can be | |
70 | -- safely called even when the Expander is inactive (but Errors_Detected | |
71 | -- is 0). The benefit of executing this code when expansion is off, is | |
72 | -- the ability to emit constraint error warning for static expressions | |
73 | -- even when we are not generating code. | |
74 | ||
75 | ---------------------------- | |
76 | -- Local Subprogram Specs -- | |
77 | ---------------------------- | |
78 | ||
79 | procedure Apply_Selected_Length_Checks | |
80 | (Ck_Node : Node_Id; | |
81 | Target_Typ : Entity_Id; | |
82 | Source_Typ : Entity_Id; | |
83 | Do_Static : Boolean); | |
84 | -- This is the subprogram that does all the work for Apply_Length_Check | |
85 | -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as | |
86 | -- described for the above routines. The Do_Static flag indicates that | |
87 | -- only a static check is to be done. | |
88 | ||
89 | procedure Apply_Selected_Range_Checks | |
90 | (Ck_Node : Node_Id; | |
91 | Target_Typ : Entity_Id; | |
92 | Source_Typ : Entity_Id; | |
93 | Do_Static : Boolean); | |
94 | -- This is the subprogram that does all the work for Apply_Range_Check. | |
95 | -- Expr, Target_Typ and Source_Typ are as described for the above | |
96 | -- routine. The Do_Static flag indicates that only a static check is | |
97 | -- to be done. | |
98 | ||
99 | function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; | |
100 | -- If a discriminal is used in constraining a prival, Return reference | |
101 | -- to the discriminal of the protected body (which renames the parameter | |
102 | -- of the enclosing protected operation). This clumsy transformation is | |
103 | -- needed because privals are created too late and their actual subtypes | |
104 | -- are not available when analysing the bodies of the protected operations. | |
105 | -- To be cleaned up??? | |
106 | ||
107 | function Guard_Access | |
108 | (Cond : Node_Id; | |
109 | Loc : Source_Ptr; | |
110 | Ck_Node : Node_Id) | |
111 | return Node_Id; | |
112 | -- In the access type case, guard the test with a test to ensure | |
113 | -- that the access value is non-null, since the checks do not | |
114 | -- not apply to null access values. | |
115 | ||
116 | procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); | |
117 | -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the | |
118 | -- Constraint_Error node. | |
119 | ||
120 | function Selected_Length_Checks | |
121 | (Ck_Node : Node_Id; | |
122 | Target_Typ : Entity_Id; | |
123 | Source_Typ : Entity_Id; | |
124 | Warn_Node : Node_Id) | |
125 | return Check_Result; | |
126 | -- Like Apply_Selected_Length_Checks, except it doesn't modify | |
127 | -- anything, just returns a list of nodes as described in the spec of | |
128 | -- this package for the Range_Check function. | |
129 | ||
130 | function Selected_Range_Checks | |
131 | (Ck_Node : Node_Id; | |
132 | Target_Typ : Entity_Id; | |
133 | Source_Typ : Entity_Id; | |
134 | Warn_Node : Node_Id) | |
135 | return Check_Result; | |
136 | -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, | |
137 | -- just returns a list of nodes as described in the spec of this package | |
138 | -- for the Range_Check function. | |
139 | ||
140 | ------------------------------ | |
141 | -- Access_Checks_Suppressed -- | |
142 | ------------------------------ | |
143 | ||
144 | function Access_Checks_Suppressed (E : Entity_Id) return Boolean is | |
145 | begin | |
146 | return Scope_Suppress.Access_Checks | |
147 | or else (Present (E) and then Suppress_Access_Checks (E)); | |
148 | end Access_Checks_Suppressed; | |
149 | ||
150 | ------------------------------------- | |
151 | -- Accessibility_Checks_Suppressed -- | |
152 | ------------------------------------- | |
153 | ||
154 | function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is | |
155 | begin | |
156 | return Scope_Suppress.Accessibility_Checks | |
157 | or else (Present (E) and then Suppress_Accessibility_Checks (E)); | |
158 | end Accessibility_Checks_Suppressed; | |
159 | ||
160 | ------------------------- | |
161 | -- Append_Range_Checks -- | |
162 | ------------------------- | |
163 | ||
164 | procedure Append_Range_Checks | |
165 | (Checks : Check_Result; | |
166 | Stmts : List_Id; | |
167 | Suppress_Typ : Entity_Id; | |
168 | Static_Sloc : Source_Ptr; | |
169 | Flag_Node : Node_Id) | |
170 | is | |
171 | Internal_Flag_Node : Node_Id := Flag_Node; | |
172 | Internal_Static_Sloc : Source_Ptr := Static_Sloc; | |
173 | Checks_On : constant Boolean := | |
174 | (not Index_Checks_Suppressed (Suppress_Typ)) | |
175 | or else | |
176 | (not Range_Checks_Suppressed (Suppress_Typ)); | |
177 | ||
178 | begin | |
179 | -- For now we just return if Checks_On is false, however this should | |
180 | -- be enhanced to check for an always True value in the condition | |
181 | -- and to generate a compilation warning??? | |
182 | ||
183 | if not Checks_On then | |
184 | return; | |
185 | end if; | |
186 | ||
187 | for J in 1 .. 2 loop | |
188 | exit when No (Checks (J)); | |
189 | ||
190 | if Nkind (Checks (J)) = N_Raise_Constraint_Error | |
191 | and then Present (Condition (Checks (J))) | |
192 | then | |
193 | if not Has_Dynamic_Range_Check (Internal_Flag_Node) then | |
194 | Append_To (Stmts, Checks (J)); | |
195 | Set_Has_Dynamic_Range_Check (Internal_Flag_Node); | |
196 | end if; | |
197 | ||
198 | else | |
199 | Append_To | |
f15731c4 | 200 | (Stmts, |
201 | Make_Raise_Constraint_Error (Internal_Static_Sloc, | |
202 | Reason => CE_Range_Check_Failed)); | |
ee6ba406 | 203 | end if; |
204 | end loop; | |
205 | end Append_Range_Checks; | |
206 | ||
207 | ------------------------ | |
208 | -- Apply_Access_Check -- | |
209 | ------------------------ | |
210 | ||
211 | procedure Apply_Access_Check (N : Node_Id) is | |
212 | P : constant Node_Id := Prefix (N); | |
213 | ||
214 | begin | |
215 | if Inside_A_Generic then | |
216 | return; | |
217 | end if; | |
218 | ||
219 | if Is_Entity_Name (P) then | |
220 | Check_Unset_Reference (P); | |
221 | end if; | |
222 | ||
223 | if Is_Entity_Name (P) | |
224 | and then Access_Checks_Suppressed (Entity (P)) | |
225 | then | |
226 | return; | |
227 | ||
228 | elsif Access_Checks_Suppressed (Etype (P)) then | |
229 | return; | |
230 | ||
231 | else | |
232 | Set_Do_Access_Check (N, True); | |
233 | end if; | |
234 | end Apply_Access_Check; | |
235 | ||
236 | ------------------------------- | |
237 | -- Apply_Accessibility_Check -- | |
238 | ------------------------------- | |
239 | ||
240 | procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is | |
241 | Loc : constant Source_Ptr := Sloc (N); | |
242 | Param_Ent : constant Entity_Id := Param_Entity (N); | |
243 | Param_Level : Node_Id; | |
244 | Type_Level : Node_Id; | |
245 | ||
246 | begin | |
247 | if Inside_A_Generic then | |
248 | return; | |
249 | ||
250 | -- Only apply the run-time check if the access parameter | |
251 | -- has an associated extra access level parameter and | |
252 | -- when the level of the type is less deep than the level | |
253 | -- of the access parameter. | |
254 | ||
255 | elsif Present (Param_Ent) | |
256 | and then Present (Extra_Accessibility (Param_Ent)) | |
257 | and then UI_Gt (Object_Access_Level (N), | |
258 | Type_Access_Level (Typ)) | |
259 | and then not Accessibility_Checks_Suppressed (Param_Ent) | |
260 | and then not Accessibility_Checks_Suppressed (Typ) | |
261 | then | |
262 | Param_Level := | |
263 | New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); | |
264 | ||
265 | Type_Level := | |
266 | Make_Integer_Literal (Loc, Type_Access_Level (Typ)); | |
267 | ||
268 | -- Raise Program_Error if the accessibility level of the | |
269 | -- the access parameter is deeper than the level of the | |
270 | -- target access type. | |
271 | ||
272 | Insert_Action (N, | |
273 | Make_Raise_Program_Error (Loc, | |
274 | Condition => | |
275 | Make_Op_Gt (Loc, | |
276 | Left_Opnd => Param_Level, | |
f15731c4 | 277 | Right_Opnd => Type_Level), |
278 | Reason => PE_Accessibility_Check_Failed)); | |
ee6ba406 | 279 | |
280 | Analyze_And_Resolve (N); | |
281 | end if; | |
282 | end Apply_Accessibility_Check; | |
283 | ||
c2b56224 | 284 | --------------------------- |
285 | -- Apply_Alignment_Check -- | |
286 | --------------------------- | |
287 | ||
288 | procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is | |
289 | AC : constant Node_Id := Address_Clause (E); | |
290 | Expr : Node_Id; | |
291 | Loc : Source_Ptr; | |
292 | ||
293 | begin | |
294 | if No (AC) or else Range_Checks_Suppressed (E) then | |
295 | return; | |
296 | end if; | |
297 | ||
298 | Loc := Sloc (AC); | |
299 | Expr := Expression (AC); | |
300 | ||
301 | if Nkind (Expr) = N_Unchecked_Type_Conversion then | |
302 | Expr := Expression (Expr); | |
303 | ||
304 | elsif Nkind (Expr) = N_Function_Call | |
305 | and then Is_RTE (Entity (Name (Expr)), RE_To_Address) | |
306 | then | |
307 | Expr := First (Parameter_Associations (Expr)); | |
308 | ||
309 | if Nkind (Expr) = N_Parameter_Association then | |
310 | Expr := Explicit_Actual_Parameter (Expr); | |
311 | end if; | |
312 | end if; | |
313 | ||
314 | -- Here Expr is the address value. See if we know that the | |
315 | -- value is unacceptable at compile time. | |
316 | ||
317 | if Compile_Time_Known_Value (Expr) | |
318 | and then Known_Alignment (E) | |
319 | then | |
320 | if Expr_Value (Expr) mod Alignment (E) /= 0 then | |
f15731c4 | 321 | Insert_Action (N, |
322 | Make_Raise_Program_Error (Loc, | |
323 | Reason => PE_Misaligned_Address_Value)); | |
324 | Error_Msg_NE | |
325 | ("?specified address for& not " & | |
326 | "consistent with alignment", Expr, E); | |
c2b56224 | 327 | end if; |
328 | ||
329 | -- Here we do not know if the value is acceptable, generate | |
330 | -- code to raise PE if alignment is inappropriate. | |
331 | ||
332 | else | |
333 | -- Skip generation of this code if we don't want elab code | |
334 | ||
335 | if not Restrictions (No_Elaboration_Code) then | |
336 | Insert_After_And_Analyze (N, | |
337 | Make_Raise_Program_Error (Loc, | |
338 | Condition => | |
339 | Make_Op_Ne (Loc, | |
340 | Left_Opnd => | |
341 | Make_Op_Mod (Loc, | |
342 | Left_Opnd => | |
343 | Unchecked_Convert_To | |
344 | (RTE (RE_Integer_Address), | |
345 | Duplicate_Subexpr (Expr)), | |
346 | Right_Opnd => | |
347 | Make_Attribute_Reference (Loc, | |
348 | Prefix => New_Occurrence_Of (E, Loc), | |
349 | Attribute_Name => Name_Alignment)), | |
f15731c4 | 350 | Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
351 | Reason => PE_Misaligned_Address_Value), | |
c2b56224 | 352 | Suppress => All_Checks); |
353 | end if; | |
354 | end if; | |
355 | ||
356 | return; | |
357 | end Apply_Alignment_Check; | |
358 | ||
ee6ba406 | 359 | ------------------------------------- |
360 | -- Apply_Arithmetic_Overflow_Check -- | |
361 | ------------------------------------- | |
362 | ||
363 | -- This routine is called only if the type is an integer type, and | |
364 | -- a software arithmetic overflow check must be performed for op | |
365 | -- (add, subtract, multiply). The check is performed only if | |
366 | -- Software_Overflow_Checking is enabled and Do_Overflow_Check | |
367 | -- is set. In this case we expand the operation into a more complex | |
368 | -- sequence of tests that ensures that overflow is properly caught. | |
369 | ||
370 | procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is | |
371 | Loc : constant Source_Ptr := Sloc (N); | |
372 | Typ : constant Entity_Id := Etype (N); | |
373 | Rtyp : constant Entity_Id := Root_Type (Typ); | |
374 | Siz : constant Int := UI_To_Int (Esize (Rtyp)); | |
375 | Dsiz : constant Int := Siz * 2; | |
376 | Opnod : Node_Id; | |
377 | Ctyp : Entity_Id; | |
378 | Opnd : Node_Id; | |
379 | Cent : RE_Id; | |
380 | Lo : Uint; | |
381 | Hi : Uint; | |
382 | OK : Boolean; | |
383 | ||
384 | begin | |
f15731c4 | 385 | if Backend_Overflow_Checks_On_Target |
386 | or not Do_Overflow_Check (N) | |
387 | or not Expander_Active | |
ee6ba406 | 388 | then |
389 | return; | |
390 | end if; | |
391 | ||
392 | -- Nothing to do if the range of the result is known OK | |
393 | ||
394 | Determine_Range (N, OK, Lo, Hi); | |
395 | ||
396 | -- Note in the test below that we assume that if a bound of the | |
397 | -- range is equal to that of the type. That's not quite accurate | |
398 | -- but we do this for the following reasons: | |
399 | ||
400 | -- a) The way that Determine_Range works, it will typically report | |
401 | -- the bounds of the value are the bounds of the type, because | |
402 | -- it either can't tell anything more precise, or does not think | |
403 | -- it is worth the effort to be more precise. | |
404 | ||
405 | -- b) It is very unusual to have a situation in which this would | |
406 | -- generate an unnecessary overflow check (an example would be | |
407 | -- a subtype with a range 0 .. Integer'Last - 1 to which the | |
408 | -- literal value one is added. | |
409 | ||
410 | -- c) The alternative is a lot of special casing in this routine | |
411 | -- which would partially duplicate the Determine_Range processing. | |
412 | ||
413 | if OK | |
414 | and then Lo > Expr_Value (Type_Low_Bound (Typ)) | |
415 | and then Hi < Expr_Value (Type_High_Bound (Typ)) | |
416 | then | |
417 | return; | |
418 | end if; | |
419 | ||
420 | -- None of the special case optimizations worked, so there is nothing | |
421 | -- for it but to generate the full general case code: | |
422 | ||
423 | -- x op y | |
424 | ||
425 | -- is expanded into | |
426 | ||
427 | -- Typ (Checktyp (x) op Checktyp (y)); | |
428 | ||
429 | -- where Typ is the type of the original expression, and Checktyp is | |
430 | -- an integer type of sufficient length to hold the largest possible | |
431 | -- result. | |
432 | ||
433 | -- In the case where check type exceeds the size of Long_Long_Integer, | |
434 | -- we use a different approach, expanding to: | |
435 | ||
436 | -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) | |
437 | ||
438 | -- where xxx is Add, Multiply or Subtract as appropriate | |
439 | ||
440 | -- Find check type if one exists | |
441 | ||
442 | if Dsiz <= Standard_Integer_Size then | |
443 | Ctyp := Standard_Integer; | |
444 | ||
445 | elsif Dsiz <= Standard_Long_Long_Integer_Size then | |
446 | Ctyp := Standard_Long_Long_Integer; | |
447 | ||
448 | -- No check type exists, use runtime call | |
449 | ||
450 | else | |
451 | if Nkind (N) = N_Op_Add then | |
452 | Cent := RE_Add_With_Ovflo_Check; | |
453 | ||
454 | elsif Nkind (N) = N_Op_Multiply then | |
455 | Cent := RE_Multiply_With_Ovflo_Check; | |
456 | ||
457 | else | |
458 | pragma Assert (Nkind (N) = N_Op_Subtract); | |
459 | Cent := RE_Subtract_With_Ovflo_Check; | |
460 | end if; | |
461 | ||
462 | Rewrite (N, | |
463 | OK_Convert_To (Typ, | |
464 | Make_Function_Call (Loc, | |
465 | Name => New_Reference_To (RTE (Cent), Loc), | |
466 | Parameter_Associations => New_List ( | |
467 | OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), | |
468 | OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); | |
469 | ||
470 | Analyze_And_Resolve (N, Typ); | |
471 | return; | |
472 | end if; | |
473 | ||
474 | -- If we fall through, we have the case where we do the arithmetic in | |
475 | -- the next higher type and get the check by conversion. In these cases | |
476 | -- Ctyp is set to the type to be used as the check type. | |
477 | ||
478 | Opnod := Relocate_Node (N); | |
479 | ||
480 | Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); | |
481 | ||
482 | Analyze (Opnd); | |
483 | Set_Etype (Opnd, Ctyp); | |
484 | Set_Analyzed (Opnd, True); | |
485 | Set_Left_Opnd (Opnod, Opnd); | |
486 | ||
487 | Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); | |
488 | ||
489 | Analyze (Opnd); | |
490 | Set_Etype (Opnd, Ctyp); | |
491 | Set_Analyzed (Opnd, True); | |
492 | Set_Right_Opnd (Opnod, Opnd); | |
493 | ||
494 | -- The type of the operation changes to the base type of the check | |
495 | -- type, and we reset the overflow check indication, since clearly | |
496 | -- no overflow is possible now that we are using a double length | |
497 | -- type. We also set the Analyzed flag to avoid a recursive attempt | |
498 | -- to expand the node. | |
499 | ||
500 | Set_Etype (Opnod, Base_Type (Ctyp)); | |
501 | Set_Do_Overflow_Check (Opnod, False); | |
502 | Set_Analyzed (Opnod, True); | |
503 | ||
504 | -- Now build the outer conversion | |
505 | ||
506 | Opnd := OK_Convert_To (Typ, Opnod); | |
507 | ||
508 | Analyze (Opnd); | |
509 | Set_Etype (Opnd, Typ); | |
510 | Set_Analyzed (Opnd, True); | |
511 | Set_Do_Overflow_Check (Opnd, True); | |
512 | ||
513 | Rewrite (N, Opnd); | |
514 | end Apply_Arithmetic_Overflow_Check; | |
515 | ||
516 | ---------------------------- | |
517 | -- Apply_Array_Size_Check -- | |
518 | ---------------------------- | |
519 | ||
520 | -- Note: Really of course this entre check should be in the backend, | |
521 | -- and perhaps this is not quite the right value, but it is good | |
522 | -- enough to catch the normal cases (and the relevant ACVC tests!) | |
523 | ||
524 | procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is | |
525 | Loc : constant Source_Ptr := Sloc (N); | |
526 | Ctyp : constant Entity_Id := Component_Type (Typ); | |
527 | Ent : constant Entity_Id := Defining_Identifier (N); | |
528 | Decl : Node_Id; | |
529 | Lo : Node_Id; | |
530 | Hi : Node_Id; | |
531 | Lob : Uint; | |
532 | Hib : Uint; | |
533 | Siz : Uint; | |
534 | Xtyp : Entity_Id; | |
535 | Indx : Node_Id; | |
536 | Sizx : Node_Id; | |
537 | Code : Node_Id; | |
538 | ||
539 | Static : Boolean := True; | |
540 | -- Set false if any index subtye bound is non-static | |
541 | ||
542 | Umark : constant Uintp.Save_Mark := Uintp.Mark; | |
543 | -- We can throw away all the Uint computations here, since they are | |
544 | -- done only to generate boolean test results. | |
545 | ||
546 | Check_Siz : Uint; | |
547 | -- Size to check against | |
548 | ||
549 | function Is_Address_Or_Import (Decl : Node_Id) return Boolean; | |
550 | -- Determines if Decl is an address clause or Import/Interface pragma | |
551 | -- that references the defining identifier of the current declaration. | |
552 | ||
553 | -------------------------- | |
554 | -- Is_Address_Or_Import -- | |
555 | -------------------------- | |
556 | ||
557 | function Is_Address_Or_Import (Decl : Node_Id) return Boolean is | |
558 | begin | |
559 | if Nkind (Decl) = N_At_Clause then | |
560 | return Chars (Identifier (Decl)) = Chars (Ent); | |
561 | ||
562 | elsif Nkind (Decl) = N_Attribute_Definition_Clause then | |
563 | return | |
564 | Chars (Decl) = Name_Address | |
565 | and then | |
566 | Nkind (Name (Decl)) = N_Identifier | |
567 | and then | |
568 | Chars (Name (Decl)) = Chars (Ent); | |
569 | ||
570 | elsif Nkind (Decl) = N_Pragma then | |
571 | if (Chars (Decl) = Name_Import | |
572 | or else | |
573 | Chars (Decl) = Name_Interface) | |
574 | and then Present (Pragma_Argument_Associations (Decl)) | |
575 | then | |
576 | declare | |
577 | F : constant Node_Id := | |
578 | First (Pragma_Argument_Associations (Decl)); | |
579 | ||
580 | begin | |
581 | return | |
582 | Present (F) | |
583 | and then | |
584 | Present (Next (F)) | |
585 | and then | |
586 | Nkind (Expression (Next (F))) = N_Identifier | |
587 | and then | |
588 | Chars (Expression (Next (F))) = Chars (Ent); | |
589 | end; | |
590 | ||
591 | else | |
592 | return False; | |
593 | end if; | |
594 | ||
595 | else | |
596 | return False; | |
597 | end if; | |
598 | end Is_Address_Or_Import; | |
599 | ||
600 | -- Start of processing for Apply_Array_Size_Check | |
601 | ||
602 | begin | |
603 | if not Expander_Active | |
604 | or else Storage_Checks_Suppressed (Typ) | |
605 | then | |
606 | return; | |
607 | end if; | |
608 | ||
609 | -- It is pointless to insert this check inside an _init_proc, because | |
610 | -- that's too late, we have already built the object to be the right | |
611 | -- size, and if it's too large, too bad! | |
612 | ||
613 | if Inside_Init_Proc then | |
614 | return; | |
615 | end if; | |
616 | ||
617 | -- Look head for pragma interface/import or address clause applying | |
618 | -- to this entity. If found, we suppress the check entirely. For now | |
619 | -- we only look ahead 20 declarations to stop this becoming too slow | |
620 | -- Note that eventually this whole routine gets moved to gigi. | |
621 | ||
622 | Decl := N; | |
623 | for Ctr in 1 .. 20 loop | |
624 | Next (Decl); | |
625 | exit when No (Decl); | |
626 | ||
627 | if Is_Address_Or_Import (Decl) then | |
628 | return; | |
629 | end if; | |
630 | end loop; | |
631 | ||
632 | -- First step is to calculate the maximum number of elements. For this | |
633 | -- calculation, we use the actual size of the subtype if it is static, | |
634 | -- and if a bound of a subtype is non-static, we go to the bound of the | |
635 | -- base type. | |
636 | ||
637 | Siz := Uint_1; | |
638 | Indx := First_Index (Typ); | |
639 | while Present (Indx) loop | |
640 | Xtyp := Etype (Indx); | |
641 | Lo := Type_Low_Bound (Xtyp); | |
642 | Hi := Type_High_Bound (Xtyp); | |
643 | ||
644 | -- If any bound raises constraint error, we will never get this | |
645 | -- far, so there is no need to generate any kind of check. | |
646 | ||
647 | if Raises_Constraint_Error (Lo) | |
648 | or else | |
649 | Raises_Constraint_Error (Hi) | |
650 | then | |
651 | Uintp.Release (Umark); | |
652 | return; | |
653 | end if; | |
654 | ||
655 | -- Otherwise get bounds values | |
656 | ||
657 | if Is_Static_Expression (Lo) then | |
658 | Lob := Expr_Value (Lo); | |
659 | else | |
660 | Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp))); | |
661 | Static := False; | |
662 | end if; | |
663 | ||
664 | if Is_Static_Expression (Hi) then | |
665 | Hib := Expr_Value (Hi); | |
666 | else | |
667 | Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp))); | |
668 | Static := False; | |
669 | end if; | |
670 | ||
671 | Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0); | |
672 | Next_Index (Indx); | |
673 | end loop; | |
674 | ||
675 | -- Compute the limit against which we want to check. For subprograms, | |
676 | -- where the array will go on the stack, we use 8*2**24, which (in | |
677 | -- bits) is the size of a 16 megabyte array. | |
678 | ||
679 | if Is_Subprogram (Scope (Ent)) then | |
680 | Check_Siz := Uint_2 ** 27; | |
681 | else | |
682 | Check_Siz := Uint_2 ** 31; | |
683 | end if; | |
684 | ||
685 | -- If we have all static bounds and Siz is too large, then we know we | |
686 | -- know we have a storage error right now, so generate message | |
687 | ||
688 | if Static and then Siz >= Check_Siz then | |
689 | Insert_Action (N, | |
f15731c4 | 690 | Make_Raise_Storage_Error (Loc, |
691 | Reason => SE_Object_Too_Large)); | |
ee6ba406 | 692 | Warn_On_Instance := True; |
693 | Error_Msg_N ("?Storage_Error will be raised at run-time", N); | |
694 | Warn_On_Instance := False; | |
695 | Uintp.Release (Umark); | |
696 | return; | |
697 | end if; | |
698 | ||
699 | -- Case of component size known at compile time. If the array | |
700 | -- size is definitely in range, then we do not need a check. | |
701 | ||
702 | if Known_Esize (Ctyp) | |
703 | and then Siz * Esize (Ctyp) < Check_Siz | |
704 | then | |
705 | Uintp.Release (Umark); | |
706 | return; | |
707 | end if; | |
708 | ||
709 | -- Here if a dynamic check is required | |
710 | ||
711 | -- What we do is to build an expression for the size of the array, | |
712 | -- which is computed as the 'Size of the array component, times | |
713 | -- the size of each dimension. | |
714 | ||
715 | Uintp.Release (Umark); | |
716 | ||
717 | Sizx := | |
718 | Make_Attribute_Reference (Loc, | |
719 | Prefix => New_Occurrence_Of (Ctyp, Loc), | |
720 | Attribute_Name => Name_Size); | |
721 | ||
722 | Indx := First_Index (Typ); | |
723 | ||
724 | for J in 1 .. Number_Dimensions (Typ) loop | |
725 | ||
726 | if Sloc (Etype (Indx)) = Sloc (N) then | |
727 | Ensure_Defined (Etype (Indx), N); | |
728 | end if; | |
729 | ||
730 | Sizx := | |
731 | Make_Op_Multiply (Loc, | |
732 | Left_Opnd => Sizx, | |
733 | Right_Opnd => | |
734 | Make_Attribute_Reference (Loc, | |
735 | Prefix => New_Occurrence_Of (Typ, Loc), | |
736 | Attribute_Name => Name_Length, | |
737 | Expressions => New_List ( | |
738 | Make_Integer_Literal (Loc, J)))); | |
739 | Next_Index (Indx); | |
740 | end loop; | |
741 | ||
742 | Code := | |
743 | Make_Raise_Storage_Error (Loc, | |
744 | Condition => | |
745 | Make_Op_Ge (Loc, | |
746 | Left_Opnd => Sizx, | |
747 | Right_Opnd => | |
f15731c4 | 748 | Make_Integer_Literal (Loc, Check_Siz)), |
749 | Reason => SE_Object_Too_Large); | |
ee6ba406 | 750 | |
751 | Set_Size_Check_Code (Defining_Identifier (N), Code); | |
752 | Insert_Action (N, Code); | |
ee6ba406 | 753 | end Apply_Array_Size_Check; |
754 | ||
755 | ---------------------------- | |
756 | -- Apply_Constraint_Check -- | |
757 | ---------------------------- | |
758 | ||
759 | procedure Apply_Constraint_Check | |
760 | (N : Node_Id; | |
761 | Typ : Entity_Id; | |
762 | No_Sliding : Boolean := False) | |
763 | is | |
764 | Desig_Typ : Entity_Id; | |
765 | ||
766 | begin | |
767 | if Inside_A_Generic then | |
768 | return; | |
769 | ||
770 | elsif Is_Scalar_Type (Typ) then | |
771 | Apply_Scalar_Range_Check (N, Typ); | |
772 | ||
773 | elsif Is_Array_Type (Typ) then | |
774 | ||
5f260d20 | 775 | -- A useful optimization: an aggregate with only an Others clause |
776 | -- always has the right bounds. | |
777 | ||
778 | if Nkind (N) = N_Aggregate | |
779 | and then No (Expressions (N)) | |
780 | and then Nkind | |
781 | (First (Choices (First (Component_Associations (N))))) | |
782 | = N_Others_Choice | |
783 | then | |
784 | return; | |
785 | end if; | |
786 | ||
ee6ba406 | 787 | if Is_Constrained (Typ) then |
788 | Apply_Length_Check (N, Typ); | |
789 | ||
790 | if No_Sliding then | |
791 | Apply_Range_Check (N, Typ); | |
792 | end if; | |
793 | else | |
794 | Apply_Range_Check (N, Typ); | |
795 | end if; | |
796 | ||
797 | elsif (Is_Record_Type (Typ) | |
798 | or else Is_Private_Type (Typ)) | |
799 | and then Has_Discriminants (Base_Type (Typ)) | |
800 | and then Is_Constrained (Typ) | |
801 | then | |
802 | Apply_Discriminant_Check (N, Typ); | |
803 | ||
804 | elsif Is_Access_Type (Typ) then | |
805 | ||
806 | Desig_Typ := Designated_Type (Typ); | |
807 | ||
808 | -- No checks necessary if expression statically null | |
809 | ||
810 | if Nkind (N) = N_Null then | |
811 | null; | |
812 | ||
813 | -- No sliding possible on access to arrays | |
814 | ||
815 | elsif Is_Array_Type (Desig_Typ) then | |
816 | if Is_Constrained (Desig_Typ) then | |
817 | Apply_Length_Check (N, Typ); | |
818 | end if; | |
819 | ||
820 | Apply_Range_Check (N, Typ); | |
821 | ||
822 | elsif Has_Discriminants (Base_Type (Desig_Typ)) | |
823 | and then Is_Constrained (Desig_Typ) | |
824 | then | |
825 | Apply_Discriminant_Check (N, Typ); | |
826 | end if; | |
827 | end if; | |
828 | end Apply_Constraint_Check; | |
829 | ||
830 | ------------------------------ | |
831 | -- Apply_Discriminant_Check -- | |
832 | ------------------------------ | |
833 | ||
834 | procedure Apply_Discriminant_Check | |
835 | (N : Node_Id; | |
836 | Typ : Entity_Id; | |
837 | Lhs : Node_Id := Empty) | |
838 | is | |
839 | Loc : constant Source_Ptr := Sloc (N); | |
840 | Do_Access : constant Boolean := Is_Access_Type (Typ); | |
841 | S_Typ : Entity_Id := Etype (N); | |
842 | Cond : Node_Id; | |
843 | T_Typ : Entity_Id; | |
844 | ||
845 | function Is_Aliased_Unconstrained_Component return Boolean; | |
846 | -- It is possible for an aliased component to have a nominal | |
847 | -- unconstrained subtype (through instantiation). If this is a | |
848 | -- discriminated component assigned in the expansion of an aggregate | |
849 | -- in an initialization, the check must be suppressed. This unusual | |
850 | -- situation requires a predicate of its own (see 7503-008). | |
851 | ||
852 | ---------------------------------------- | |
853 | -- Is_Aliased_Unconstrained_Component -- | |
854 | ---------------------------------------- | |
855 | ||
856 | function Is_Aliased_Unconstrained_Component return Boolean is | |
857 | Comp : Entity_Id; | |
858 | Pref : Node_Id; | |
859 | ||
860 | begin | |
861 | if Nkind (Lhs) /= N_Selected_Component then | |
862 | return False; | |
863 | else | |
864 | Comp := Entity (Selector_Name (Lhs)); | |
865 | Pref := Prefix (Lhs); | |
866 | end if; | |
867 | ||
868 | if Ekind (Comp) /= E_Component | |
869 | or else not Is_Aliased (Comp) | |
870 | then | |
871 | return False; | |
872 | end if; | |
873 | ||
874 | return not Comes_From_Source (Pref) | |
875 | and then In_Instance | |
876 | and then not Is_Constrained (Etype (Comp)); | |
877 | end Is_Aliased_Unconstrained_Component; | |
878 | ||
879 | -- Start of processing for Apply_Discriminant_Check | |
880 | ||
881 | begin | |
882 | if Do_Access then | |
883 | T_Typ := Designated_Type (Typ); | |
884 | else | |
885 | T_Typ := Typ; | |
886 | end if; | |
887 | ||
888 | -- Nothing to do if discriminant checks are suppressed or else no code | |
889 | -- is to be generated | |
890 | ||
891 | if not Expander_Active | |
892 | or else Discriminant_Checks_Suppressed (T_Typ) | |
893 | then | |
894 | return; | |
895 | end if; | |
896 | ||
897 | -- No discriminant checks necessary for access when expression | |
898 | -- is statically Null. This is not only an optimization, this is | |
899 | -- fundamental because otherwise discriminant checks may be generated | |
900 | -- in init procs for types containing an access to a non-frozen yet | |
901 | -- record, causing a deadly forward reference. | |
902 | ||
903 | -- Also, if the expression is of an access type whose designated | |
904 | -- type is incomplete, then the access value must be null and | |
905 | -- we suppress the check. | |
906 | ||
907 | if Nkind (N) = N_Null then | |
908 | return; | |
909 | ||
910 | elsif Is_Access_Type (S_Typ) then | |
911 | S_Typ := Designated_Type (S_Typ); | |
912 | ||
913 | if Ekind (S_Typ) = E_Incomplete_Type then | |
914 | return; | |
915 | end if; | |
916 | end if; | |
917 | ||
918 | -- If an assignment target is present, then we need to generate | |
919 | -- the actual subtype if the target is a parameter or aliased | |
920 | -- object with an unconstrained nominal subtype. | |
921 | ||
922 | if Present (Lhs) | |
923 | and then (Present (Param_Entity (Lhs)) | |
924 | or else (not Is_Constrained (T_Typ) | |
925 | and then Is_Aliased_View (Lhs) | |
926 | and then not Is_Aliased_Unconstrained_Component)) | |
927 | then | |
928 | T_Typ := Get_Actual_Subtype (Lhs); | |
929 | end if; | |
930 | ||
931 | -- Nothing to do if the type is unconstrained (this is the case | |
932 | -- where the actual subtype in the RM sense of N is unconstrained | |
933 | -- and no check is required). | |
934 | ||
935 | if not Is_Constrained (T_Typ) then | |
936 | return; | |
937 | end if; | |
938 | ||
939 | -- Suppress checks if the subtypes are the same. | |
940 | -- the check must be preserved in an assignment to a formal, because | |
941 | -- the constraint is given by the actual. | |
942 | ||
943 | if Nkind (Original_Node (N)) /= N_Allocator | |
944 | and then (No (Lhs) | |
945 | or else not Is_Entity_Name (Lhs) | |
946 | or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter | |
947 | and then Ekind (Entity (Lhs)) /= E_Out_Parameter)) | |
948 | then | |
949 | if (Etype (N) = Typ | |
950 | or else (Do_Access and then Designated_Type (Typ) = S_Typ)) | |
951 | and then not Is_Aliased_View (Lhs) | |
952 | then | |
953 | return; | |
954 | end if; | |
955 | ||
956 | -- We can also eliminate checks on allocators with a subtype mark | |
957 | -- that coincides with the context type. The context type may be a | |
958 | -- subtype without a constraint (common case, a generic actual). | |
959 | ||
960 | elsif Nkind (Original_Node (N)) = N_Allocator | |
961 | and then Is_Entity_Name (Expression (Original_Node (N))) | |
962 | then | |
963 | declare | |
964 | Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N))); | |
965 | ||
966 | begin | |
967 | if Alloc_Typ = T_Typ | |
968 | or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration | |
969 | and then Is_Entity_Name ( | |
970 | Subtype_Indication (Parent (T_Typ))) | |
971 | and then Alloc_Typ = Base_Type (T_Typ)) | |
972 | ||
973 | then | |
974 | return; | |
975 | end if; | |
976 | end; | |
977 | end if; | |
978 | ||
979 | -- See if we have a case where the types are both constrained, and | |
980 | -- all the constraints are constants. In this case, we can do the | |
981 | -- check successfully at compile time. | |
982 | ||
983 | -- we skip this check for the case where the node is a rewritten` | |
984 | -- allocator, because it already carries the context subtype, and | |
985 | -- extracting the discriminants from the aggregate is messy. | |
986 | ||
987 | if Is_Constrained (S_Typ) | |
988 | and then Nkind (Original_Node (N)) /= N_Allocator | |
989 | then | |
990 | declare | |
991 | DconT : Elmt_Id; | |
992 | Discr : Entity_Id; | |
993 | DconS : Elmt_Id; | |
994 | ItemS : Node_Id; | |
995 | ItemT : Node_Id; | |
996 | ||
997 | begin | |
998 | -- S_Typ may not have discriminants in the case where it is a | |
999 | -- private type completed by a default discriminated type. In | |
1000 | -- that case, we need to get the constraints from the | |
1001 | -- underlying_type. If the underlying type is unconstrained (i.e. | |
1002 | -- has no default discriminants) no check is needed. | |
1003 | ||
1004 | if Has_Discriminants (S_Typ) then | |
1005 | Discr := First_Discriminant (S_Typ); | |
1006 | DconS := First_Elmt (Discriminant_Constraint (S_Typ)); | |
1007 | ||
1008 | else | |
1009 | Discr := First_Discriminant (Underlying_Type (S_Typ)); | |
1010 | DconS := | |
1011 | First_Elmt | |
1012 | (Discriminant_Constraint (Underlying_Type (S_Typ))); | |
1013 | ||
1014 | if No (DconS) then | |
1015 | return; | |
1016 | end if; | |
1017 | end if; | |
1018 | ||
1019 | DconT := First_Elmt (Discriminant_Constraint (T_Typ)); | |
1020 | ||
1021 | while Present (Discr) loop | |
1022 | ItemS := Node (DconS); | |
1023 | ItemT := Node (DconT); | |
1024 | ||
1025 | exit when | |
1026 | not Is_OK_Static_Expression (ItemS) | |
1027 | or else | |
1028 | not Is_OK_Static_Expression (ItemT); | |
1029 | ||
1030 | if Expr_Value (ItemS) /= Expr_Value (ItemT) then | |
1031 | if Do_Access then -- needs run-time check. | |
1032 | exit; | |
1033 | else | |
1034 | Apply_Compile_Time_Constraint_Error | |
f15731c4 | 1035 | (N, "incorrect value for discriminant&?", |
1036 | CE_Discriminant_Check_Failed, Ent => Discr); | |
ee6ba406 | 1037 | return; |
1038 | end if; | |
1039 | end if; | |
1040 | ||
1041 | Next_Elmt (DconS); | |
1042 | Next_Elmt (DconT); | |
1043 | Next_Discriminant (Discr); | |
1044 | end loop; | |
1045 | ||
1046 | if No (Discr) then | |
1047 | return; | |
1048 | end if; | |
1049 | end; | |
1050 | end if; | |
1051 | ||
1052 | -- Here we need a discriminant check. First build the expression | |
1053 | -- for the comparisons of the discriminants: | |
1054 | ||
1055 | -- (n.disc1 /= typ.disc1) or else | |
1056 | -- (n.disc2 /= typ.disc2) or else | |
1057 | -- ... | |
1058 | -- (n.discn /= typ.discn) | |
1059 | ||
1060 | Cond := Build_Discriminant_Checks (N, T_Typ); | |
1061 | ||
1062 | -- If Lhs is set and is a parameter, then the condition is | |
1063 | -- guarded by: lhs'constrained and then (condition built above) | |
1064 | ||
1065 | if Present (Param_Entity (Lhs)) then | |
1066 | Cond := | |
1067 | Make_And_Then (Loc, | |
1068 | Left_Opnd => | |
1069 | Make_Attribute_Reference (Loc, | |
1070 | Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), | |
1071 | Attribute_Name => Name_Constrained), | |
1072 | Right_Opnd => Cond); | |
1073 | end if; | |
1074 | ||
1075 | if Do_Access then | |
1076 | Cond := Guard_Access (Cond, Loc, N); | |
1077 | end if; | |
1078 | ||
1079 | Insert_Action (N, | |
f15731c4 | 1080 | Make_Raise_Constraint_Error (Loc, |
1081 | Condition => Cond, | |
1082 | Reason => CE_Discriminant_Check_Failed)); | |
ee6ba406 | 1083 | |
1084 | end Apply_Discriminant_Check; | |
1085 | ||
1086 | ------------------------ | |
1087 | -- Apply_Divide_Check -- | |
1088 | ------------------------ | |
1089 | ||
1090 | procedure Apply_Divide_Check (N : Node_Id) is | |
1091 | Loc : constant Source_Ptr := Sloc (N); | |
1092 | Typ : constant Entity_Id := Etype (N); | |
1093 | Left : constant Node_Id := Left_Opnd (N); | |
1094 | Right : constant Node_Id := Right_Opnd (N); | |
1095 | ||
1096 | LLB : Uint; | |
1097 | Llo : Uint; | |
1098 | Lhi : Uint; | |
1099 | LOK : Boolean; | |
1100 | Rlo : Uint; | |
1101 | Rhi : Uint; | |
1102 | ROK : Boolean; | |
1103 | ||
1104 | begin | |
1105 | if Expander_Active | |
f15731c4 | 1106 | and not Backend_Divide_Checks_On_Target |
ee6ba406 | 1107 | then |
1108 | Determine_Range (Right, ROK, Rlo, Rhi); | |
1109 | ||
1110 | -- See if division by zero possible, and if so generate test. This | |
1111 | -- part of the test is not controlled by the -gnato switch. | |
1112 | ||
1113 | if Do_Division_Check (N) then | |
1114 | ||
1115 | if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then | |
1116 | Insert_Action (N, | |
1117 | Make_Raise_Constraint_Error (Loc, | |
1118 | Condition => | |
1119 | Make_Op_Eq (Loc, | |
1120 | Left_Opnd => Duplicate_Subexpr (Right), | |
f15731c4 | 1121 | Right_Opnd => Make_Integer_Literal (Loc, 0)), |
1122 | Reason => CE_Divide_By_Zero)); | |
ee6ba406 | 1123 | end if; |
1124 | end if; | |
1125 | ||
1126 | -- Test for extremely annoying case of xxx'First divided by -1 | |
1127 | ||
1128 | if Do_Overflow_Check (N) then | |
1129 | ||
1130 | if Nkind (N) = N_Op_Divide | |
1131 | and then Is_Signed_Integer_Type (Typ) | |
1132 | then | |
1133 | Determine_Range (Left, LOK, Llo, Lhi); | |
1134 | LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); | |
1135 | ||
1136 | if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) | |
1137 | and then | |
1138 | ((not LOK) or else (Llo = LLB)) | |
1139 | then | |
1140 | Insert_Action (N, | |
1141 | Make_Raise_Constraint_Error (Loc, | |
1142 | Condition => | |
1143 | Make_And_Then (Loc, | |
1144 | ||
1145 | Make_Op_Eq (Loc, | |
1146 | Left_Opnd => Duplicate_Subexpr (Left), | |
1147 | Right_Opnd => Make_Integer_Literal (Loc, LLB)), | |
1148 | ||
1149 | Make_Op_Eq (Loc, | |
1150 | Left_Opnd => Duplicate_Subexpr (Right), | |
1151 | Right_Opnd => | |
f15731c4 | 1152 | Make_Integer_Literal (Loc, -1))), |
1153 | Reason => CE_Overflow_Check_Failed)); | |
ee6ba406 | 1154 | end if; |
1155 | end if; | |
1156 | end if; | |
1157 | end if; | |
1158 | end Apply_Divide_Check; | |
1159 | ||
1160 | ------------------------ | |
1161 | -- Apply_Length_Check -- | |
1162 | ------------------------ | |
1163 | ||
1164 | procedure Apply_Length_Check | |
1165 | (Ck_Node : Node_Id; | |
1166 | Target_Typ : Entity_Id; | |
1167 | Source_Typ : Entity_Id := Empty) | |
1168 | is | |
1169 | begin | |
1170 | Apply_Selected_Length_Checks | |
1171 | (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); | |
1172 | end Apply_Length_Check; | |
1173 | ||
1174 | ----------------------- | |
1175 | -- Apply_Range_Check -- | |
1176 | ----------------------- | |
1177 | ||
1178 | procedure Apply_Range_Check | |
1179 | (Ck_Node : Node_Id; | |
1180 | Target_Typ : Entity_Id; | |
1181 | Source_Typ : Entity_Id := Empty) | |
1182 | is | |
1183 | begin | |
1184 | Apply_Selected_Range_Checks | |
1185 | (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); | |
1186 | end Apply_Range_Check; | |
1187 | ||
1188 | ------------------------------ | |
1189 | -- Apply_Scalar_Range_Check -- | |
1190 | ------------------------------ | |
1191 | ||
1192 | -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check | |
1193 | -- flag off if it is already set on. | |
1194 | ||
1195 | procedure Apply_Scalar_Range_Check | |
1196 | (Expr : Node_Id; | |
1197 | Target_Typ : Entity_Id; | |
1198 | Source_Typ : Entity_Id := Empty; | |
1199 | Fixed_Int : Boolean := False) | |
1200 | is | |
1201 | Parnt : constant Node_Id := Parent (Expr); | |
1202 | S_Typ : Entity_Id; | |
1203 | Arr : Node_Id := Empty; -- initialize to prevent warning | |
1204 | Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning | |
1205 | OK : Boolean; | |
1206 | ||
1207 | Is_Subscr_Ref : Boolean; | |
1208 | -- Set true if Expr is a subscript | |
1209 | ||
1210 | Is_Unconstrained_Subscr_Ref : Boolean; | |
1211 | -- Set true if Expr is a subscript of an unconstrained array. In this | |
1212 | -- case we do not attempt to do an analysis of the value against the | |
1213 | -- range of the subscript, since we don't know the actual subtype. | |
1214 | ||
1215 | Int_Real : Boolean; | |
1216 | -- Set to True if Expr should be regarded as a real value | |
1217 | -- even though the type of Expr might be discrete. | |
1218 | ||
1219 | procedure Bad_Value; | |
1220 | -- Procedure called if value is determined to be out of range | |
1221 | ||
1222 | procedure Bad_Value is | |
1223 | begin | |
1224 | Apply_Compile_Time_Constraint_Error | |
f15731c4 | 1225 | (Expr, "value not in range of}?", CE_Range_Check_Failed, |
ee6ba406 | 1226 | Ent => Target_Typ, |
1227 | Typ => Target_Typ); | |
1228 | end Bad_Value; | |
1229 | ||
1230 | begin | |
1231 | if Inside_A_Generic then | |
1232 | return; | |
1233 | ||
1234 | -- Return if check obviously not needed. Note that we do not check | |
1235 | -- for the expander being inactive, since this routine does not | |
1236 | -- insert any code, but it does generate useful warnings sometimes, | |
1237 | -- which we would like even if we are in semantics only mode. | |
1238 | ||
1239 | elsif Target_Typ = Any_Type | |
1240 | or else not Is_Scalar_Type (Target_Typ) | |
1241 | or else Raises_Constraint_Error (Expr) | |
1242 | then | |
1243 | return; | |
1244 | end if; | |
1245 | ||
1246 | -- Now, see if checks are suppressed | |
1247 | ||
1248 | Is_Subscr_Ref := | |
1249 | Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; | |
1250 | ||
1251 | if Is_Subscr_Ref then | |
1252 | Arr := Prefix (Parnt); | |
1253 | Arr_Typ := Get_Actual_Subtype_If_Available (Arr); | |
1254 | end if; | |
1255 | ||
1256 | if not Do_Range_Check (Expr) then | |
1257 | ||
1258 | -- Subscript reference. Check for Index_Checks suppressed | |
1259 | ||
1260 | if Is_Subscr_Ref then | |
1261 | ||
1262 | -- Check array type and its base type | |
1263 | ||
1264 | if Index_Checks_Suppressed (Arr_Typ) | |
1265 | or else Suppress_Index_Checks (Base_Type (Arr_Typ)) | |
1266 | then | |
1267 | return; | |
1268 | ||
1269 | -- Check array itself if it is an entity name | |
1270 | ||
1271 | elsif Is_Entity_Name (Arr) | |
1272 | and then Suppress_Index_Checks (Entity (Arr)) | |
1273 | then | |
1274 | return; | |
1275 | ||
1276 | -- Check expression itself if it is an entity name | |
1277 | ||
1278 | elsif Is_Entity_Name (Expr) | |
1279 | and then Suppress_Index_Checks (Entity (Expr)) | |
1280 | then | |
1281 | return; | |
1282 | end if; | |
1283 | ||
1284 | -- All other cases, check for Range_Checks suppressed | |
1285 | ||
1286 | else | |
1287 | -- Check target type and its base type | |
1288 | ||
1289 | if Range_Checks_Suppressed (Target_Typ) | |
1290 | or else Suppress_Range_Checks (Base_Type (Target_Typ)) | |
1291 | then | |
1292 | return; | |
1293 | ||
1294 | -- Check expression itself if it is an entity name | |
1295 | ||
1296 | elsif Is_Entity_Name (Expr) | |
1297 | and then Suppress_Range_Checks (Entity (Expr)) | |
1298 | then | |
1299 | return; | |
1300 | ||
1301 | -- If Expr is part of an assignment statement, then check | |
1302 | -- left side of assignment if it is an entity name. | |
1303 | ||
1304 | elsif Nkind (Parnt) = N_Assignment_Statement | |
1305 | and then Is_Entity_Name (Name (Parnt)) | |
1306 | and then Suppress_Range_Checks (Entity (Name (Parnt))) | |
1307 | then | |
1308 | return; | |
1309 | end if; | |
1310 | end if; | |
1311 | end if; | |
1312 | ||
1313 | -- Now see if we need a check | |
1314 | ||
1315 | if No (Source_Typ) then | |
1316 | S_Typ := Etype (Expr); | |
1317 | else | |
1318 | S_Typ := Source_Typ; | |
1319 | end if; | |
1320 | ||
1321 | if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then | |
1322 | return; | |
1323 | end if; | |
1324 | ||
1325 | Is_Unconstrained_Subscr_Ref := | |
1326 | Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); | |
1327 | ||
1328 | -- Always do a range check if the source type includes infinities | |
1329 | -- and the target type does not include infinities. | |
1330 | ||
1331 | if Is_Floating_Point_Type (S_Typ) | |
1332 | and then Has_Infinities (S_Typ) | |
1333 | and then not Has_Infinities (Target_Typ) | |
1334 | then | |
1335 | Enable_Range_Check (Expr); | |
1336 | end if; | |
1337 | ||
1338 | -- Return if we know expression is definitely in the range of | |
1339 | -- the target type as determined by Determine_Range. Right now | |
1340 | -- we only do this for discrete types, and not fixed-point or | |
1341 | -- floating-point types. | |
1342 | ||
1343 | -- The additional less-precise tests below catch these cases. | |
1344 | ||
1345 | -- Note: skip this if we are given a source_typ, since the point | |
1346 | -- of supplying a Source_Typ is to stop us looking at the expression. | |
1347 | -- could sharpen this test to be out parameters only ??? | |
1348 | ||
1349 | if Is_Discrete_Type (Target_Typ) | |
1350 | and then Is_Discrete_Type (Etype (Expr)) | |
1351 | and then not Is_Unconstrained_Subscr_Ref | |
1352 | and then No (Source_Typ) | |
1353 | then | |
1354 | declare | |
1355 | Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); | |
1356 | Thi : constant Node_Id := Type_High_Bound (Target_Typ); | |
1357 | Lo : Uint; | |
1358 | Hi : Uint; | |
1359 | ||
1360 | begin | |
1361 | if Compile_Time_Known_Value (Tlo) | |
1362 | and then Compile_Time_Known_Value (Thi) | |
1363 | then | |
1364 | Determine_Range (Expr, OK, Lo, Hi); | |
1365 | ||
1366 | if OK then | |
1367 | declare | |
1368 | Lov : constant Uint := Expr_Value (Tlo); | |
1369 | Hiv : constant Uint := Expr_Value (Thi); | |
1370 | ||
1371 | begin | |
1372 | if Lo >= Lov and then Hi <= Hiv then | |
1373 | return; | |
1374 | ||
1375 | elsif Lov > Hi or else Hiv < Lo then | |
1376 | Bad_Value; | |
1377 | return; | |
1378 | end if; | |
1379 | end; | |
1380 | end if; | |
1381 | end if; | |
1382 | end; | |
1383 | end if; | |
1384 | ||
1385 | Int_Real := | |
1386 | Is_Floating_Point_Type (S_Typ) | |
1387 | or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); | |
1388 | ||
1389 | -- Check if we can determine at compile time whether Expr is in the | |
1390 | -- range of the target type. Note that if S_Typ is within the | |
1391 | -- bounds of Target_Typ then this must be the case. This checks is | |
1392 | -- only meaningful if this is not a conversion between integer and | |
1393 | -- real types. | |
1394 | ||
1395 | if not Is_Unconstrained_Subscr_Ref | |
1396 | and then | |
1397 | Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) | |
1398 | and then | |
1399 | (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) | |
1400 | or else | |
1401 | Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) | |
1402 | then | |
1403 | return; | |
1404 | ||
1405 | elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then | |
1406 | Bad_Value; | |
1407 | return; | |
1408 | ||
1409 | -- Do not set range checks if they are killed | |
1410 | ||
1411 | elsif Nkind (Expr) = N_Unchecked_Type_Conversion | |
1412 | and then Kill_Range_Check (Expr) | |
1413 | then | |
1414 | return; | |
1415 | ||
1416 | -- ??? We only need a runtime check if the target type is constrained | |
1417 | -- (the predefined type Float is not for instance). | |
1418 | -- so the following should really be | |
1419 | -- | |
1420 | -- elsif Is_Constrained (Target_Typ) then | |
1421 | -- | |
1422 | -- but it isn't because certain types do not have the Is_Constrained | |
1423 | -- flag properly set (see 1503-003). | |
1424 | ||
1425 | else | |
1426 | Enable_Range_Check (Expr); | |
1427 | return; | |
1428 | end if; | |
1429 | ||
1430 | end Apply_Scalar_Range_Check; | |
1431 | ||
1432 | ---------------------------------- | |
1433 | -- Apply_Selected_Length_Checks -- | |
1434 | ---------------------------------- | |
1435 | ||
1436 | procedure Apply_Selected_Length_Checks | |
1437 | (Ck_Node : Node_Id; | |
1438 | Target_Typ : Entity_Id; | |
1439 | Source_Typ : Entity_Id; | |
1440 | Do_Static : Boolean) | |
1441 | is | |
1442 | Cond : Node_Id; | |
1443 | R_Result : Check_Result; | |
1444 | R_Cno : Node_Id; | |
1445 | ||
1446 | Loc : constant Source_Ptr := Sloc (Ck_Node); | |
1447 | Checks_On : constant Boolean := | |
1448 | (not Index_Checks_Suppressed (Target_Typ)) | |
1449 | or else | |
1450 | (not Length_Checks_Suppressed (Target_Typ)); | |
1451 | ||
1452 | begin | |
f15731c4 | 1453 | if not Expander_Active then |
ee6ba406 | 1454 | return; |
1455 | end if; | |
1456 | ||
1457 | R_Result := | |
1458 | Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); | |
1459 | ||
1460 | for J in 1 .. 2 loop | |
1461 | ||
1462 | R_Cno := R_Result (J); | |
1463 | exit when No (R_Cno); | |
1464 | ||
1465 | -- A length check may mention an Itype which is attached to a | |
1466 | -- subsequent node. At the top level in a package this can cause | |
1467 | -- an order-of-elaboration problem, so we make sure that the itype | |
1468 | -- is referenced now. | |
1469 | ||
1470 | if Ekind (Current_Scope) = E_Package | |
1471 | and then Is_Compilation_Unit (Current_Scope) | |
1472 | then | |
1473 | Ensure_Defined (Target_Typ, Ck_Node); | |
1474 | ||
1475 | if Present (Source_Typ) then | |
1476 | Ensure_Defined (Source_Typ, Ck_Node); | |
1477 | ||
1478 | elsif Is_Itype (Etype (Ck_Node)) then | |
1479 | Ensure_Defined (Etype (Ck_Node), Ck_Node); | |
1480 | end if; | |
1481 | end if; | |
1482 | ||
1483 | -- If the item is a conditional raise of constraint error, | |
1484 | -- then have a look at what check is being performed and | |
1485 | -- ??? | |
1486 | ||
1487 | if Nkind (R_Cno) = N_Raise_Constraint_Error | |
1488 | and then Present (Condition (R_Cno)) | |
1489 | then | |
1490 | Cond := Condition (R_Cno); | |
1491 | ||
f15731c4 | 1492 | if not Has_Dynamic_Length_Check (Ck_Node) |
1493 | and then Checks_On | |
1494 | then | |
ee6ba406 | 1495 | Insert_Action (Ck_Node, R_Cno); |
1496 | ||
1497 | if not Do_Static then | |
1498 | Set_Has_Dynamic_Length_Check (Ck_Node); | |
1499 | end if; | |
ee6ba406 | 1500 | end if; |
1501 | ||
1502 | -- Output a warning if the condition is known to be True | |
1503 | ||
1504 | if Is_Entity_Name (Cond) | |
1505 | and then Entity (Cond) = Standard_True | |
1506 | then | |
1507 | Apply_Compile_Time_Constraint_Error | |
1508 | (Ck_Node, "wrong length for array of}?", | |
f15731c4 | 1509 | CE_Length_Check_Failed, |
ee6ba406 | 1510 | Ent => Target_Typ, |
1511 | Typ => Target_Typ); | |
1512 | ||
1513 | -- If we were only doing a static check, or if checks are not | |
1514 | -- on, then we want to delete the check, since it is not needed. | |
1515 | -- We do this by replacing the if statement by a null statement | |
1516 | ||
1517 | elsif Do_Static or else not Checks_On then | |
1518 | Rewrite (R_Cno, Make_Null_Statement (Loc)); | |
1519 | end if; | |
1520 | ||
1521 | else | |
1522 | Install_Static_Check (R_Cno, Loc); | |
1523 | end if; | |
1524 | ||
1525 | end loop; | |
1526 | ||
1527 | end Apply_Selected_Length_Checks; | |
1528 | ||
1529 | --------------------------------- | |
1530 | -- Apply_Selected_Range_Checks -- | |
1531 | --------------------------------- | |
1532 | ||
1533 | procedure Apply_Selected_Range_Checks | |
1534 | (Ck_Node : Node_Id; | |
1535 | Target_Typ : Entity_Id; | |
1536 | Source_Typ : Entity_Id; | |
1537 | Do_Static : Boolean) | |
1538 | is | |
1539 | Cond : Node_Id; | |
1540 | R_Result : Check_Result; | |
1541 | R_Cno : Node_Id; | |
1542 | ||
1543 | Loc : constant Source_Ptr := Sloc (Ck_Node); | |
1544 | Checks_On : constant Boolean := | |
1545 | (not Index_Checks_Suppressed (Target_Typ)) | |
1546 | or else | |
1547 | (not Range_Checks_Suppressed (Target_Typ)); | |
1548 | ||
1549 | begin | |
1550 | if not Expander_Active or else not Checks_On then | |
1551 | return; | |
1552 | end if; | |
1553 | ||
1554 | R_Result := | |
1555 | Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); | |
1556 | ||
1557 | for J in 1 .. 2 loop | |
1558 | ||
1559 | R_Cno := R_Result (J); | |
1560 | exit when No (R_Cno); | |
1561 | ||
1562 | -- If the item is a conditional raise of constraint error, | |
1563 | -- then have a look at what check is being performed and | |
1564 | -- ??? | |
1565 | ||
1566 | if Nkind (R_Cno) = N_Raise_Constraint_Error | |
1567 | and then Present (Condition (R_Cno)) | |
1568 | then | |
1569 | Cond := Condition (R_Cno); | |
1570 | ||
1571 | if not Has_Dynamic_Range_Check (Ck_Node) then | |
1572 | Insert_Action (Ck_Node, R_Cno); | |
1573 | ||
1574 | if not Do_Static then | |
1575 | Set_Has_Dynamic_Range_Check (Ck_Node); | |
1576 | end if; | |
1577 | end if; | |
1578 | ||
1579 | -- Output a warning if the condition is known to be True | |
1580 | ||
1581 | if Is_Entity_Name (Cond) | |
1582 | and then Entity (Cond) = Standard_True | |
1583 | then | |
1584 | -- Since an N_Range is technically not an expression, we | |
1585 | -- have to set one of the bounds to C_E and then just flag | |
1586 | -- the N_Range. The warning message will point to the | |
1587 | -- lower bound and complain about a range, which seems OK. | |
1588 | ||
1589 | if Nkind (Ck_Node) = N_Range then | |
1590 | Apply_Compile_Time_Constraint_Error | |
1591 | (Low_Bound (Ck_Node), "static range out of bounds of}?", | |
f15731c4 | 1592 | CE_Range_Check_Failed, |
ee6ba406 | 1593 | Ent => Target_Typ, |
1594 | Typ => Target_Typ); | |
1595 | ||
1596 | Set_Raises_Constraint_Error (Ck_Node); | |
1597 | ||
1598 | else | |
1599 | Apply_Compile_Time_Constraint_Error | |
1600 | (Ck_Node, "static value out of range of}?", | |
f15731c4 | 1601 | CE_Range_Check_Failed, |
ee6ba406 | 1602 | Ent => Target_Typ, |
1603 | Typ => Target_Typ); | |
1604 | end if; | |
1605 | ||
1606 | -- If we were only doing a static check, or if checks are not | |
1607 | -- on, then we want to delete the check, since it is not needed. | |
1608 | -- We do this by replacing the if statement by a null statement | |
1609 | ||
1610 | elsif Do_Static or else not Checks_On then | |
1611 | Rewrite (R_Cno, Make_Null_Statement (Loc)); | |
1612 | end if; | |
1613 | ||
1614 | else | |
1615 | Install_Static_Check (R_Cno, Loc); | |
1616 | end if; | |
1617 | ||
1618 | end loop; | |
1619 | ||
1620 | end Apply_Selected_Range_Checks; | |
1621 | ||
1622 | ------------------------------- | |
1623 | -- Apply_Static_Length_Check -- | |
1624 | ------------------------------- | |
1625 | ||
1626 | procedure Apply_Static_Length_Check | |
1627 | (Expr : Node_Id; | |
1628 | Target_Typ : Entity_Id; | |
1629 | Source_Typ : Entity_Id := Empty) | |
1630 | is | |
1631 | begin | |
1632 | Apply_Selected_Length_Checks | |
1633 | (Expr, Target_Typ, Source_Typ, Do_Static => True); | |
1634 | end Apply_Static_Length_Check; | |
1635 | ||
1636 | ------------------------------------- | |
1637 | -- Apply_Subscript_Validity_Checks -- | |
1638 | ------------------------------------- | |
1639 | ||
1640 | procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is | |
1641 | Sub : Node_Id; | |
1642 | ||
1643 | begin | |
1644 | pragma Assert (Nkind (Expr) = N_Indexed_Component); | |
1645 | ||
1646 | -- Loop through subscripts | |
1647 | ||
1648 | Sub := First (Expressions (Expr)); | |
1649 | while Present (Sub) loop | |
1650 | ||
1651 | -- Check one subscript. Note that we do not worry about | |
1652 | -- enumeration type with holes, since we will convert the | |
1653 | -- value to a Pos value for the subscript, and that convert | |
1654 | -- will do the necessary validity check. | |
1655 | ||
1656 | Ensure_Valid (Sub, Holes_OK => True); | |
1657 | ||
1658 | -- Move to next subscript | |
1659 | ||
1660 | Sub := Next (Sub); | |
1661 | end loop; | |
1662 | end Apply_Subscript_Validity_Checks; | |
1663 | ||
1664 | ---------------------------------- | |
1665 | -- Apply_Type_Conversion_Checks -- | |
1666 | ---------------------------------- | |
1667 | ||
1668 | procedure Apply_Type_Conversion_Checks (N : Node_Id) is | |
1669 | Target_Type : constant Entity_Id := Etype (N); | |
1670 | Target_Base : constant Entity_Id := Base_Type (Target_Type); | |
1671 | ||
1672 | Expr : constant Node_Id := Expression (N); | |
1673 | Expr_Type : constant Entity_Id := Etype (Expr); | |
1674 | ||
1675 | begin | |
1676 | if Inside_A_Generic then | |
1677 | return; | |
1678 | ||
f15731c4 | 1679 | -- Skip these checks if serious errors detected, there are some nasty |
ee6ba406 | 1680 | -- situations of incomplete trees that blow things up. |
1681 | ||
f15731c4 | 1682 | elsif Serious_Errors_Detected > 0 then |
ee6ba406 | 1683 | return; |
1684 | ||
1685 | -- Scalar type conversions of the form Target_Type (Expr) require | |
1686 | -- two checks: | |
1687 | -- | |
1688 | -- - First there is an overflow check to insure that Expr is | |
1689 | -- in the base type of Target_Typ (4.6 (28)), | |
1690 | -- | |
1691 | -- - After we know Expr fits into the base type, we must perform a | |
1692 | -- range check to ensure that Expr meets the constraints of the | |
1693 | -- Target_Type. | |
1694 | ||
1695 | elsif Is_Scalar_Type (Target_Type) then | |
1696 | declare | |
1697 | Conv_OK : constant Boolean := Conversion_OK (N); | |
1698 | -- If the Conversion_OK flag on the type conversion is set | |
1699 | -- and no floating point type is involved in the type conversion | |
1700 | -- then fixed point values must be read as integral values. | |
1701 | ||
1702 | begin | |
1703 | -- Overflow check. | |
1704 | ||
1705 | if not Overflow_Checks_Suppressed (Target_Base) | |
1706 | and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) | |
1707 | then | |
1708 | Set_Do_Overflow_Check (N); | |
1709 | end if; | |
1710 | ||
1711 | if not Range_Checks_Suppressed (Target_Type) | |
1712 | and then not Range_Checks_Suppressed (Expr_Type) | |
1713 | then | |
1714 | Apply_Scalar_Range_Check | |
1715 | (Expr, Target_Type, Fixed_Int => Conv_OK); | |
1716 | end if; | |
1717 | end; | |
1718 | ||
1719 | elsif Comes_From_Source (N) | |
1720 | and then Is_Record_Type (Target_Type) | |
1721 | and then Is_Derived_Type (Target_Type) | |
1722 | and then not Is_Tagged_Type (Target_Type) | |
1723 | and then not Is_Constrained (Target_Type) | |
1724 | and then Present (Girder_Constraint (Target_Type)) | |
1725 | then | |
1726 | -- A unconstrained derived type may have inherited discriminants. | |
1727 | -- Build an actual discriminant constraint list using the girder | |
1728 | -- constraint, to verify that the expression of the parent type | |
1729 | -- satisfies the constraints imposed by the (unconstrained!) | |
1730 | -- derived type. This applies to value conversions, not to view | |
1731 | -- conversions of tagged types. | |
1732 | ||
1733 | declare | |
1734 | Loc : constant Source_Ptr := Sloc (N); | |
1735 | Cond : Node_Id; | |
1736 | Constraint : Elmt_Id; | |
1737 | Discr_Value : Node_Id; | |
1738 | Discr : Entity_Id; | |
1739 | New_Constraints : Elist_Id := New_Elmt_List; | |
1740 | Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type); | |
1741 | ||
1742 | begin | |
1743 | Constraint := First_Elmt (Girder_Constraint (Target_Type)); | |
1744 | ||
1745 | while Present (Constraint) loop | |
1746 | Discr_Value := Node (Constraint); | |
1747 | ||
1748 | if Is_Entity_Name (Discr_Value) | |
1749 | and then Ekind (Entity (Discr_Value)) = E_Discriminant | |
1750 | then | |
1751 | Discr := Corresponding_Discriminant (Entity (Discr_Value)); | |
1752 | ||
1753 | if Present (Discr) | |
1754 | and then Scope (Discr) = Base_Type (Expr_Type) | |
1755 | then | |
1756 | -- Parent is constrained by new discriminant. Obtain | |
1757 | -- Value of original discriminant in expression. If | |
1758 | -- the new discriminant has been used to constrain more | |
1759 | -- than one of the girder ones, this will provide the | |
1760 | -- required consistency check. | |
1761 | ||
1762 | Append_Elmt ( | |
1763 | Make_Selected_Component (Loc, | |
1764 | Prefix => | |
1765 | Duplicate_Subexpr (Expr, Name_Req => True), | |
1766 | Selector_Name => | |
1767 | Make_Identifier (Loc, Chars (Discr))), | |
1768 | New_Constraints); | |
1769 | ||
1770 | else | |
1771 | -- Discriminant of more remote ancestor ??? | |
1772 | ||
1773 | return; | |
1774 | end if; | |
1775 | ||
1776 | -- Derived type definition has an explicit value for | |
1777 | -- this girder discriminant. | |
1778 | ||
1779 | else | |
1780 | Append_Elmt | |
1781 | (Duplicate_Subexpr (Discr_Value), New_Constraints); | |
1782 | end if; | |
1783 | ||
1784 | Next_Elmt (Constraint); | |
1785 | end loop; | |
1786 | ||
1787 | -- Use the unconstrained expression type to retrieve the | |
1788 | -- discriminants of the parent, and apply momentarily the | |
1789 | -- discriminant constraint synthesized above. | |
1790 | ||
1791 | Set_Discriminant_Constraint (Expr_Type, New_Constraints); | |
1792 | Cond := Build_Discriminant_Checks (Expr, Expr_Type); | |
1793 | Set_Discriminant_Constraint (Expr_Type, Old_Constraints); | |
1794 | ||
1795 | Insert_Action (N, | |
f15731c4 | 1796 | Make_Raise_Constraint_Error (Loc, |
1797 | Condition => Cond, | |
1798 | Reason => CE_Discriminant_Check_Failed)); | |
ee6ba406 | 1799 | end; |
1800 | ||
1801 | -- should there be other checks here for array types ??? | |
1802 | ||
1803 | else | |
1804 | null; | |
1805 | end if; | |
1806 | ||
1807 | end Apply_Type_Conversion_Checks; | |
1808 | ||
1809 | ---------------------------------------------- | |
1810 | -- Apply_Universal_Integer_Attribute_Checks -- | |
1811 | ---------------------------------------------- | |
1812 | ||
1813 | procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is | |
1814 | Loc : constant Source_Ptr := Sloc (N); | |
1815 | Typ : constant Entity_Id := Etype (N); | |
1816 | ||
1817 | begin | |
1818 | if Inside_A_Generic then | |
1819 | return; | |
1820 | ||
1821 | -- Nothing to do if checks are suppressed | |
1822 | ||
1823 | elsif Range_Checks_Suppressed (Typ) | |
1824 | and then Overflow_Checks_Suppressed (Typ) | |
1825 | then | |
1826 | return; | |
1827 | ||
1828 | -- Nothing to do if the attribute does not come from source. The | |
1829 | -- internal attributes we generate of this type do not need checks, | |
1830 | -- and furthermore the attempt to check them causes some circular | |
1831 | -- elaboration orders when dealing with packed types. | |
1832 | ||
1833 | elsif not Comes_From_Source (N) then | |
1834 | return; | |
1835 | ||
1836 | -- Otherwise, replace the attribute node with a type conversion | |
1837 | -- node whose expression is the attribute, retyped to universal | |
1838 | -- integer, and whose subtype mark is the target type. The call | |
1839 | -- to analyze this conversion will set range and overflow checks | |
1840 | -- as required for proper detection of an out of range value. | |
1841 | ||
1842 | else | |
1843 | Set_Etype (N, Universal_Integer); | |
1844 | Set_Analyzed (N, True); | |
1845 | ||
1846 | Rewrite (N, | |
1847 | Make_Type_Conversion (Loc, | |
1848 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), | |
1849 | Expression => Relocate_Node (N))); | |
1850 | ||
1851 | Analyze_And_Resolve (N, Typ); | |
1852 | return; | |
1853 | end if; | |
1854 | ||
1855 | end Apply_Universal_Integer_Attribute_Checks; | |
1856 | ||
1857 | ------------------------------- | |
1858 | -- Build_Discriminant_Checks -- | |
1859 | ------------------------------- | |
1860 | ||
1861 | function Build_Discriminant_Checks | |
1862 | (N : Node_Id; | |
1863 | T_Typ : Entity_Id) | |
1864 | return Node_Id | |
1865 | is | |
1866 | Loc : constant Source_Ptr := Sloc (N); | |
1867 | Cond : Node_Id; | |
1868 | Disc : Elmt_Id; | |
1869 | Disc_Ent : Entity_Id; | |
1870 | Dval : Node_Id; | |
1871 | ||
1872 | begin | |
1873 | Cond := Empty; | |
1874 | Disc := First_Elmt (Discriminant_Constraint (T_Typ)); | |
1875 | ||
1876 | -- For a fully private type, use the discriminants of the parent | |
1877 | -- type. | |
1878 | ||
1879 | if Is_Private_Type (T_Typ) | |
1880 | and then No (Full_View (T_Typ)) | |
1881 | then | |
1882 | Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); | |
1883 | else | |
1884 | Disc_Ent := First_Discriminant (T_Typ); | |
1885 | end if; | |
1886 | ||
1887 | while Present (Disc) loop | |
1888 | ||
1889 | Dval := Node (Disc); | |
1890 | ||
1891 | if Nkind (Dval) = N_Identifier | |
1892 | and then Ekind (Entity (Dval)) = E_Discriminant | |
1893 | then | |
1894 | Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); | |
1895 | else | |
1896 | Dval := Duplicate_Subexpr (Dval); | |
1897 | end if; | |
1898 | ||
1899 | Evolve_Or_Else (Cond, | |
1900 | Make_Op_Ne (Loc, | |
1901 | Left_Opnd => | |
1902 | Make_Selected_Component (Loc, | |
1903 | Prefix => | |
1904 | Duplicate_Subexpr (N, Name_Req => True), | |
1905 | Selector_Name => | |
1906 | Make_Identifier (Loc, Chars (Disc_Ent))), | |
1907 | Right_Opnd => Dval)); | |
1908 | ||
1909 | Next_Elmt (Disc); | |
1910 | Next_Discriminant (Disc_Ent); | |
1911 | end loop; | |
1912 | ||
1913 | return Cond; | |
1914 | end Build_Discriminant_Checks; | |
1915 | ||
1916 | ----------------------------------- | |
1917 | -- Check_Valid_Lvalue_Subscripts -- | |
1918 | ----------------------------------- | |
1919 | ||
1920 | procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is | |
1921 | begin | |
1922 | -- Skip this if range checks are suppressed | |
1923 | ||
1924 | if Range_Checks_Suppressed (Etype (Expr)) then | |
1925 | return; | |
1926 | ||
1927 | -- Only do this check for expressions that come from source. We | |
1928 | -- assume that expander generated assignments explicitly include | |
1929 | -- any necessary checks. Note that this is not just an optimization, | |
1930 | -- it avoids infinite recursions! | |
1931 | ||
1932 | elsif not Comes_From_Source (Expr) then | |
1933 | return; | |
1934 | ||
1935 | -- For a selected component, check the prefix | |
1936 | ||
1937 | elsif Nkind (Expr) = N_Selected_Component then | |
1938 | Check_Valid_Lvalue_Subscripts (Prefix (Expr)); | |
1939 | return; | |
1940 | ||
1941 | -- Case of indexed component | |
1942 | ||
1943 | elsif Nkind (Expr) = N_Indexed_Component then | |
1944 | Apply_Subscript_Validity_Checks (Expr); | |
1945 | ||
1946 | -- Prefix may itself be or contain an indexed component, and | |
1947 | -- these subscripts need checking as well | |
1948 | ||
1949 | Check_Valid_Lvalue_Subscripts (Prefix (Expr)); | |
1950 | end if; | |
1951 | end Check_Valid_Lvalue_Subscripts; | |
1952 | ||
1953 | --------------------- | |
1954 | -- Determine_Range -- | |
1955 | --------------------- | |
1956 | ||
6af1bdbc | 1957 | Cache_Size : constant := 2 ** 10; |
ee6ba406 | 1958 | type Cache_Index is range 0 .. Cache_Size - 1; |
1959 | -- Determine size of below cache (power of 2 is more efficient!) | |
1960 | ||
1961 | Determine_Range_Cache_N : array (Cache_Index) of Node_Id; | |
1962 | Determine_Range_Cache_Lo : array (Cache_Index) of Uint; | |
1963 | Determine_Range_Cache_Hi : array (Cache_Index) of Uint; | |
1964 | -- The above arrays are used to implement a small direct cache | |
1965 | -- for Determine_Range calls. Because of the way Determine_Range | |
1966 | -- recursively traces subexpressions, and because overflow checking | |
1967 | -- calls the routine on the way up the tree, a quadratic behavior | |
1968 | -- can otherwise be encountered in large expressions. The cache | |
1969 | -- entry for node N is stored in the (N mod Cache_Size) entry, and | |
1970 | -- can be validated by checking the actual node value stored there. | |
1971 | ||
1972 | procedure Determine_Range | |
1973 | (N : Node_Id; | |
1974 | OK : out Boolean; | |
1975 | Lo : out Uint; | |
1976 | Hi : out Uint) | |
1977 | is | |
8880be85 | 1978 | Typ : constant Entity_Id := Etype (N); |
1979 | ||
1980 | Lo_Left : Uint; | |
1981 | Hi_Left : Uint; | |
1982 | -- Lo and Hi bounds of left operand | |
ee6ba406 | 1983 | |
ee6ba406 | 1984 | Lo_Right : Uint; |
ee6ba406 | 1985 | Hi_Right : Uint; |
8880be85 | 1986 | -- Lo and Hi bounds of right (or only) operand |
1987 | ||
1988 | Bound : Node_Id; | |
1989 | -- Temp variable used to hold a bound node | |
1990 | ||
1991 | Hbound : Uint; | |
1992 | -- High bound of base type of expression | |
1993 | ||
1994 | Lor : Uint; | |
1995 | Hir : Uint; | |
1996 | -- Refined values for low and high bounds, after tightening | |
1997 | ||
1998 | OK1 : Boolean; | |
1999 | -- Used in lower level calls to indicate if call succeeded | |
2000 | ||
2001 | Cindex : Cache_Index; | |
2002 | -- Used to search cache | |
ee6ba406 | 2003 | |
2004 | function OK_Operands return Boolean; | |
2005 | -- Used for binary operators. Determines the ranges of the left and | |
2006 | -- right operands, and if they are both OK, returns True, and puts | |
2007 | -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left | |
2008 | ||
2009 | ----------------- | |
2010 | -- OK_Operands -- | |
2011 | ----------------- | |
2012 | ||
2013 | function OK_Operands return Boolean is | |
2014 | begin | |
2015 | Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left); | |
2016 | ||
2017 | if not OK1 then | |
2018 | return False; | |
2019 | end if; | |
2020 | ||
2021 | Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); | |
2022 | return OK1; | |
2023 | end OK_Operands; | |
2024 | ||
2025 | -- Start of processing for Determine_Range | |
2026 | ||
2027 | begin | |
2028 | -- Prevent junk warnings by initializing range variables | |
2029 | ||
2030 | Lo := No_Uint; | |
2031 | Hi := No_Uint; | |
2032 | Lor := No_Uint; | |
2033 | Hir := No_Uint; | |
2034 | ||
2035 | -- If the type is not discrete, or is undefined, then we can't | |
2036 | -- do anything about determining the range. | |
2037 | ||
2038 | if No (Typ) or else not Is_Discrete_Type (Typ) | |
2039 | or else Error_Posted (N) | |
2040 | then | |
2041 | OK := False; | |
2042 | return; | |
2043 | end if; | |
2044 | ||
2045 | -- For all other cases, we can determine the range | |
2046 | ||
2047 | OK := True; | |
2048 | ||
2049 | -- If value is compile time known, then the possible range is the | |
2050 | -- one value that we know this expression definitely has! | |
2051 | ||
2052 | if Compile_Time_Known_Value (N) then | |
2053 | Lo := Expr_Value (N); | |
2054 | Hi := Lo; | |
2055 | return; | |
2056 | end if; | |
2057 | ||
2058 | -- Return if already in the cache | |
2059 | ||
2060 | Cindex := Cache_Index (N mod Cache_Size); | |
2061 | ||
2062 | if Determine_Range_Cache_N (Cindex) = N then | |
2063 | Lo := Determine_Range_Cache_Lo (Cindex); | |
2064 | Hi := Determine_Range_Cache_Hi (Cindex); | |
2065 | return; | |
2066 | end if; | |
2067 | ||
2068 | -- Otherwise, start by finding the bounds of the type of the | |
2069 | -- expression, the value cannot be outside this range (if it | |
2070 | -- is, then we have an overflow situation, which is a separate | |
2071 | -- check, we are talking here only about the expression value). | |
2072 | ||
2073 | -- We use the actual bound unless it is dynamic, in which case | |
2074 | -- use the corresponding base type bound if possible. If we can't | |
8880be85 | 2075 | -- get a bound then we figure we can't determine the range (a |
2076 | -- peculiar case, that perhaps cannot happen, but there is no | |
2077 | -- point in bombing in this optimization circuit. | |
2078 | ||
2079 | -- First the low bound | |
ee6ba406 | 2080 | |
2081 | Bound := Type_Low_Bound (Typ); | |
2082 | ||
2083 | if Compile_Time_Known_Value (Bound) then | |
2084 | Lo := Expr_Value (Bound); | |
2085 | ||
2086 | elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then | |
2087 | Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ))); | |
2088 | ||
2089 | else | |
2090 | OK := False; | |
2091 | return; | |
2092 | end if; | |
2093 | ||
8880be85 | 2094 | -- Now the high bound |
2095 | ||
ee6ba406 | 2096 | Bound := Type_High_Bound (Typ); |
2097 | ||
8880be85 | 2098 | -- We need the high bound of the base type later on, and this should |
2099 | -- always be compile time known. Again, it is not clear that this | |
2100 | -- can ever be false, but no point in bombing. | |
ee6ba406 | 2101 | |
8880be85 | 2102 | if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then |
ee6ba406 | 2103 | Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ))); |
2104 | Hi := Hbound; | |
2105 | ||
2106 | else | |
2107 | OK := False; | |
2108 | return; | |
2109 | end if; | |
2110 | ||
8880be85 | 2111 | -- If we have a static subtype, then that may have a tighter bound |
2112 | -- so use the upper bound of the subtype instead in this case. | |
2113 | ||
2114 | if Compile_Time_Known_Value (Bound) then | |
2115 | Hi := Expr_Value (Bound); | |
2116 | end if; | |
2117 | ||
ee6ba406 | 2118 | -- We may be able to refine this value in certain situations. If |
2119 | -- refinement is possible, then Lor and Hir are set to possibly | |
2120 | -- tighter bounds, and OK1 is set to True. | |
2121 | ||
2122 | case Nkind (N) is | |
2123 | ||
2124 | -- For unary plus, result is limited by range of operand | |
2125 | ||
2126 | when N_Op_Plus => | |
2127 | Determine_Range (Right_Opnd (N), OK1, Lor, Hir); | |
2128 | ||
2129 | -- For unary minus, determine range of operand, and negate it | |
2130 | ||
2131 | when N_Op_Minus => | |
2132 | Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); | |
2133 | ||
2134 | if OK1 then | |
2135 | Lor := -Hi_Right; | |
2136 | Hir := -Lo_Right; | |
2137 | end if; | |
2138 | ||
2139 | -- For binary addition, get range of each operand and do the | |
2140 | -- addition to get the result range. | |
2141 | ||
2142 | when N_Op_Add => | |
2143 | if OK_Operands then | |
2144 | Lor := Lo_Left + Lo_Right; | |
2145 | Hir := Hi_Left + Hi_Right; | |
2146 | end if; | |
2147 | ||
2148 | -- Division is tricky. The only case we consider is where the | |
2149 | -- right operand is a positive constant, and in this case we | |
2150 | -- simply divide the bounds of the left operand | |
2151 | ||
2152 | when N_Op_Divide => | |
2153 | if OK_Operands then | |
2154 | if Lo_Right = Hi_Right | |
2155 | and then Lo_Right > 0 | |
2156 | then | |
2157 | Lor := Lo_Left / Lo_Right; | |
2158 | Hir := Hi_Left / Lo_Right; | |
2159 | ||
2160 | else | |
2161 | OK1 := False; | |
2162 | end if; | |
2163 | end if; | |
2164 | ||
2165 | -- For binary subtraction, get range of each operand and do | |
2166 | -- the worst case subtraction to get the result range. | |
2167 | ||
2168 | when N_Op_Subtract => | |
2169 | if OK_Operands then | |
2170 | Lor := Lo_Left - Hi_Right; | |
2171 | Hir := Hi_Left - Lo_Right; | |
2172 | end if; | |
2173 | ||
2174 | -- For MOD, if right operand is a positive constant, then | |
2175 | -- result must be in the allowable range of mod results. | |
2176 | ||
2177 | when N_Op_Mod => | |
2178 | if OK_Operands then | |
2179 | if Lo_Right = Hi_Right then | |
2180 | if Lo_Right > 0 then | |
2181 | Lor := Uint_0; | |
2182 | Hir := Lo_Right - 1; | |
2183 | ||
2184 | elsif Lo_Right < 0 then | |
2185 | Lor := Lo_Right + 1; | |
2186 | Hir := Uint_0; | |
2187 | end if; | |
2188 | ||
2189 | else | |
2190 | OK1 := False; | |
2191 | end if; | |
2192 | end if; | |
2193 | ||
2194 | -- For REM, if right operand is a positive constant, then | |
2195 | -- result must be in the allowable range of mod results. | |
2196 | ||
2197 | when N_Op_Rem => | |
2198 | if OK_Operands then | |
2199 | if Lo_Right = Hi_Right then | |
2200 | declare | |
2201 | Dval : constant Uint := (abs Lo_Right) - 1; | |
2202 | ||
2203 | begin | |
2204 | -- The sign of the result depends on the sign of the | |
2205 | -- dividend (but not on the sign of the divisor, hence | |
2206 | -- the abs operation above). | |
2207 | ||
2208 | if Lo_Left < 0 then | |
2209 | Lor := -Dval; | |
2210 | else | |
2211 | Lor := Uint_0; | |
2212 | end if; | |
2213 | ||
2214 | if Hi_Left < 0 then | |
2215 | Hir := Uint_0; | |
2216 | else | |
2217 | Hir := Dval; | |
2218 | end if; | |
2219 | end; | |
2220 | ||
2221 | else | |
2222 | OK1 := False; | |
2223 | end if; | |
2224 | end if; | |
2225 | ||
2226 | -- Attribute reference cases | |
2227 | ||
2228 | when N_Attribute_Reference => | |
2229 | case Attribute_Name (N) is | |
2230 | ||
2231 | -- For Pos/Val attributes, we can refine the range using the | |
2232 | -- possible range of values of the attribute expression | |
2233 | ||
2234 | when Name_Pos | Name_Val => | |
2235 | Determine_Range (First (Expressions (N)), OK1, Lor, Hir); | |
2236 | ||
2237 | -- For Length attribute, use the bounds of the corresponding | |
2238 | -- index type to refine the range. | |
2239 | ||
2240 | when Name_Length => | |
2241 | declare | |
2242 | Atyp : Entity_Id := Etype (Prefix (N)); | |
2243 | Inum : Nat; | |
2244 | Indx : Node_Id; | |
2245 | ||
2246 | LL, LU : Uint; | |
2247 | UL, UU : Uint; | |
2248 | ||
2249 | begin | |
2250 | if Is_Access_Type (Atyp) then | |
2251 | Atyp := Designated_Type (Atyp); | |
2252 | end if; | |
2253 | ||
2254 | -- For string literal, we know exact value | |
2255 | ||
2256 | if Ekind (Atyp) = E_String_Literal_Subtype then | |
2257 | OK := True; | |
2258 | Lo := String_Literal_Length (Atyp); | |
2259 | Hi := String_Literal_Length (Atyp); | |
2260 | return; | |
2261 | end if; | |
2262 | ||
2263 | -- Otherwise check for expression given | |
2264 | ||
2265 | if No (Expressions (N)) then | |
2266 | Inum := 1; | |
2267 | else | |
2268 | Inum := | |
2269 | UI_To_Int (Expr_Value (First (Expressions (N)))); | |
2270 | end if; | |
2271 | ||
2272 | Indx := First_Index (Atyp); | |
2273 | for J in 2 .. Inum loop | |
2274 | Indx := Next_Index (Indx); | |
2275 | end loop; | |
2276 | ||
2277 | Determine_Range | |
2278 | (Type_Low_Bound (Etype (Indx)), OK1, LL, LU); | |
2279 | ||
2280 | if OK1 then | |
2281 | Determine_Range | |
2282 | (Type_High_Bound (Etype (Indx)), OK1, UL, UU); | |
2283 | ||
2284 | if OK1 then | |
2285 | ||
2286 | -- The maximum value for Length is the biggest | |
2287 | -- possible gap between the values of the bounds. | |
2288 | -- But of course, this value cannot be negative. | |
2289 | ||
2290 | Hir := UI_Max (Uint_0, UU - LL); | |
2291 | ||
2292 | -- For constrained arrays, the minimum value for | |
2293 | -- Length is taken from the actual value of the | |
2294 | -- bounds, since the index will be exactly of | |
2295 | -- this subtype. | |
2296 | ||
2297 | if Is_Constrained (Atyp) then | |
2298 | Lor := UI_Max (Uint_0, UL - LU); | |
2299 | ||
2300 | -- For an unconstrained array, the minimum value | |
2301 | -- for length is always zero. | |
2302 | ||
2303 | else | |
2304 | Lor := Uint_0; | |
2305 | end if; | |
2306 | end if; | |
2307 | end if; | |
2308 | end; | |
2309 | ||
2310 | -- No special handling for other attributes | |
2311 | -- Probably more opportunities exist here ??? | |
2312 | ||
2313 | when others => | |
2314 | OK1 := False; | |
2315 | ||
2316 | end case; | |
2317 | ||
2318 | -- For type conversion from one discrete type to another, we | |
2319 | -- can refine the range using the converted value. | |
2320 | ||
2321 | when N_Type_Conversion => | |
2322 | Determine_Range (Expression (N), OK1, Lor, Hir); | |
2323 | ||
2324 | -- Nothing special to do for all other expression kinds | |
2325 | ||
2326 | when others => | |
2327 | OK1 := False; | |
2328 | Lor := No_Uint; | |
2329 | Hir := No_Uint; | |
2330 | end case; | |
2331 | ||
2332 | -- At this stage, if OK1 is true, then we know that the actual | |
2333 | -- result of the computed expression is in the range Lor .. Hir. | |
2334 | -- We can use this to restrict the possible range of results. | |
2335 | ||
2336 | if OK1 then | |
2337 | ||
2338 | -- If the refined value of the low bound is greater than the | |
2339 | -- type high bound, then reset it to the more restrictive | |
2340 | -- value. However, we do NOT do this for the case of a modular | |
2341 | -- type where the possible upper bound on the value is above the | |
2342 | -- base type high bound, because that means the result could wrap. | |
2343 | ||
2344 | if Lor > Lo | |
2345 | and then not (Is_Modular_Integer_Type (Typ) | |
2346 | and then Hir > Hbound) | |
2347 | then | |
2348 | Lo := Lor; | |
2349 | end if; | |
2350 | ||
2351 | -- Similarly, if the refined value of the high bound is less | |
2352 | -- than the value so far, then reset it to the more restrictive | |
2353 | -- value. Again, we do not do this if the refined low bound is | |
2354 | -- negative for a modular type, since this would wrap. | |
2355 | ||
2356 | if Hir < Hi | |
2357 | and then not (Is_Modular_Integer_Type (Typ) | |
2358 | and then Lor < Uint_0) | |
2359 | then | |
2360 | Hi := Hir; | |
2361 | end if; | |
2362 | end if; | |
2363 | ||
2364 | -- Set cache entry for future call and we are all done | |
2365 | ||
2366 | Determine_Range_Cache_N (Cindex) := N; | |
2367 | Determine_Range_Cache_Lo (Cindex) := Lo; | |
2368 | Determine_Range_Cache_Hi (Cindex) := Hi; | |
2369 | return; | |
2370 | ||
2371 | -- If any exception occurs, it means that we have some bug in the compiler | |
2372 | -- possibly triggered by a previous error, or by some unforseen peculiar | |
2373 | -- occurrence. However, this is only an optimization attempt, so there is | |
2374 | -- really no point in crashing the compiler. Instead we just decide, too | |
2375 | -- bad, we can't figure out a range in this case after all. | |
2376 | ||
2377 | exception | |
2378 | when others => | |
2379 | ||
2380 | -- Debug flag K disables this behavior (useful for debugging) | |
2381 | ||
2382 | if Debug_Flag_K then | |
2383 | raise; | |
2384 | else | |
2385 | OK := False; | |
2386 | Lo := No_Uint; | |
2387 | Hi := No_Uint; | |
2388 | return; | |
2389 | end if; | |
2390 | ||
2391 | end Determine_Range; | |
2392 | ||
2393 | ------------------------------------ | |
2394 | -- Discriminant_Checks_Suppressed -- | |
2395 | ------------------------------------ | |
2396 | ||
2397 | function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2398 | begin | |
2399 | return Scope_Suppress.Discriminant_Checks | |
2400 | or else (Present (E) and then Suppress_Discriminant_Checks (E)); | |
2401 | end Discriminant_Checks_Suppressed; | |
2402 | ||
2403 | -------------------------------- | |
2404 | -- Division_Checks_Suppressed -- | |
2405 | -------------------------------- | |
2406 | ||
2407 | function Division_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2408 | begin | |
2409 | return Scope_Suppress.Division_Checks | |
2410 | or else (Present (E) and then Suppress_Division_Checks (E)); | |
2411 | end Division_Checks_Suppressed; | |
2412 | ||
2413 | ----------------------------------- | |
2414 | -- Elaboration_Checks_Suppressed -- | |
2415 | ----------------------------------- | |
2416 | ||
2417 | function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2418 | begin | |
2419 | return Scope_Suppress.Elaboration_Checks | |
2420 | or else (Present (E) and then Suppress_Elaboration_Checks (E)); | |
2421 | end Elaboration_Checks_Suppressed; | |
2422 | ||
2423 | ------------------------ | |
2424 | -- Enable_Range_Check -- | |
2425 | ------------------------ | |
2426 | ||
2427 | procedure Enable_Range_Check (N : Node_Id) is | |
2428 | begin | |
2429 | if Nkind (N) = N_Unchecked_Type_Conversion | |
2430 | and then Kill_Range_Check (N) | |
2431 | then | |
2432 | return; | |
2433 | else | |
2434 | Set_Do_Range_Check (N, True); | |
2435 | end if; | |
2436 | end Enable_Range_Check; | |
2437 | ||
2438 | ------------------ | |
2439 | -- Ensure_Valid -- | |
2440 | ------------------ | |
2441 | ||
2442 | procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is | |
2443 | Typ : constant Entity_Id := Etype (Expr); | |
2444 | ||
2445 | begin | |
2446 | -- Ignore call if we are not doing any validity checking | |
2447 | ||
2448 | if not Validity_Checks_On then | |
2449 | return; | |
2450 | ||
2451 | -- No check required if expression is from the expander, we assume | |
2452 | -- the expander will generate whatever checks are needed. Note that | |
2453 | -- this is not just an optimization, it avoids infinite recursions! | |
2454 | ||
2455 | -- Unchecked conversions must be checked, unless they are initialized | |
2456 | -- scalar values, as in a component assignment in an init_proc. | |
2457 | ||
2458 | elsif not Comes_From_Source (Expr) | |
2459 | and then (Nkind (Expr) /= N_Unchecked_Type_Conversion | |
2460 | or else Kill_Range_Check (Expr)) | |
2461 | then | |
2462 | return; | |
2463 | ||
2464 | -- No check required if expression is known to have valid value | |
2465 | ||
2466 | elsif Expr_Known_Valid (Expr) then | |
2467 | return; | |
2468 | ||
2469 | -- No check required if checks off | |
2470 | ||
2471 | elsif Range_Checks_Suppressed (Typ) then | |
2472 | return; | |
2473 | ||
2474 | -- Ignore case of enumeration with holes where the flag is set not | |
2475 | -- to worry about holes, since no special validity check is needed | |
2476 | ||
2477 | elsif Is_Enumeration_Type (Typ) | |
2478 | and then Has_Non_Standard_Rep (Typ) | |
2479 | and then Holes_OK | |
2480 | then | |
2481 | return; | |
2482 | ||
2483 | -- No check required on the left-hand side of an assignment. | |
2484 | ||
2485 | elsif Nkind (Parent (Expr)) = N_Assignment_Statement | |
2486 | and then Expr = Name (Parent (Expr)) | |
2487 | then | |
2488 | return; | |
2489 | ||
2490 | -- An annoying special case. If this is an out parameter of a scalar | |
2491 | -- type, then the value is not going to be accessed, therefore it is | |
2492 | -- inappropriate to do any validity check at the call site. | |
2493 | ||
2494 | else | |
2495 | -- Only need to worry about scalar types | |
2496 | ||
2497 | if Is_Scalar_Type (Typ) then | |
2498 | declare | |
2499 | P : Node_Id; | |
2500 | N : Node_Id; | |
2501 | E : Entity_Id; | |
2502 | F : Entity_Id; | |
2503 | A : Node_Id; | |
2504 | L : List_Id; | |
2505 | ||
2506 | begin | |
2507 | -- Find actual argument (which may be a parameter association) | |
2508 | -- and the parent of the actual argument (the call statement) | |
2509 | ||
2510 | N := Expr; | |
2511 | P := Parent (Expr); | |
2512 | ||
2513 | if Nkind (P) = N_Parameter_Association then | |
2514 | N := P; | |
2515 | P := Parent (N); | |
2516 | end if; | |
2517 | ||
2518 | -- Only need to worry if we are argument of a procedure | |
2519 | -- call since functions don't have out parameters. | |
2520 | ||
2521 | if Nkind (P) = N_Procedure_Call_Statement then | |
2522 | L := Parameter_Associations (P); | |
2523 | E := Entity (Name (P)); | |
2524 | ||
2525 | -- Only need to worry if there are indeed actuals, and | |
2526 | -- if this could be a procedure call, otherwise we cannot | |
2527 | -- get a match (either we are not an argument, or the | |
2528 | -- mode of the formal is not OUT). This test also filters | |
2529 | -- out the generic case. | |
2530 | ||
2531 | if Is_Non_Empty_List (L) | |
2532 | and then Is_Subprogram (E) | |
2533 | then | |
2534 | -- This is the loop through parameters, looking to | |
2535 | -- see if there is an OUT parameter for which we are | |
2536 | -- the argument. | |
2537 | ||
2538 | F := First_Formal (E); | |
2539 | A := First (L); | |
2540 | ||
2541 | while Present (F) loop | |
2542 | if Ekind (F) = E_Out_Parameter and then A = N then | |
2543 | return; | |
2544 | end if; | |
2545 | ||
2546 | Next_Formal (F); | |
2547 | Next (A); | |
2548 | end loop; | |
2549 | end if; | |
2550 | end if; | |
2551 | end; | |
2552 | end if; | |
2553 | end if; | |
2554 | ||
2555 | -- If we fall through, a validity check is required. Note that it would | |
2556 | -- not be good to set Do_Range_Check, even in contexts where this is | |
2557 | -- permissible, since this flag causes checking against the target type, | |
2558 | -- not the source type in contexts such as assignments | |
2559 | ||
2560 | Insert_Valid_Check (Expr); | |
2561 | end Ensure_Valid; | |
2562 | ||
2563 | ---------------------- | |
2564 | -- Expr_Known_Valid -- | |
2565 | ---------------------- | |
2566 | ||
2567 | function Expr_Known_Valid (Expr : Node_Id) return Boolean is | |
2568 | Typ : constant Entity_Id := Etype (Expr); | |
2569 | ||
2570 | begin | |
2571 | -- Non-scalar types are always consdered valid, since they never | |
2572 | -- give rise to the issues of erroneous or bounded error behavior | |
2573 | -- that are the concern. In formal reference manual terms the | |
2574 | -- notion of validity only applies to scalar types. | |
2575 | ||
2576 | if not Is_Scalar_Type (Typ) then | |
2577 | return True; | |
2578 | ||
2579 | -- If no validity checking, then everything is considered valid | |
2580 | ||
2581 | elsif not Validity_Checks_On then | |
2582 | return True; | |
2583 | ||
2584 | -- Floating-point types are considered valid unless floating-point | |
2585 | -- validity checks have been specifically turned on. | |
2586 | ||
2587 | elsif Is_Floating_Point_Type (Typ) | |
2588 | and then not Validity_Check_Floating_Point | |
2589 | then | |
2590 | return True; | |
2591 | ||
2592 | -- If the expression is the value of an object that is known to | |
2593 | -- be valid, then clearly the expression value itself is valid. | |
2594 | ||
2595 | elsif Is_Entity_Name (Expr) | |
2596 | and then Is_Known_Valid (Entity (Expr)) | |
2597 | then | |
2598 | return True; | |
2599 | ||
2600 | -- If the type is one for which all values are known valid, then | |
2601 | -- we are sure that the value is valid except in the slightly odd | |
2602 | -- case where the expression is a reference to a variable whose size | |
2603 | -- has been explicitly set to a value greater than the object size. | |
2604 | ||
2605 | elsif Is_Known_Valid (Typ) then | |
2606 | if Is_Entity_Name (Expr) | |
2607 | and then Ekind (Entity (Expr)) = E_Variable | |
2608 | and then Esize (Entity (Expr)) > Esize (Typ) | |
2609 | then | |
2610 | return False; | |
2611 | else | |
2612 | return True; | |
2613 | end if; | |
2614 | ||
2615 | -- Integer and character literals always have valid values, where | |
2616 | -- appropriate these will be range checked in any case. | |
2617 | ||
2618 | elsif Nkind (Expr) = N_Integer_Literal | |
2619 | or else | |
2620 | Nkind (Expr) = N_Character_Literal | |
2621 | then | |
2622 | return True; | |
2623 | ||
2624 | -- If we have a type conversion or a qualification of a known valid | |
2625 | -- value, then the result will always be valid. | |
2626 | ||
2627 | elsif Nkind (Expr) = N_Type_Conversion | |
2628 | or else | |
2629 | Nkind (Expr) = N_Qualified_Expression | |
2630 | then | |
2631 | return Expr_Known_Valid (Expression (Expr)); | |
2632 | ||
2633 | -- The result of any function call or operator is always considered | |
2634 | -- valid, since we assume the necessary checks are done by the call. | |
2635 | ||
2636 | elsif Nkind (Expr) in N_Binary_Op | |
2637 | or else | |
2638 | Nkind (Expr) in N_Unary_Op | |
2639 | or else | |
2640 | Nkind (Expr) = N_Function_Call | |
2641 | then | |
2642 | return True; | |
2643 | ||
2644 | -- For all other cases, we do not know the expression is valid | |
2645 | ||
2646 | else | |
2647 | return False; | |
2648 | end if; | |
2649 | end Expr_Known_Valid; | |
2650 | ||
2651 | --------------------- | |
2652 | -- Get_Discriminal -- | |
2653 | --------------------- | |
2654 | ||
2655 | function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is | |
2656 | Loc : constant Source_Ptr := Sloc (E); | |
2657 | D : Entity_Id; | |
2658 | Sc : Entity_Id; | |
2659 | ||
2660 | begin | |
2661 | -- The entity E is the type of a private component of the protected | |
2662 | -- type, or the type of a renaming of that component within a protected | |
2663 | -- operation of that type. | |
2664 | ||
2665 | Sc := Scope (E); | |
2666 | ||
2667 | if Ekind (Sc) /= E_Protected_Type then | |
2668 | Sc := Scope (Sc); | |
2669 | ||
2670 | if Ekind (Sc) /= E_Protected_Type then | |
2671 | return Bound; | |
2672 | end if; | |
2673 | end if; | |
2674 | ||
2675 | D := First_Discriminant (Sc); | |
2676 | ||
2677 | while Present (D) | |
2678 | and then Chars (D) /= Chars (Bound) | |
2679 | loop | |
2680 | Next_Discriminant (D); | |
2681 | end loop; | |
2682 | ||
2683 | return New_Occurrence_Of (Discriminal (D), Loc); | |
2684 | end Get_Discriminal; | |
2685 | ||
2686 | ------------------ | |
2687 | -- Guard_Access -- | |
2688 | ------------------ | |
2689 | ||
2690 | function Guard_Access | |
2691 | (Cond : Node_Id; | |
2692 | Loc : Source_Ptr; | |
2693 | Ck_Node : Node_Id) | |
2694 | return Node_Id | |
2695 | is | |
2696 | begin | |
2697 | if Nkind (Cond) = N_Or_Else then | |
2698 | Set_Paren_Count (Cond, 1); | |
2699 | end if; | |
2700 | ||
2701 | if Nkind (Ck_Node) = N_Allocator then | |
2702 | return Cond; | |
2703 | else | |
2704 | return | |
2705 | Make_And_Then (Loc, | |
2706 | Left_Opnd => | |
2707 | Make_Op_Ne (Loc, | |
2708 | Left_Opnd => Duplicate_Subexpr (Ck_Node), | |
2709 | Right_Opnd => Make_Null (Loc)), | |
2710 | Right_Opnd => Cond); | |
2711 | end if; | |
2712 | end Guard_Access; | |
2713 | ||
2714 | ----------------------------- | |
2715 | -- Index_Checks_Suppressed -- | |
2716 | ----------------------------- | |
2717 | ||
2718 | function Index_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2719 | begin | |
2720 | return Scope_Suppress.Index_Checks | |
2721 | or else (Present (E) and then Suppress_Index_Checks (E)); | |
2722 | end Index_Checks_Suppressed; | |
2723 | ||
2724 | ---------------- | |
2725 | -- Initialize -- | |
2726 | ---------------- | |
2727 | ||
2728 | procedure Initialize is | |
2729 | begin | |
2730 | for J in Determine_Range_Cache_N'Range loop | |
2731 | Determine_Range_Cache_N (J) := Empty; | |
2732 | end loop; | |
2733 | end Initialize; | |
2734 | ||
2735 | ------------------------- | |
2736 | -- Insert_Range_Checks -- | |
2737 | ------------------------- | |
2738 | ||
2739 | procedure Insert_Range_Checks | |
2740 | (Checks : Check_Result; | |
2741 | Node : Node_Id; | |
2742 | Suppress_Typ : Entity_Id; | |
2743 | Static_Sloc : Source_Ptr := No_Location; | |
2744 | Flag_Node : Node_Id := Empty; | |
2745 | Do_Before : Boolean := False) | |
2746 | is | |
2747 | Internal_Flag_Node : Node_Id := Flag_Node; | |
2748 | Internal_Static_Sloc : Source_Ptr := Static_Sloc; | |
2749 | ||
2750 | Check_Node : Node_Id; | |
2751 | Checks_On : constant Boolean := | |
2752 | (not Index_Checks_Suppressed (Suppress_Typ)) | |
2753 | or else | |
2754 | (not Range_Checks_Suppressed (Suppress_Typ)); | |
2755 | ||
2756 | begin | |
2757 | -- For now we just return if Checks_On is false, however this should | |
2758 | -- be enhanced to check for an always True value in the condition | |
2759 | -- and to generate a compilation warning??? | |
2760 | ||
2761 | if not Expander_Active or else not Checks_On then | |
2762 | return; | |
2763 | end if; | |
2764 | ||
2765 | if Static_Sloc = No_Location then | |
2766 | Internal_Static_Sloc := Sloc (Node); | |
2767 | end if; | |
2768 | ||
2769 | if No (Flag_Node) then | |
2770 | Internal_Flag_Node := Node; | |
2771 | end if; | |
2772 | ||
2773 | for J in 1 .. 2 loop | |
2774 | exit when No (Checks (J)); | |
2775 | ||
2776 | if Nkind (Checks (J)) = N_Raise_Constraint_Error | |
2777 | and then Present (Condition (Checks (J))) | |
2778 | then | |
2779 | if not Has_Dynamic_Range_Check (Internal_Flag_Node) then | |
2780 | Check_Node := Checks (J); | |
2781 | Mark_Rewrite_Insertion (Check_Node); | |
2782 | ||
2783 | if Do_Before then | |
2784 | Insert_Before_And_Analyze (Node, Check_Node); | |
2785 | else | |
2786 | Insert_After_And_Analyze (Node, Check_Node); | |
2787 | end if; | |
2788 | ||
2789 | Set_Has_Dynamic_Range_Check (Internal_Flag_Node); | |
2790 | end if; | |
2791 | ||
2792 | else | |
2793 | Check_Node := | |
f15731c4 | 2794 | Make_Raise_Constraint_Error (Internal_Static_Sloc, |
2795 | Reason => CE_Range_Check_Failed); | |
ee6ba406 | 2796 | Mark_Rewrite_Insertion (Check_Node); |
2797 | ||
2798 | if Do_Before then | |
2799 | Insert_Before_And_Analyze (Node, Check_Node); | |
2800 | else | |
2801 | Insert_After_And_Analyze (Node, Check_Node); | |
2802 | end if; | |
2803 | end if; | |
2804 | end loop; | |
2805 | end Insert_Range_Checks; | |
2806 | ||
2807 | ------------------------ | |
2808 | -- Insert_Valid_Check -- | |
2809 | ------------------------ | |
2810 | ||
2811 | procedure Insert_Valid_Check (Expr : Node_Id) is | |
2812 | Loc : constant Source_Ptr := Sloc (Expr); | |
8b718dab | 2813 | Exp : Node_Id; |
ee6ba406 | 2814 | |
2815 | begin | |
2816 | -- Do not insert if checks off, or if not checking validity | |
2817 | ||
2818 | if Range_Checks_Suppressed (Etype (Expr)) | |
2819 | or else (not Validity_Checks_On) | |
2820 | then | |
8b718dab | 2821 | return; |
2822 | end if; | |
ee6ba406 | 2823 | |
8b718dab | 2824 | -- If we have a checked conversion, then validity check applies to |
2825 | -- the expression inside the conversion, not the result, since if | |
2826 | -- the expression inside is valid, then so is the conversion result. | |
ee6ba406 | 2827 | |
8b718dab | 2828 | Exp := Expr; |
2829 | while Nkind (Exp) = N_Type_Conversion loop | |
2830 | Exp := Expression (Exp); | |
2831 | end loop; | |
2832 | ||
f15731c4 | 2833 | -- Insert the validity check. Note that we do this with validity |
8b718dab | 2834 | -- checks turned off, to avoid recursion, we do not want validity |
2835 | -- checks on the validity checking code itself! | |
2836 | ||
2837 | Validity_Checks_On := False; | |
2838 | Insert_Action | |
2839 | (Expr, | |
2840 | Make_Raise_Constraint_Error (Loc, | |
2841 | Condition => | |
2842 | Make_Op_Not (Loc, | |
2843 | Right_Opnd => | |
2844 | Make_Attribute_Reference (Loc, | |
2845 | Prefix => | |
2846 | Duplicate_Subexpr (Exp, Name_Req => True), | |
f15731c4 | 2847 | Attribute_Name => Name_Valid)), |
2848 | Reason => CE_Invalid_Data), | |
8b718dab | 2849 | Suppress => All_Checks); |
2850 | Validity_Checks_On := True; | |
ee6ba406 | 2851 | end Insert_Valid_Check; |
2852 | ||
2853 | -------------------------- | |
2854 | -- Install_Static_Check -- | |
2855 | -------------------------- | |
2856 | ||
2857 | procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is | |
2858 | Stat : constant Boolean := Is_Static_Expression (R_Cno); | |
2859 | Typ : constant Entity_Id := Etype (R_Cno); | |
2860 | ||
2861 | begin | |
f15731c4 | 2862 | Rewrite (R_Cno, |
2863 | Make_Raise_Constraint_Error (Loc, | |
2864 | Reason => CE_Range_Check_Failed)); | |
ee6ba406 | 2865 | Set_Analyzed (R_Cno); |
2866 | Set_Etype (R_Cno, Typ); | |
2867 | Set_Raises_Constraint_Error (R_Cno); | |
2868 | Set_Is_Static_Expression (R_Cno, Stat); | |
2869 | end Install_Static_Check; | |
2870 | ||
2871 | ------------------------------ | |
2872 | -- Length_Checks_Suppressed -- | |
2873 | ------------------------------ | |
2874 | ||
2875 | function Length_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2876 | begin | |
2877 | return Scope_Suppress.Length_Checks | |
2878 | or else (Present (E) and then Suppress_Length_Checks (E)); | |
2879 | end Length_Checks_Suppressed; | |
2880 | ||
2881 | -------------------------------- | |
2882 | -- Overflow_Checks_Suppressed -- | |
2883 | -------------------------------- | |
2884 | ||
2885 | function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2886 | begin | |
2887 | return Scope_Suppress.Overflow_Checks | |
2888 | or else (Present (E) and then Suppress_Overflow_Checks (E)); | |
2889 | end Overflow_Checks_Suppressed; | |
2890 | ||
2891 | ----------------- | |
2892 | -- Range_Check -- | |
2893 | ----------------- | |
2894 | ||
2895 | function Range_Check | |
2896 | (Ck_Node : Node_Id; | |
2897 | Target_Typ : Entity_Id; | |
2898 | Source_Typ : Entity_Id := Empty; | |
2899 | Warn_Node : Node_Id := Empty) | |
2900 | return Check_Result | |
2901 | is | |
2902 | begin | |
2903 | return Selected_Range_Checks | |
2904 | (Ck_Node, Target_Typ, Source_Typ, Warn_Node); | |
2905 | end Range_Check; | |
2906 | ||
2907 | ----------------------------- | |
2908 | -- Range_Checks_Suppressed -- | |
2909 | ----------------------------- | |
2910 | ||
2911 | function Range_Checks_Suppressed (E : Entity_Id) return Boolean is | |
2912 | begin | |
2913 | -- Note: for now we always suppress range checks on Vax float types, | |
2914 | -- since Gigi does not know how to generate these checks. | |
2915 | ||
2916 | return Scope_Suppress.Range_Checks | |
2917 | or else (Present (E) and then Suppress_Range_Checks (E)) | |
2918 | or else Vax_Float (E); | |
2919 | end Range_Checks_Suppressed; | |
2920 | ||
2921 | ---------------------------- | |
2922 | -- Selected_Length_Checks -- | |
2923 | ---------------------------- | |
2924 | ||
2925 | function Selected_Length_Checks | |
2926 | (Ck_Node : Node_Id; | |
2927 | Target_Typ : Entity_Id; | |
2928 | Source_Typ : Entity_Id; | |
2929 | Warn_Node : Node_Id) | |
2930 | return Check_Result | |
2931 | is | |
2932 | Loc : constant Source_Ptr := Sloc (Ck_Node); | |
2933 | S_Typ : Entity_Id; | |
2934 | T_Typ : Entity_Id; | |
2935 | Expr_Actual : Node_Id; | |
2936 | Exptyp : Entity_Id; | |
2937 | Cond : Node_Id := Empty; | |
2938 | Do_Access : Boolean := False; | |
2939 | Wnode : Node_Id := Warn_Node; | |
2940 | Ret_Result : Check_Result := (Empty, Empty); | |
2941 | Num_Checks : Natural := 0; | |
2942 | ||
2943 | procedure Add_Check (N : Node_Id); | |
2944 | -- Adds the action given to Ret_Result if N is non-Empty | |
2945 | ||
2946 | function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; | |
2947 | function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; | |
2948 | ||
2949 | function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; | |
2950 | -- True for equal literals and for nodes that denote the same constant | |
5f260d20 | 2951 | -- entity, even if its value is not a static constant. This includes the |
2952 | -- case of a discriminal reference within an init_proc. Removes some | |
2953 | -- obviously superfluous checks. | |
ee6ba406 | 2954 | |
2955 | function Length_E_Cond | |
2956 | (Exptyp : Entity_Id; | |
2957 | Typ : Entity_Id; | |
2958 | Indx : Nat) | |
2959 | return Node_Id; | |
2960 | -- Returns expression to compute: | |
2961 | -- Typ'Length /= Exptyp'Length | |
2962 | ||
2963 | function Length_N_Cond | |
2964 | (Expr : Node_Id; | |
2965 | Typ : Entity_Id; | |
2966 | Indx : Nat) | |
2967 | return Node_Id; | |
2968 | -- Returns expression to compute: | |
2969 | -- Typ'Length /= Expr'Length | |
2970 | ||
2971 | --------------- | |
2972 | -- Add_Check -- | |
2973 | --------------- | |
2974 | ||
2975 | procedure Add_Check (N : Node_Id) is | |
2976 | begin | |
2977 | if Present (N) then | |
2978 | ||
2979 | -- For now, ignore attempt to place more than 2 checks ??? | |
2980 | ||
2981 | if Num_Checks = 2 then | |
2982 | return; | |
2983 | end if; | |
2984 | ||
2985 | pragma Assert (Num_Checks <= 1); | |
2986 | Num_Checks := Num_Checks + 1; | |
2987 | Ret_Result (Num_Checks) := N; | |
2988 | end if; | |
2989 | end Add_Check; | |
2990 | ||
2991 | ------------------ | |
2992 | -- Get_E_Length -- | |
2993 | ------------------ | |
2994 | ||
2995 | function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is | |
2996 | N : Node_Id; | |
2997 | E1 : Entity_Id := E; | |
2998 | Pt : Entity_Id := Scope (Scope (E)); | |
2999 | ||
3000 | begin | |
3001 | if Ekind (Scope (E)) = E_Record_Type | |
3002 | and then Has_Discriminants (Scope (E)) | |
3003 | then | |
3004 | N := Build_Discriminal_Subtype_Of_Component (E); | |
3005 | ||
3006 | if Present (N) then | |
3007 | Insert_Action (Ck_Node, N); | |
3008 | E1 := Defining_Identifier (N); | |
3009 | end if; | |
3010 | end if; | |
3011 | ||
3012 | if Ekind (E1) = E_String_Literal_Subtype then | |
3013 | return | |
3014 | Make_Integer_Literal (Loc, | |
3015 | Intval => String_Literal_Length (E1)); | |
3016 | ||
3017 | elsif Ekind (Pt) = E_Protected_Type | |
3018 | and then Has_Discriminants (Pt) | |
3019 | and then Has_Completion (Pt) | |
3020 | and then not Inside_Init_Proc | |
3021 | then | |
3022 | ||
3023 | -- If the type whose length is needed is a private component | |
3024 | -- constrained by a discriminant, we must expand the 'Length | |
3025 | -- attribute into an explicit computation, using the discriminal | |
3026 | -- of the current protected operation. This is because the actual | |
3027 | -- type of the prival is constructed after the protected opera- | |
3028 | -- tion has been fully expanded. | |
3029 | ||
3030 | declare | |
3031 | Indx_Type : Node_Id; | |
3032 | Lo : Node_Id; | |
3033 | Hi : Node_Id; | |
3034 | Do_Expand : Boolean := False; | |
3035 | ||
3036 | begin | |
3037 | Indx_Type := First_Index (E); | |
3038 | ||
3039 | for J in 1 .. Indx - 1 loop | |
3040 | Next_Index (Indx_Type); | |
3041 | end loop; | |
3042 | ||
3043 | Get_Index_Bounds (Indx_Type, Lo, Hi); | |
3044 | ||
3045 | if Nkind (Lo) = N_Identifier | |
3046 | and then Ekind (Entity (Lo)) = E_In_Parameter | |
3047 | then | |
3048 | Lo := Get_Discriminal (E, Lo); | |
3049 | Do_Expand := True; | |
3050 | end if; | |
3051 | ||
3052 | if Nkind (Hi) = N_Identifier | |
3053 | and then Ekind (Entity (Hi)) = E_In_Parameter | |
3054 | then | |
3055 | Hi := Get_Discriminal (E, Hi); | |
3056 | Do_Expand := True; | |
3057 | end if; | |
3058 | ||
3059 | if Do_Expand then | |
3060 | if not Is_Entity_Name (Lo) then | |
3061 | Lo := Duplicate_Subexpr (Lo); | |
3062 | end if; | |
3063 | ||
3064 | if not Is_Entity_Name (Hi) then | |
3065 | Lo := Duplicate_Subexpr (Hi); | |
3066 | end if; | |
3067 | ||
3068 | N := | |
3069 | Make_Op_Add (Loc, | |
3070 | Left_Opnd => | |
3071 | Make_Op_Subtract (Loc, | |
3072 | Left_Opnd => Hi, | |
3073 | Right_Opnd => Lo), | |
3074 | ||
3075 | Right_Opnd => Make_Integer_Literal (Loc, 1)); | |
3076 | return N; | |
3077 | ||
3078 | else | |
3079 | N := | |
3080 | Make_Attribute_Reference (Loc, | |
3081 | Attribute_Name => Name_Length, | |
3082 | Prefix => | |
3083 | New_Occurrence_Of (E1, Loc)); | |
3084 | ||
3085 | if Indx > 1 then | |
3086 | Set_Expressions (N, New_List ( | |
3087 | Make_Integer_Literal (Loc, Indx))); | |
3088 | end if; | |
3089 | ||
3090 | return N; | |
3091 | end if; | |
3092 | end; | |
3093 | ||
3094 | else | |
3095 | N := | |
3096 | Make_Attribute_Reference (Loc, | |
3097 | Attribute_Name => Name_Length, | |
3098 | Prefix => | |
3099 | New_Occurrence_Of (E1, Loc)); | |
3100 | ||
3101 | if Indx > 1 then | |
3102 | Set_Expressions (N, New_List ( | |
3103 | Make_Integer_Literal (Loc, Indx))); | |
3104 | end if; | |
3105 | ||
3106 | return N; | |
3107 | ||
3108 | end if; | |
3109 | end Get_E_Length; | |
3110 | ||
3111 | ------------------ | |
3112 | -- Get_N_Length -- | |
3113 | ------------------ | |
3114 | ||
3115 | function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is | |
3116 | begin | |
3117 | return | |
3118 | Make_Attribute_Reference (Loc, | |
3119 | Attribute_Name => Name_Length, | |
3120 | Prefix => | |
3121 | Duplicate_Subexpr (N, Name_Req => True), | |
3122 | Expressions => New_List ( | |
3123 | Make_Integer_Literal (Loc, Indx))); | |
3124 | ||
3125 | end Get_N_Length; | |
3126 | ||
3127 | ------------------- | |
3128 | -- Length_E_Cond -- | |
3129 | ------------------- | |
3130 | ||
3131 | function Length_E_Cond | |
3132 | (Exptyp : Entity_Id; | |
3133 | Typ : Entity_Id; | |
3134 | Indx : Nat) | |
3135 | return Node_Id | |
3136 | is | |
3137 | begin | |
3138 | return | |
3139 | Make_Op_Ne (Loc, | |
3140 | Left_Opnd => Get_E_Length (Typ, Indx), | |
3141 | Right_Opnd => Get_E_Length (Exptyp, Indx)); | |
3142 | ||
3143 | end Length_E_Cond; | |
3144 | ||
3145 | ------------------- | |
3146 | -- Length_N_Cond -- | |
3147 | ------------------- | |
3148 | ||
3149 | function Length_N_Cond | |
3150 | (Expr : Node_Id; | |
3151 | Typ : Entity_Id; | |
3152 | Indx : Nat) | |
3153 | return Node_Id | |
3154 | is | |
3155 | begin | |
3156 | return | |
3157 | Make_Op_Ne (Loc, | |
3158 | Left_Opnd => Get_E_Length (Typ, Indx), | |
3159 | Right_Opnd => Get_N_Length (Expr, Indx)); | |
3160 | ||
3161 | end Length_N_Cond; | |
3162 | ||
3163 | function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is | |
3164 | begin | |
3165 | return | |
3166 | (Nkind (L) = N_Integer_Literal | |
3167 | and then Nkind (R) = N_Integer_Literal | |
3168 | and then Intval (L) = Intval (R)) | |
3169 | ||
3170 | or else | |
3171 | (Is_Entity_Name (L) | |
3172 | and then Ekind (Entity (L)) = E_Constant | |
3173 | and then ((Is_Entity_Name (R) | |
3174 | and then Entity (L) = Entity (R)) | |
3175 | or else | |
3176 | (Nkind (R) = N_Type_Conversion | |
3177 | and then Is_Entity_Name (Expression (R)) | |
3178 | and then Entity (L) = Entity (Expression (R))))) | |
3179 | ||
3180 | or else | |
3181 | (Is_Entity_Name (R) | |
3182 | and then Ekind (Entity (R)) = E_Constant | |
3183 | and then Nkind (L) = N_Type_Conversion | |
3184 | and then Is_Entity_Name (Expression (L)) | |
5f260d20 | 3185 | and then Entity (R) = Entity (Expression (L))) |
3186 | ||
3187 | or else | |
3188 | (Is_Entity_Name (L) | |
3189 | and then Is_Entity_Name (R) | |
3190 | and then Entity (L) = Entity (R) | |
3191 | and then Ekind (Entity (L)) = E_In_Parameter | |
3192 | and then Inside_Init_Proc); | |
ee6ba406 | 3193 | end Same_Bounds; |
3194 | ||
3195 | -- Start of processing for Selected_Length_Checks | |
3196 | ||
3197 | begin | |
3198 | if not Expander_Active then | |
3199 | return Ret_Result; | |
3200 | end if; | |
3201 | ||
3202 | if Target_Typ = Any_Type | |
3203 | or else Target_Typ = Any_Composite | |
3204 | or else Raises_Constraint_Error (Ck_Node) | |
3205 | then | |
3206 | return Ret_Result; | |
3207 | end if; | |
3208 | ||
3209 | if No (Wnode) then | |
3210 | Wnode := Ck_Node; | |
3211 | end if; | |
3212 | ||
3213 | T_Typ := Target_Typ; | |
3214 | ||
3215 | if No (Source_Typ) then | |
3216 | S_Typ := Etype (Ck_Node); | |
3217 | else | |
3218 | S_Typ := Source_Typ; | |
3219 | end if; | |
3220 | ||
3221 | if S_Typ = Any_Type or else S_Typ = Any_Composite then | |
3222 | return Ret_Result; | |
3223 | end if; | |
3224 | ||
3225 | if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then | |
3226 | S_Typ := Designated_Type (S_Typ); | |
3227 | T_Typ := Designated_Type (T_Typ); | |
3228 | Do_Access := True; | |
3229 | ||
3230 | -- A simple optimization | |
3231 | ||
3232 | if Nkind (Ck_Node) = N_Null then | |
3233 | return Ret_Result; | |
3234 | end if; | |
3235 | end if; | |
3236 | ||
3237 | if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then | |
3238 | if Is_Constrained (T_Typ) then | |
3239 | ||
3240 | -- The checking code to be generated will freeze the | |
3241 | -- corresponding array type. However, we must freeze the | |
3242 | -- type now, so that the freeze node does not appear within | |
3243 | -- the generated condional expression, but ahead of it. | |
3244 | ||
3245 | Freeze_Before (Ck_Node, T_Typ); | |
3246 | ||
3247 | Expr_Actual := Get_Referenced_Object (Ck_Node); | |
3248 | Exptyp := Get_Actual_Subtype (Expr_Actual); | |
3249 | ||
3250 | if Is_Access_Type (Exptyp) then | |
3251 | Exptyp := Designated_Type (Exptyp); | |
3252 | end if; | |
3253 | ||
3254 | -- String_Literal case. This needs to be handled specially be- | |
3255 | -- cause no index types are available for string literals. The | |
3256 | -- condition is simply: | |
3257 | ||
3258 | -- T_Typ'Length = string-literal-length | |
3259 | ||
3260 | if Nkind (Expr_Actual) = N_String_Literal then | |
3261 | Cond := | |
3262 | Make_Op_Ne (Loc, | |
3263 | Left_Opnd => Get_E_Length (T_Typ, 1), | |
3264 | Right_Opnd => | |
3265 | Make_Integer_Literal (Loc, | |
3266 | Intval => | |
3267 | String_Literal_Length (Etype (Expr_Actual)))); | |
3268 | ||
3269 | -- General array case. Here we have a usable actual subtype for | |
3270 | -- the expression, and the condition is built from the two types | |
3271 | -- (Do_Length): | |
3272 | ||
3273 | -- T_Typ'Length /= Exptyp'Length or else | |
3274 | -- T_Typ'Length (2) /= Exptyp'Length (2) or else | |
3275 | -- T_Typ'Length (3) /= Exptyp'Length (3) or else | |
3276 | -- ... | |
3277 | ||
3278 | elsif Is_Constrained (Exptyp) then | |
3279 | declare | |
3280 | L_Index : Node_Id; | |
3281 | R_Index : Node_Id; | |
3282 | Ndims : Nat := Number_Dimensions (T_Typ); | |
3283 | ||
3284 | L_Low : Node_Id; | |
3285 | L_High : Node_Id; | |
3286 | R_Low : Node_Id; | |
3287 | R_High : Node_Id; | |
3288 | ||
3289 | L_Length : Uint; | |
3290 | R_Length : Uint; | |
3291 | ||
3292 | begin | |
3293 | L_Index := First_Index (T_Typ); | |
3294 | R_Index := First_Index (Exptyp); | |
3295 | ||
3296 | for Indx in 1 .. Ndims loop | |
3297 | if not (Nkind (L_Index) = N_Raise_Constraint_Error | |
f15731c4 | 3298 | or else |
3299 | Nkind (R_Index) = N_Raise_Constraint_Error) | |
ee6ba406 | 3300 | then |
3301 | Get_Index_Bounds (L_Index, L_Low, L_High); | |
3302 | Get_Index_Bounds (R_Index, R_Low, R_High); | |
3303 | ||
3304 | -- Deal with compile time length check. Note that we | |
3305 | -- skip this in the access case, because the access | |
3306 | -- value may be null, so we cannot know statically. | |
3307 | ||
3308 | if not Do_Access | |
3309 | and then Compile_Time_Known_Value (L_Low) | |
3310 | and then Compile_Time_Known_Value (L_High) | |
3311 | and then Compile_Time_Known_Value (R_Low) | |
3312 | and then Compile_Time_Known_Value (R_High) | |
3313 | then | |
3314 | if Expr_Value (L_High) >= Expr_Value (L_Low) then | |
3315 | L_Length := Expr_Value (L_High) - | |
3316 | Expr_Value (L_Low) + 1; | |
3317 | else | |
3318 | L_Length := UI_From_Int (0); | |
3319 | end if; | |
3320 | ||
3321 | if Expr_Value (R_High) >= Expr_Value (R_Low) then | |
3322 | R_Length := Expr_Value (R_High) - | |
3323 | Expr_Value (R_Low) + 1; | |
3324 | else | |
3325 | R_Length := UI_From_Int (0); | |
3326 | end if; | |
3327 | ||
3328 | if L_Length > R_Length then | |
3329 | Add_Check | |
3330 | (Compile_Time_Constraint_Error | |
3331 | (Wnode, "too few elements for}?", T_Typ)); | |
3332 | ||
3333 | elsif L_Length < R_Length then | |
3334 | Add_Check | |
3335 | (Compile_Time_Constraint_Error | |
3336 | (Wnode, "too many elements for}?", T_Typ)); | |
3337 | end if; | |
3338 | ||
3339 | -- The comparison for an individual index subtype | |
3340 | -- is omitted if the corresponding index subtypes | |
3341 | -- statically match, since the result is known to | |
3342 | -- be true. Note that this test is worth while even | |
3343 | -- though we do static evaluation, because non-static | |
3344 | -- subtypes can statically match. | |
3345 | ||
3346 | elsif not | |
3347 | Subtypes_Statically_Match | |
3348 | (Etype (L_Index), Etype (R_Index)) | |
3349 | ||
3350 | and then not | |
3351 | (Same_Bounds (L_Low, R_Low) | |
3352 | and then Same_Bounds (L_High, R_High)) | |
3353 | then | |
3354 | Evolve_Or_Else | |
3355 | (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); | |
3356 | end if; | |
3357 | ||
3358 | Next (L_Index); | |
3359 | Next (R_Index); | |
3360 | end if; | |
3361 | end loop; | |
3362 | end; | |
3363 | ||
3364 | -- Handle cases where we do not get a usable actual subtype that | |
3365 | -- is constrained. This happens for example in the function call | |
3366 | -- and explicit dereference cases. In these cases, we have to get | |
3367 | -- the length or range from the expression itself, making sure we | |
3368 | -- do not evaluate it more than once. | |
3369 | ||
3370 | -- Here Ck_Node is the original expression, or more properly the | |
3371 | -- result of applying Duplicate_Expr to the original tree, | |
3372 | -- forcing the result to be a name. | |
3373 | ||
3374 | else | |
3375 | declare | |
f15731c4 | 3376 | Ndims : Nat := Number_Dimensions (T_Typ); |
ee6ba406 | 3377 | |
3378 | begin | |
3379 | -- Build the condition for the explicit dereference case | |
3380 | ||
3381 | for Indx in 1 .. Ndims loop | |
3382 | Evolve_Or_Else | |
3383 | (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx)); | |
3384 | end loop; | |
3385 | end; | |
3386 | end if; | |
3387 | end if; | |
3388 | end if; | |
3389 | ||
3390 | -- Construct the test and insert into the tree | |
3391 | ||
3392 | if Present (Cond) then | |
3393 | if Do_Access then | |
3394 | Cond := Guard_Access (Cond, Loc, Ck_Node); | |
3395 | end if; | |
3396 | ||
f15731c4 | 3397 | Add_Check |
3398 | (Make_Raise_Constraint_Error (Loc, | |
3399 | Condition => Cond, | |
3400 | Reason => CE_Length_Check_Failed)); | |
ee6ba406 | 3401 | end if; |
3402 | ||
3403 | return Ret_Result; | |
ee6ba406 | 3404 | end Selected_Length_Checks; |
3405 | ||
3406 | --------------------------- | |
3407 | -- Selected_Range_Checks -- | |
3408 | --------------------------- | |
3409 | ||
3410 | function Selected_Range_Checks | |
3411 | (Ck_Node : Node_Id; | |
3412 | Target_Typ : Entity_Id; | |
3413 | Source_Typ : Entity_Id; | |
3414 | Warn_Node : Node_Id) | |
3415 | return Check_Result | |
3416 | is | |
3417 | Loc : constant Source_Ptr := Sloc (Ck_Node); | |
3418 | S_Typ : Entity_Id; | |
3419 | T_Typ : Entity_Id; | |
3420 | Expr_Actual : Node_Id; | |
3421 | Exptyp : Entity_Id; | |
3422 | Cond : Node_Id := Empty; | |
3423 | Do_Access : Boolean := False; | |
3424 | Wnode : Node_Id := Warn_Node; | |
3425 | Ret_Result : Check_Result := (Empty, Empty); | |
3426 | Num_Checks : Integer := 0; | |
3427 | ||
3428 | procedure Add_Check (N : Node_Id); | |
3429 | -- Adds the action given to Ret_Result if N is non-Empty | |
3430 | ||
3431 | function Discrete_Range_Cond | |
3432 | (Expr : Node_Id; | |
3433 | Typ : Entity_Id) | |
3434 | return Node_Id; | |
3435 | -- Returns expression to compute: | |
3436 | -- Low_Bound (Expr) < Typ'First | |
3437 | -- or else | |
3438 | -- High_Bound (Expr) > Typ'Last | |
3439 | ||
3440 | function Discrete_Expr_Cond | |
3441 | (Expr : Node_Id; | |
3442 | Typ : Entity_Id) | |
3443 | return Node_Id; | |
3444 | -- Returns expression to compute: | |
3445 | -- Expr < Typ'First | |
3446 | -- or else | |
3447 | -- Expr > Typ'Last | |
3448 | ||
3449 | function Get_E_First_Or_Last | |
3450 | (E : Entity_Id; | |
3451 | Indx : Nat; | |
3452 | Nam : Name_Id) | |
3453 | return Node_Id; | |
3454 | -- Returns expression to compute: | |
3455 | -- E'First or E'Last | |
3456 | ||
3457 | function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; | |
3458 | function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; | |
3459 | -- Returns expression to compute: | |
3460 | -- N'First or N'Last using Duplicate_Subexpr | |
3461 | ||
3462 | function Range_E_Cond | |
3463 | (Exptyp : Entity_Id; | |
3464 | Typ : Entity_Id; | |
3465 | Indx : Nat) | |
3466 | return Node_Id; | |
3467 | -- Returns expression to compute: | |
3468 | -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last | |
3469 | ||
3470 | function Range_Equal_E_Cond | |
3471 | (Exptyp : Entity_Id; | |
3472 | Typ : Entity_Id; | |
3473 | Indx : Nat) | |
3474 | return Node_Id; | |
3475 | -- Returns expression to compute: | |
3476 | -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last | |
3477 | ||
3478 | function Range_N_Cond | |
3479 | (Expr : Node_Id; | |
3480 | Typ : Entity_Id; | |
3481 | Indx : Nat) | |
3482 | return Node_Id; | |
3483 | -- Return expression to compute: | |
3484 | -- Expr'First < Typ'First or else Expr'Last > Typ'Last | |
3485 | ||
3486 | --------------- | |
3487 | -- Add_Check -- | |
3488 | --------------- | |
3489 | ||
3490 | procedure Add_Check (N : Node_Id) is | |
3491 | begin | |
3492 | if Present (N) then | |
3493 | ||
3494 | -- For now, ignore attempt to place more than 2 checks ??? | |
3495 | ||
3496 | if Num_Checks = 2 then | |
3497 | return; | |
3498 | end if; | |
3499 | ||
3500 | pragma Assert (Num_Checks <= 1); | |
3501 | Num_Checks := Num_Checks + 1; | |
3502 | Ret_Result (Num_Checks) := N; | |
3503 | end if; | |
3504 | end Add_Check; | |
3505 | ||
3506 | ------------------------- | |
3507 | -- Discrete_Expr_Cond -- | |
3508 | ------------------------- | |
3509 | ||
3510 | function Discrete_Expr_Cond | |
3511 | (Expr : Node_Id; | |
3512 | Typ : Entity_Id) | |
3513 | return Node_Id | |
3514 | is | |
3515 | begin | |
3516 | return | |
3517 | Make_Or_Else (Loc, | |
3518 | Left_Opnd => | |
3519 | Make_Op_Lt (Loc, | |
3520 | Left_Opnd => | |
3521 | Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)), | |
3522 | Right_Opnd => | |
3523 | Convert_To (Base_Type (Typ), | |
3524 | Get_E_First_Or_Last (Typ, 0, Name_First))), | |
3525 | ||
3526 | Right_Opnd => | |
3527 | Make_Op_Gt (Loc, | |
3528 | Left_Opnd => | |
3529 | Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)), | |
3530 | Right_Opnd => | |
3531 | Convert_To | |
3532 | (Base_Type (Typ), | |
3533 | Get_E_First_Or_Last (Typ, 0, Name_Last)))); | |
3534 | end Discrete_Expr_Cond; | |
3535 | ||
3536 | ------------------------- | |
3537 | -- Discrete_Range_Cond -- | |
3538 | ------------------------- | |
3539 | ||
3540 | function Discrete_Range_Cond | |
3541 | (Expr : Node_Id; | |
3542 | Typ : Entity_Id) | |
3543 | return Node_Id | |
3544 | is | |
3545 | LB : Node_Id := Low_Bound (Expr); | |
3546 | HB : Node_Id := High_Bound (Expr); | |
3547 | ||
3548 | Left_Opnd : Node_Id; | |
3549 | Right_Opnd : Node_Id; | |
3550 | ||
3551 | begin | |
3552 | if Nkind (LB) = N_Identifier | |
3553 | and then Ekind (Entity (LB)) = E_Discriminant then | |
3554 | LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); | |
3555 | end if; | |
3556 | ||
3557 | if Nkind (HB) = N_Identifier | |
3558 | and then Ekind (Entity (HB)) = E_Discriminant then | |
3559 | HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); | |
3560 | end if; | |
3561 | ||
3562 | Left_Opnd := | |
3563 | Make_Op_Lt (Loc, | |
3564 | Left_Opnd => | |
3565 | Convert_To | |
3566 | (Base_Type (Typ), Duplicate_Subexpr (LB)), | |
3567 | ||
3568 | Right_Opnd => | |
3569 | Convert_To | |
3570 | (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First))); | |
3571 | ||
3572 | if Base_Type (Typ) = Typ then | |
3573 | return Left_Opnd; | |
3574 | ||
3575 | elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ))) | |
3576 | and then | |
3577 | Compile_Time_Known_Value (High_Bound (Scalar_Range | |
3578 | (Base_Type (Typ)))) | |
3579 | then | |
3580 | if Is_Floating_Point_Type (Typ) then | |
3581 | if Expr_Value_R (High_Bound (Scalar_Range (Typ))) = | |
3582 | Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ)))) | |
3583 | then | |
3584 | return Left_Opnd; | |
3585 | end if; | |
3586 | ||
3587 | else | |
3588 | if Expr_Value (High_Bound (Scalar_Range (Typ))) = | |
3589 | Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ)))) | |
3590 | then | |
3591 | return Left_Opnd; | |
3592 | end if; | |
3593 | end if; | |
3594 | end if; | |
3595 | ||
3596 | Right_Opnd := | |
3597 | Make_Op_Gt (Loc, | |
3598 | Left_Opnd => | |
3599 | Convert_To | |
3600 | (Base_Type (Typ), Duplicate_Subexpr (HB)), | |
3601 | ||
3602 | Right_Opnd => | |
3603 | Convert_To | |
3604 | (Base_Type (Typ), | |
3605 | Get_E_First_Or_Last (Typ, 0, Name_Last))); | |
3606 | ||
3607 | return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); | |
3608 | end Discrete_Range_Cond; | |
3609 | ||
3610 | ------------------------- | |
3611 | -- Get_E_First_Or_Last -- | |
3612 | ------------------------- | |
3613 | ||
3614 | function Get_E_First_Or_Last | |
3615 | (E : Entity_Id; | |
3616 | Indx : Nat; | |
3617 | Nam : Name_Id) | |
3618 | return Node_Id | |
3619 | is | |
3620 | N : Node_Id; | |
3621 | LB : Node_Id; | |
3622 | HB : Node_Id; | |
3623 | Bound : Node_Id; | |
3624 | ||
3625 | begin | |
3626 | if Is_Array_Type (E) then | |
3627 | N := First_Index (E); | |
3628 | ||
3629 | for J in 2 .. Indx loop | |
3630 | Next_Index (N); | |
3631 | end loop; | |
3632 | ||
3633 | else | |
3634 | N := Scalar_Range (E); | |
3635 | end if; | |
3636 | ||
3637 | if Nkind (N) = N_Subtype_Indication then | |
3638 | LB := Low_Bound (Range_Expression (Constraint (N))); | |
3639 | HB := High_Bound (Range_Expression (Constraint (N))); | |
3640 | ||
3641 | elsif Is_Entity_Name (N) then | |
3642 | LB := Type_Low_Bound (Etype (N)); | |
3643 | HB := Type_High_Bound (Etype (N)); | |
3644 | ||
3645 | else | |
3646 | LB := Low_Bound (N); | |
3647 | HB := High_Bound (N); | |
3648 | end if; | |
3649 | ||
3650 | if Nam = Name_First then | |
3651 | Bound := LB; | |
3652 | else | |
3653 | Bound := HB; | |
3654 | end if; | |
3655 | ||
3656 | if Nkind (Bound) = N_Identifier | |
3657 | and then Ekind (Entity (Bound)) = E_Discriminant | |
3658 | then | |
3659 | return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); | |
3660 | ||
3661 | elsif Nkind (Bound) = N_Identifier | |
3662 | and then Ekind (Entity (Bound)) = E_In_Parameter | |
3663 | and then not Inside_Init_Proc | |
3664 | then | |
3665 | return Get_Discriminal (E, Bound); | |
3666 | ||
3667 | elsif Nkind (Bound) = N_Integer_Literal then | |
3668 | return Make_Integer_Literal (Loc, Intval (Bound)); | |
3669 | ||
3670 | else | |
3671 | return Duplicate_Subexpr (Bound); | |
3672 | end if; | |
3673 | end Get_E_First_Or_Last; | |
3674 | ||
3675 | ----------------- | |
3676 | -- Get_N_First -- | |
3677 | ----------------- | |
3678 | ||
3679 | function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is | |
3680 | begin | |
3681 | return | |
3682 | Make_Attribute_Reference (Loc, | |
3683 | Attribute_Name => Name_First, | |
3684 | Prefix => | |
3685 | Duplicate_Subexpr (N, Name_Req => True), | |
3686 | Expressions => New_List ( | |
3687 | Make_Integer_Literal (Loc, Indx))); | |
3688 | ||
3689 | end Get_N_First; | |
3690 | ||
3691 | ---------------- | |
3692 | -- Get_N_Last -- | |
3693 | ---------------- | |
3694 | ||
3695 | function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is | |
3696 | begin | |
3697 | return | |
3698 | Make_Attribute_Reference (Loc, | |
3699 | Attribute_Name => Name_Last, | |
3700 | Prefix => | |
3701 | Duplicate_Subexpr (N, Name_Req => True), | |
3702 | Expressions => New_List ( | |
3703 | Make_Integer_Literal (Loc, Indx))); | |
3704 | ||
3705 | end Get_N_Last; | |
3706 | ||
3707 | ------------------ | |
3708 | -- Range_E_Cond -- | |
3709 | ------------------ | |
3710 | ||
3711 | function Range_E_Cond | |
3712 | (Exptyp : Entity_Id; | |
3713 | Typ : Entity_Id; | |
3714 | Indx : Nat) | |
3715 | return Node_Id | |
3716 | is | |
3717 | begin | |
3718 | return | |
3719 | Make_Or_Else (Loc, | |
3720 | Left_Opnd => | |
3721 | Make_Op_Lt (Loc, | |
3722 | Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), | |
3723 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), | |
3724 | ||
3725 | Right_Opnd => | |
3726 | Make_Op_Gt (Loc, | |
3727 | Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), | |
3728 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); | |
3729 | ||
3730 | end Range_E_Cond; | |
3731 | ||
3732 | ------------------------ | |
3733 | -- Range_Equal_E_Cond -- | |
3734 | ------------------------ | |
3735 | ||
3736 | function Range_Equal_E_Cond | |
3737 | (Exptyp : Entity_Id; | |
3738 | Typ : Entity_Id; | |
3739 | Indx : Nat) | |
3740 | return Node_Id | |
3741 | is | |
3742 | begin | |
3743 | return | |
3744 | Make_Or_Else (Loc, | |
3745 | Left_Opnd => | |
3746 | Make_Op_Ne (Loc, | |
3747 | Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), | |
3748 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), | |
3749 | Right_Opnd => | |
3750 | Make_Op_Ne (Loc, | |
3751 | Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), | |
3752 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); | |
3753 | end Range_Equal_E_Cond; | |
3754 | ||
3755 | ------------------ | |
3756 | -- Range_N_Cond -- | |
3757 | ------------------ | |
3758 | ||
3759 | function Range_N_Cond | |
3760 | (Expr : Node_Id; | |
3761 | Typ : Entity_Id; | |
3762 | Indx : Nat) | |
3763 | return Node_Id | |
3764 | is | |
3765 | begin | |
3766 | return | |
3767 | Make_Or_Else (Loc, | |
3768 | Left_Opnd => | |
3769 | Make_Op_Lt (Loc, | |
3770 | Left_Opnd => Get_N_First (Expr, Indx), | |
3771 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), | |
3772 | ||
3773 | Right_Opnd => | |
3774 | Make_Op_Gt (Loc, | |
3775 | Left_Opnd => Get_N_Last (Expr, Indx), | |
3776 | Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); | |
3777 | end Range_N_Cond; | |
3778 | ||
3779 | -- Start of processing for Selected_Range_Checks | |
3780 | ||
3781 | begin | |
3782 | if not Expander_Active then | |
3783 | return Ret_Result; | |
3784 | end if; | |
3785 | ||
3786 | if Target_Typ = Any_Type | |
3787 | or else Target_Typ = Any_Composite | |
3788 | or else Raises_Constraint_Error (Ck_Node) | |
3789 | then | |
3790 | return Ret_Result; | |
3791 | end if; | |
3792 | ||
3793 | if No (Wnode) then | |
3794 | Wnode := Ck_Node; | |
3795 | end if; | |
3796 | ||
3797 | T_Typ := Target_Typ; | |
3798 | ||
3799 | if No (Source_Typ) then | |
3800 | S_Typ := Etype (Ck_Node); | |
3801 | else | |
3802 | S_Typ := Source_Typ; | |
3803 | end if; | |
3804 | ||
3805 | if S_Typ = Any_Type or else S_Typ = Any_Composite then | |
3806 | return Ret_Result; | |
3807 | end if; | |
3808 | ||
3809 | -- The order of evaluating T_Typ before S_Typ seems to be critical | |
3810 | -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed | |
3811 | -- in, and since Node can be an N_Range node, it might be invalid. | |
3812 | -- Should there be an assert check somewhere for taking the Etype of | |
3813 | -- an N_Range node ??? | |
3814 | ||
3815 | if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then | |
3816 | S_Typ := Designated_Type (S_Typ); | |
3817 | T_Typ := Designated_Type (T_Typ); | |
3818 | Do_Access := True; | |
3819 | ||
3820 | -- A simple optimization | |
3821 | ||
3822 | if Nkind (Ck_Node) = N_Null then | |
3823 | return Ret_Result; | |
3824 | end if; | |
3825 | end if; | |
3826 | ||
3827 | -- For an N_Range Node, check for a null range and then if not | |
3828 | -- null generate a range check action. | |
3829 | ||
3830 | if Nkind (Ck_Node) = N_Range then | |
3831 | ||
3832 | -- There's no point in checking a range against itself | |
3833 | ||
3834 | if Ck_Node = Scalar_Range (T_Typ) then | |
3835 | return Ret_Result; | |
3836 | end if; | |
3837 | ||
3838 | declare | |
3839 | T_LB : constant Node_Id := Type_Low_Bound (T_Typ); | |
3840 | T_HB : constant Node_Id := Type_High_Bound (T_Typ); | |
3841 | LB : constant Node_Id := Low_Bound (Ck_Node); | |
3842 | HB : constant Node_Id := High_Bound (Ck_Node); | |
3843 | Null_Range : Boolean; | |
3844 | ||
3845 | Out_Of_Range_L : Boolean; | |
3846 | Out_Of_Range_H : Boolean; | |
3847 | ||
3848 | begin | |
3849 | -- Check for case where everything is static and we can | |
3850 | -- do the check at compile time. This is skipped if we | |
3851 | -- have an access type, since the access value may be null. | |
3852 | ||
3853 | -- ??? This code can be improved since you only need to know | |
3854 | -- that the two respective bounds (LB & T_LB or HB & T_HB) | |
3855 | -- are known at compile time to emit pertinent messages. | |
3856 | ||
3857 | if Compile_Time_Known_Value (LB) | |
3858 | and then Compile_Time_Known_Value (HB) | |
3859 | and then Compile_Time_Known_Value (T_LB) | |
3860 | and then Compile_Time_Known_Value (T_HB) | |
3861 | and then not Do_Access | |
3862 | then | |
3863 | -- Floating-point case | |
3864 | ||
3865 | if Is_Floating_Point_Type (S_Typ) then | |
3866 | Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); | |
3867 | Out_Of_Range_L := | |
3868 | (Expr_Value_R (LB) < Expr_Value_R (T_LB)) | |
3869 | or else | |
3870 | (Expr_Value_R (LB) > Expr_Value_R (T_HB)); | |
3871 | ||
3872 | Out_Of_Range_H := | |
3873 | (Expr_Value_R (HB) > Expr_Value_R (T_HB)) | |
3874 | or else | |
3875 | (Expr_Value_R (HB) < Expr_Value_R (T_LB)); | |
3876 | ||
3877 | -- Fixed or discrete type case | |
3878 | ||
3879 | else | |
3880 | Null_Range := Expr_Value (HB) < Expr_Value (LB); | |
3881 | Out_Of_Range_L := | |
3882 | (Expr_Value (LB) < Expr_Value (T_LB)) | |
3883 | or else | |
3884 | (Expr_Value (LB) > Expr_Value (T_HB)); | |
3885 | ||
3886 | Out_Of_Range_H := | |
3887 | (Expr_Value (HB) > Expr_Value (T_HB)) | |
3888 | or else | |
3889 | (Expr_Value (HB) < Expr_Value (T_LB)); | |
3890 | end if; | |
3891 | ||
3892 | if not Null_Range then | |
3893 | if Out_Of_Range_L then | |
3894 | if No (Warn_Node) then | |
3895 | Add_Check | |
3896 | (Compile_Time_Constraint_Error | |
3897 | (Low_Bound (Ck_Node), | |
3898 | "static value out of range of}?", T_Typ)); | |
3899 | ||
3900 | else | |
3901 | Add_Check | |
3902 | (Compile_Time_Constraint_Error | |
3903 | (Wnode, | |
3904 | "static range out of bounds of}?", T_Typ)); | |
3905 | end if; | |
3906 | end if; | |
3907 | ||
3908 | if Out_Of_Range_H then | |
3909 | if No (Warn_Node) then | |
3910 | Add_Check | |
3911 | (Compile_Time_Constraint_Error | |
3912 | (High_Bound (Ck_Node), | |
3913 | "static value out of range of}?", T_Typ)); | |
3914 | ||
3915 | else | |
3916 | Add_Check | |
3917 | (Compile_Time_Constraint_Error | |
3918 | (Wnode, | |
3919 | "static range out of bounds of}?", T_Typ)); | |
3920 | end if; | |
3921 | end if; | |
3922 | ||
3923 | end if; | |
3924 | ||
3925 | else | |
3926 | declare | |
3927 | LB : Node_Id := Low_Bound (Ck_Node); | |
3928 | HB : Node_Id := High_Bound (Ck_Node); | |
3929 | ||
3930 | begin | |
3931 | ||
3932 | -- If either bound is a discriminant and we are within | |
3933 | -- the record declaration, it is a use of the discriminant | |
3934 | -- in a constraint of a component, and nothing can be | |
3935 | -- checked here. The check will be emitted within the | |
3936 | -- init_proc. Before then, the discriminal has no real | |
3937 | -- meaning. | |
3938 | ||
3939 | if Nkind (LB) = N_Identifier | |
3940 | and then Ekind (Entity (LB)) = E_Discriminant | |
3941 | then | |
3942 | if Current_Scope = Scope (Entity (LB)) then | |
3943 | return Ret_Result; | |
3944 | else | |
3945 | LB := | |
3946 | New_Occurrence_Of (Discriminal (Entity (LB)), Loc); | |
3947 | end if; | |
3948 | end if; | |
3949 | ||
3950 | if Nkind (HB) = N_Identifier | |
3951 | and then Ekind (Entity (HB)) = E_Discriminant | |
3952 | then | |
3953 | if Current_Scope = Scope (Entity (HB)) then | |
3954 | return Ret_Result; | |
3955 | else | |
3956 | HB := | |
3957 | New_Occurrence_Of (Discriminal (Entity (HB)), Loc); | |
3958 | end if; | |
3959 | end if; | |
3960 | ||
3961 | Cond := Discrete_Range_Cond (Ck_Node, T_Typ); | |
3962 | Set_Paren_Count (Cond, 1); | |
3963 | ||
3964 | Cond := | |
3965 | Make_And_Then (Loc, | |
3966 | Left_Opnd => | |
3967 | Make_Op_Ge (Loc, | |
3968 | Left_Opnd => Duplicate_Subexpr (HB), | |
3969 | Right_Opnd => Duplicate_Subexpr (LB)), | |
3970 | Right_Opnd => Cond); | |
3971 | end; | |
3972 | ||
3973 | end if; | |
3974 | end; | |
3975 | ||
3976 | elsif Is_Scalar_Type (S_Typ) then | |
3977 | ||
3978 | -- This somewhat duplicates what Apply_Scalar_Range_Check does, | |
3979 | -- except the above simply sets a flag in the node and lets | |
3980 | -- gigi generate the check base on the Etype of the expression. | |
3981 | -- Sometimes, however we want to do a dynamic check against an | |
3982 | -- arbitrary target type, so we do that here. | |
3983 | ||
3984 | if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then | |
3985 | Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); | |
3986 | ||
3987 | -- For literals, we can tell if the constraint error will be | |
3988 | -- raised at compile time, so we never need a dynamic check, but | |
3989 | -- if the exception will be raised, then post the usual warning, | |
3990 | -- and replace the literal with a raise constraint error | |
3991 | -- expression. As usual, skip this for access types | |
3992 | ||
3993 | elsif Compile_Time_Known_Value (Ck_Node) | |
3994 | and then not Do_Access | |
3995 | then | |
3996 | declare | |
3997 | LB : constant Node_Id := Type_Low_Bound (T_Typ); | |
3998 | UB : constant Node_Id := Type_High_Bound (T_Typ); | |
3999 | ||
4000 | Out_Of_Range : Boolean; | |
4001 | Static_Bounds : constant Boolean := | |
4002 | Compile_Time_Known_Value (LB) | |
4003 | and Compile_Time_Known_Value (UB); | |
4004 | ||
4005 | begin | |
4006 | -- Following range tests should use Sem_Eval routine ??? | |
4007 | ||
4008 | if Static_Bounds then | |
4009 | if Is_Floating_Point_Type (S_Typ) then | |
4010 | Out_Of_Range := | |
4011 | (Expr_Value_R (Ck_Node) < Expr_Value_R (LB)) | |
4012 | or else | |
4013 | (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); | |
4014 | ||
4015 | else -- fixed or discrete type | |
4016 | Out_Of_Range := | |
4017 | Expr_Value (Ck_Node) < Expr_Value (LB) | |
4018 | or else | |
4019 | Expr_Value (Ck_Node) > Expr_Value (UB); | |
4020 | end if; | |
4021 | ||
4022 | -- Bounds of the type are static and the literal is | |
4023 | -- out of range so make a warning message. | |
4024 | ||
4025 | if Out_Of_Range then | |
4026 | if No (Warn_Node) then | |
4027 | Add_Check | |
4028 | (Compile_Time_Constraint_Error | |
4029 | (Ck_Node, | |
4030 | "static value out of range of}?", T_Typ)); | |
4031 | ||
4032 | else | |
4033 | Add_Check | |
4034 | (Compile_Time_Constraint_Error | |
4035 | (Wnode, | |
4036 | "static value out of range of}?", T_Typ)); | |
4037 | end if; | |
4038 | end if; | |
4039 | ||
4040 | else | |
4041 | Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); | |
4042 | end if; | |
4043 | end; | |
4044 | ||
4045 | -- Here for the case of a non-static expression, we need a runtime | |
4046 | -- check unless the source type range is guaranteed to be in the | |
4047 | -- range of the target type. | |
4048 | ||
4049 | else | |
4050 | if not In_Subrange_Of (S_Typ, T_Typ) then | |
4051 | Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); | |
4052 | end if; | |
4053 | end if; | |
4054 | end if; | |
4055 | ||
4056 | if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then | |
4057 | if Is_Constrained (T_Typ) then | |
4058 | ||
4059 | Expr_Actual := Get_Referenced_Object (Ck_Node); | |
4060 | Exptyp := Get_Actual_Subtype (Expr_Actual); | |
4061 | ||
4062 | if Is_Access_Type (Exptyp) then | |
4063 | Exptyp := Designated_Type (Exptyp); | |
4064 | end if; | |
4065 | ||
4066 | -- String_Literal case. This needs to be handled specially be- | |
4067 | -- cause no index types are available for string literals. The | |
4068 | -- condition is simply: | |
4069 | ||
4070 | -- T_Typ'Length = string-literal-length | |
4071 | ||
4072 | if Nkind (Expr_Actual) = N_String_Literal then | |
4073 | null; | |
4074 | ||
4075 | -- General array case. Here we have a usable actual subtype for | |
4076 | -- the expression, and the condition is built from the two types | |
4077 | ||
4078 | -- T_Typ'First < Exptyp'First or else | |
4079 | -- T_Typ'Last > Exptyp'Last or else | |
4080 | -- T_Typ'First(1) < Exptyp'First(1) or else | |
4081 | -- T_Typ'Last(1) > Exptyp'Last(1) or else | |
4082 | -- ... | |
4083 | ||
4084 | elsif Is_Constrained (Exptyp) then | |
4085 | declare | |
4086 | L_Index : Node_Id; | |
4087 | R_Index : Node_Id; | |
4088 | Ndims : Nat := Number_Dimensions (T_Typ); | |
4089 | ||
4090 | L_Low : Node_Id; | |
4091 | L_High : Node_Id; | |
4092 | R_Low : Node_Id; | |
4093 | R_High : Node_Id; | |
4094 | ||
4095 | begin | |
4096 | L_Index := First_Index (T_Typ); | |
4097 | R_Index := First_Index (Exptyp); | |
4098 | ||
4099 | for Indx in 1 .. Ndims loop | |
4100 | if not (Nkind (L_Index) = N_Raise_Constraint_Error | |
f15731c4 | 4101 | or else |
4102 | Nkind (R_Index) = N_Raise_Constraint_Error) | |
ee6ba406 | 4103 | then |
4104 | Get_Index_Bounds (L_Index, L_Low, L_High); | |
4105 | Get_Index_Bounds (R_Index, R_Low, R_High); | |
4106 | ||
4107 | -- Deal with compile time length check. Note that we | |
4108 | -- skip this in the access case, because the access | |
4109 | -- value may be null, so we cannot know statically. | |
4110 | ||
4111 | if not | |
4112 | Subtypes_Statically_Match | |
4113 | (Etype (L_Index), Etype (R_Index)) | |
4114 | then | |
4115 | -- If the target type is constrained then we | |
4116 | -- have to check for exact equality of bounds | |
4117 | -- (required for qualified expressions). | |
4118 | ||
4119 | if Is_Constrained (T_Typ) then | |
4120 | Evolve_Or_Else | |
4121 | (Cond, | |
4122 | Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); | |
4123 | ||
4124 | else | |
4125 | Evolve_Or_Else | |
4126 | (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); | |
4127 | end if; | |
4128 | end if; | |
4129 | ||
4130 | Next (L_Index); | |
4131 | Next (R_Index); | |
4132 | ||
4133 | end if; | |
4134 | end loop; | |
4135 | end; | |
4136 | ||
4137 | -- Handle cases where we do not get a usable actual subtype that | |
4138 | -- is constrained. This happens for example in the function call | |
4139 | -- and explicit dereference cases. In these cases, we have to get | |
4140 | -- the length or range from the expression itself, making sure we | |
4141 | -- do not evaluate it more than once. | |
4142 | ||
4143 | -- Here Ck_Node is the original expression, or more properly the | |
4144 | -- result of applying Duplicate_Expr to the original tree, | |
4145 | -- forcing the result to be a name. | |
4146 | ||
4147 | else | |
4148 | declare | |
4149 | Ndims : Nat := Number_Dimensions (T_Typ); | |
4150 | ||
4151 | begin | |
4152 | -- Build the condition for the explicit dereference case | |
4153 | ||
4154 | for Indx in 1 .. Ndims loop | |
4155 | Evolve_Or_Else | |
4156 | (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); | |
4157 | end loop; | |
4158 | end; | |
4159 | ||
4160 | end if; | |
4161 | ||
4162 | else | |
4163 | -- Generate an Action to check that the bounds of the | |
4164 | -- source value are within the constraints imposed by the | |
4165 | -- target type for a conversion to an unconstrained type. | |
4166 | -- Rule is 4.6(38). | |
4167 | ||
4168 | if Nkind (Parent (Ck_Node)) = N_Type_Conversion then | |
4169 | declare | |
4170 | Opnd_Index : Node_Id; | |
4171 | Targ_Index : Node_Id; | |
4172 | ||
4173 | begin | |
4174 | Opnd_Index | |
4175 | := First_Index (Get_Actual_Subtype (Ck_Node)); | |
4176 | Targ_Index := First_Index (T_Typ); | |
4177 | ||
4178 | while Opnd_Index /= Empty loop | |
4179 | if Nkind (Opnd_Index) = N_Range then | |
4180 | if Is_In_Range | |
4181 | (Low_Bound (Opnd_Index), Etype (Targ_Index)) | |
4182 | and then | |
4183 | Is_In_Range | |
4184 | (High_Bound (Opnd_Index), Etype (Targ_Index)) | |
4185 | then | |
4186 | null; | |
4187 | ||
4188 | elsif Is_Out_Of_Range | |
4189 | (Low_Bound (Opnd_Index), Etype (Targ_Index)) | |
4190 | or else | |
4191 | Is_Out_Of_Range | |
4192 | (High_Bound (Opnd_Index), Etype (Targ_Index)) | |
4193 | then | |
4194 | Add_Check | |
4195 | (Compile_Time_Constraint_Error | |
4196 | (Wnode, "value out of range of}?", T_Typ)); | |
4197 | ||
4198 | else | |
4199 | Evolve_Or_Else | |
4200 | (Cond, | |
4201 | Discrete_Range_Cond | |
4202 | (Opnd_Index, Etype (Targ_Index))); | |
4203 | end if; | |
4204 | end if; | |
4205 | ||
4206 | Next_Index (Opnd_Index); | |
4207 | Next_Index (Targ_Index); | |
4208 | end loop; | |
4209 | end; | |
4210 | end if; | |
4211 | end if; | |
4212 | end if; | |
4213 | ||
4214 | -- Construct the test and insert into the tree | |
4215 | ||
4216 | if Present (Cond) then | |
4217 | if Do_Access then | |
4218 | Cond := Guard_Access (Cond, Loc, Ck_Node); | |
4219 | end if; | |
4220 | ||
f15731c4 | 4221 | Add_Check |
4222 | (Make_Raise_Constraint_Error (Loc, | |
4223 | Condition => Cond, | |
4224 | Reason => CE_Range_Check_Failed)); | |
ee6ba406 | 4225 | end if; |
4226 | ||
4227 | return Ret_Result; | |
ee6ba406 | 4228 | end Selected_Range_Checks; |
4229 | ||
4230 | ------------------------------- | |
4231 | -- Storage_Checks_Suppressed -- | |
4232 | ------------------------------- | |
4233 | ||
4234 | function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is | |
4235 | begin | |
4236 | return Scope_Suppress.Storage_Checks | |
4237 | or else (Present (E) and then Suppress_Storage_Checks (E)); | |
4238 | end Storage_Checks_Suppressed; | |
4239 | ||
4240 | --------------------------- | |
4241 | -- Tag_Checks_Suppressed -- | |
4242 | --------------------------- | |
4243 | ||
4244 | function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is | |
4245 | begin | |
4246 | return Scope_Suppress.Tag_Checks | |
4247 | or else (Present (E) and then Suppress_Tag_Checks (E)); | |
4248 | end Tag_Checks_Suppressed; | |
4249 | ||
4250 | end Checks; |