1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Errout; use Errout;
33 with Exp_Ch2; use Exp_Ch2;
34 with Exp_Util; use Exp_Util;
35 with Elists; use Elists;
36 with Freeze; use Freeze;
37 with Nlists; use Nlists;
38 with Nmake; use Nmake;
40 with Rtsfind; use Rtsfind;
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;
49 with Tbuild; use Tbuild;
50 with Ttypes; use Ttypes;
51 with Urealp; use Urealp;
52 with Validsw; use Validsw;
54 package body Checks is
56 -- General note: many of these routines are concerned with generating
57 -- checking code to make sure that constraint error is raised at runtime.
58 -- Clearly this code is only needed if the expander is active, since
59 -- otherwise we will not be generating code or going into the runtime
62 -- We therefore disconnect most of these checks if the expander is
63 -- inactive. This has the additional benefit that we do not need to
64 -- worry about the tree being messed up by previous errors (since errors
65 -- turn off expansion anyway).
67 -- There are a few exceptions to the above rule. For instance routines
68 -- such as Apply_Scalar_Range_Check that do not insert any code can be
69 -- safely called even when the Expander is inactive (but Errors_Detected
70 -- is 0). The benefit of executing this code when expansion is off, is
71 -- the ability to emit constraint error warning for static expressions
72 -- even when we are not generating code.
74 ----------------------------
75 -- Local Subprogram Specs --
76 ----------------------------
78 procedure Apply_Selected_Length_Checks
80 Target_Typ : Entity_Id;
81 Source_Typ : Entity_Id;
83 -- This is the subprogram that does all the work for Apply_Length_Check
84 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
85 -- described for the above routines. The Do_Static flag indicates that
86 -- only a static check is to be done.
88 procedure Apply_Selected_Range_Checks
90 Target_Typ : Entity_Id;
91 Source_Typ : Entity_Id;
93 -- This is the subprogram that does all the work for Apply_Range_Check.
94 -- Expr, Target_Typ and Source_Typ are as described for the above
95 -- routine. The Do_Static flag indicates that only a static check is
98 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
99 -- If a discriminal is used in constraining a prival, Return reference
100 -- to the discriminal of the protected body (which renames the parameter
101 -- of the enclosing protected operation). This clumsy transformation is
102 -- needed because privals are created too late and their actual subtypes
103 -- are not available when analysing the bodies of the protected operations.
104 -- To be cleaned up???
106 function Guard_Access
111 -- In the access type case, guard the test with a test to ensure
112 -- that the access value is non-null, since the checks do not
113 -- not apply to null access values.
115 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
116 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
117 -- Constraint_Error node.
119 function Selected_Length_Checks
121 Target_Typ : Entity_Id;
122 Source_Typ : Entity_Id;
125 -- Like Apply_Selected_Length_Checks, except it doesn't modify
126 -- anything, just returns a list of nodes as described in the spec of
127 -- this package for the Range_Check function.
129 function Selected_Range_Checks
131 Target_Typ : Entity_Id;
132 Source_Typ : Entity_Id;
135 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
136 -- just returns a list of nodes as described in the spec of this package
137 -- for the Range_Check function.
139 ------------------------------
140 -- Access_Checks_Suppressed --
141 ------------------------------
143 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
145 return Scope_Suppress.Access_Checks
146 or else (Present (E) and then Suppress_Access_Checks (E));
147 end Access_Checks_Suppressed;
149 -------------------------------------
150 -- Accessibility_Checks_Suppressed --
151 -------------------------------------
153 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
155 return Scope_Suppress.Accessibility_Checks
156 or else (Present (E) and then Suppress_Accessibility_Checks (E));
157 end Accessibility_Checks_Suppressed;
159 -------------------------
160 -- Append_Range_Checks --
161 -------------------------
163 procedure Append_Range_Checks
164 (Checks : Check_Result;
166 Suppress_Typ : Entity_Id;
167 Static_Sloc : Source_Ptr;
170 Internal_Flag_Node : Node_Id := Flag_Node;
171 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
172 Checks_On : constant Boolean :=
173 (not Index_Checks_Suppressed (Suppress_Typ))
175 (not Range_Checks_Suppressed (Suppress_Typ));
178 -- For now we just return if Checks_On is false, however this should
179 -- be enhanced to check for an always True value in the condition
180 -- and to generate a compilation warning???
182 if not Checks_On then
187 exit when No (Checks (J));
189 if Nkind (Checks (J)) = N_Raise_Constraint_Error
190 and then Present (Condition (Checks (J)))
192 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
193 Append_To (Stmts, Checks (J));
194 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
199 (Stmts, Make_Raise_Constraint_Error (Internal_Static_Sloc));
202 end Append_Range_Checks;
204 ------------------------
205 -- Apply_Access_Check --
206 ------------------------
208 procedure Apply_Access_Check (N : Node_Id) is
209 P : constant Node_Id := Prefix (N);
212 if Inside_A_Generic then
216 if Is_Entity_Name (P) then
217 Check_Unset_Reference (P);
220 if Is_Entity_Name (P)
221 and then Access_Checks_Suppressed (Entity (P))
225 elsif Access_Checks_Suppressed (Etype (P)) then
229 Set_Do_Access_Check (N, True);
231 end Apply_Access_Check;
233 -------------------------------
234 -- Apply_Accessibility_Check --
235 -------------------------------
237 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
238 Loc : constant Source_Ptr := Sloc (N);
239 Param_Ent : constant Entity_Id := Param_Entity (N);
240 Param_Level : Node_Id;
241 Type_Level : Node_Id;
244 if Inside_A_Generic then
247 -- Only apply the run-time check if the access parameter
248 -- has an associated extra access level parameter and
249 -- when the level of the type is less deep than the level
250 -- of the access parameter.
252 elsif Present (Param_Ent)
253 and then Present (Extra_Accessibility (Param_Ent))
254 and then UI_Gt (Object_Access_Level (N),
255 Type_Access_Level (Typ))
256 and then not Accessibility_Checks_Suppressed (Param_Ent)
257 and then not Accessibility_Checks_Suppressed (Typ)
260 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
263 Make_Integer_Literal (Loc, Type_Access_Level (Typ));
265 -- Raise Program_Error if the accessibility level of the
266 -- the access parameter is deeper than the level of the
267 -- target access type.
270 Make_Raise_Program_Error (Loc,
273 Left_Opnd => Param_Level,
274 Right_Opnd => Type_Level)));
276 Analyze_And_Resolve (N);
278 end Apply_Accessibility_Check;
280 -------------------------------------
281 -- Apply_Arithmetic_Overflow_Check --
282 -------------------------------------
284 -- This routine is called only if the type is an integer type, and
285 -- a software arithmetic overflow check must be performed for op
286 -- (add, subtract, multiply). The check is performed only if
287 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
288 -- is set. In this case we expand the operation into a more complex
289 -- sequence of tests that ensures that overflow is properly caught.
291 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
292 Loc : constant Source_Ptr := Sloc (N);
293 Typ : constant Entity_Id := Etype (N);
294 Rtyp : constant Entity_Id := Root_Type (Typ);
295 Siz : constant Int := UI_To_Int (Esize (Rtyp));
296 Dsiz : constant Int := Siz * 2;
306 if not Software_Overflow_Checking
307 or else not Do_Overflow_Check (N)
308 or else not Expander_Active
313 -- Nothing to do if the range of the result is known OK
315 Determine_Range (N, OK, Lo, Hi);
317 -- Note in the test below that we assume that if a bound of the
318 -- range is equal to that of the type. That's not quite accurate
319 -- but we do this for the following reasons:
321 -- a) The way that Determine_Range works, it will typically report
322 -- the bounds of the value are the bounds of the type, because
323 -- it either can't tell anything more precise, or does not think
324 -- it is worth the effort to be more precise.
326 -- b) It is very unusual to have a situation in which this would
327 -- generate an unnecessary overflow check (an example would be
328 -- a subtype with a range 0 .. Integer'Last - 1 to which the
329 -- literal value one is added.
331 -- c) The alternative is a lot of special casing in this routine
332 -- which would partially duplicate the Determine_Range processing.
335 and then Lo > Expr_Value (Type_Low_Bound (Typ))
336 and then Hi < Expr_Value (Type_High_Bound (Typ))
341 -- None of the special case optimizations worked, so there is nothing
342 -- for it but to generate the full general case code:
348 -- Typ (Checktyp (x) op Checktyp (y));
350 -- where Typ is the type of the original expression, and Checktyp is
351 -- an integer type of sufficient length to hold the largest possible
354 -- In the case where check type exceeds the size of Long_Long_Integer,
355 -- we use a different approach, expanding to:
357 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
359 -- where xxx is Add, Multiply or Subtract as appropriate
361 -- Find check type if one exists
363 if Dsiz <= Standard_Integer_Size then
364 Ctyp := Standard_Integer;
366 elsif Dsiz <= Standard_Long_Long_Integer_Size then
367 Ctyp := Standard_Long_Long_Integer;
369 -- No check type exists, use runtime call
372 if Nkind (N) = N_Op_Add then
373 Cent := RE_Add_With_Ovflo_Check;
375 elsif Nkind (N) = N_Op_Multiply then
376 Cent := RE_Multiply_With_Ovflo_Check;
379 pragma Assert (Nkind (N) = N_Op_Subtract);
380 Cent := RE_Subtract_With_Ovflo_Check;
385 Make_Function_Call (Loc,
386 Name => New_Reference_To (RTE (Cent), Loc),
387 Parameter_Associations => New_List (
388 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
389 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
391 Analyze_And_Resolve (N, Typ);
395 -- If we fall through, we have the case where we do the arithmetic in
396 -- the next higher type and get the check by conversion. In these cases
397 -- Ctyp is set to the type to be used as the check type.
399 Opnod := Relocate_Node (N);
401 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
404 Set_Etype (Opnd, Ctyp);
405 Set_Analyzed (Opnd, True);
406 Set_Left_Opnd (Opnod, Opnd);
408 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
411 Set_Etype (Opnd, Ctyp);
412 Set_Analyzed (Opnd, True);
413 Set_Right_Opnd (Opnod, Opnd);
415 -- The type of the operation changes to the base type of the check
416 -- type, and we reset the overflow check indication, since clearly
417 -- no overflow is possible now that we are using a double length
418 -- type. We also set the Analyzed flag to avoid a recursive attempt
419 -- to expand the node.
421 Set_Etype (Opnod, Base_Type (Ctyp));
422 Set_Do_Overflow_Check (Opnod, False);
423 Set_Analyzed (Opnod, True);
425 -- Now build the outer conversion
427 Opnd := OK_Convert_To (Typ, Opnod);
430 Set_Etype (Opnd, Typ);
431 Set_Analyzed (Opnd, True);
432 Set_Do_Overflow_Check (Opnd, True);
435 end Apply_Arithmetic_Overflow_Check;
437 ----------------------------
438 -- Apply_Array_Size_Check --
439 ----------------------------
441 -- Note: Really of course this entre check should be in the backend,
442 -- and perhaps this is not quite the right value, but it is good
443 -- enough to catch the normal cases (and the relevant ACVC tests!)
445 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
446 Loc : constant Source_Ptr := Sloc (N);
447 Ctyp : constant Entity_Id := Component_Type (Typ);
448 Ent : constant Entity_Id := Defining_Identifier (N);
460 Static : Boolean := True;
461 -- Set false if any index subtye bound is non-static
463 Umark : constant Uintp.Save_Mark := Uintp.Mark;
464 -- We can throw away all the Uint computations here, since they are
465 -- done only to generate boolean test results.
468 -- Size to check against
470 function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
471 -- Determines if Decl is an address clause or Import/Interface pragma
472 -- that references the defining identifier of the current declaration.
474 --------------------------
475 -- Is_Address_Or_Import --
476 --------------------------
478 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
480 if Nkind (Decl) = N_At_Clause then
481 return Chars (Identifier (Decl)) = Chars (Ent);
483 elsif Nkind (Decl) = N_Attribute_Definition_Clause then
485 Chars (Decl) = Name_Address
487 Nkind (Name (Decl)) = N_Identifier
489 Chars (Name (Decl)) = Chars (Ent);
491 elsif Nkind (Decl) = N_Pragma then
492 if (Chars (Decl) = Name_Import
494 Chars (Decl) = Name_Interface)
495 and then Present (Pragma_Argument_Associations (Decl))
498 F : constant Node_Id :=
499 First (Pragma_Argument_Associations (Decl));
507 Nkind (Expression (Next (F))) = N_Identifier
509 Chars (Expression (Next (F))) = Chars (Ent);
519 end Is_Address_Or_Import;
521 -- Start of processing for Apply_Array_Size_Check
524 if not Expander_Active
525 or else Storage_Checks_Suppressed (Typ)
530 -- It is pointless to insert this check inside an _init_proc, because
531 -- that's too late, we have already built the object to be the right
532 -- size, and if it's too large, too bad!
534 if Inside_Init_Proc then
538 -- Look head for pragma interface/import or address clause applying
539 -- to this entity. If found, we suppress the check entirely. For now
540 -- we only look ahead 20 declarations to stop this becoming too slow
541 -- Note that eventually this whole routine gets moved to gigi.
544 for Ctr in 1 .. 20 loop
548 if Is_Address_Or_Import (Decl) then
553 -- First step is to calculate the maximum number of elements. For this
554 -- calculation, we use the actual size of the subtype if it is static,
555 -- and if a bound of a subtype is non-static, we go to the bound of the
559 Indx := First_Index (Typ);
560 while Present (Indx) loop
561 Xtyp := Etype (Indx);
562 Lo := Type_Low_Bound (Xtyp);
563 Hi := Type_High_Bound (Xtyp);
565 -- If any bound raises constraint error, we will never get this
566 -- far, so there is no need to generate any kind of check.
568 if Raises_Constraint_Error (Lo)
570 Raises_Constraint_Error (Hi)
572 Uintp.Release (Umark);
576 -- Otherwise get bounds values
578 if Is_Static_Expression (Lo) then
579 Lob := Expr_Value (Lo);
581 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
585 if Is_Static_Expression (Hi) then
586 Hib := Expr_Value (Hi);
588 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
592 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
596 -- Compute the limit against which we want to check. For subprograms,
597 -- where the array will go on the stack, we use 8*2**24, which (in
598 -- bits) is the size of a 16 megabyte array.
600 if Is_Subprogram (Scope (Ent)) then
601 Check_Siz := Uint_2 ** 27;
603 Check_Siz := Uint_2 ** 31;
606 -- If we have all static bounds and Siz is too large, then we know we
607 -- know we have a storage error right now, so generate message
609 if Static and then Siz >= Check_Siz then
611 Make_Raise_Storage_Error (Loc));
612 Warn_On_Instance := True;
613 Error_Msg_N ("?Storage_Error will be raised at run-time", N);
614 Warn_On_Instance := False;
615 Uintp.Release (Umark);
619 -- Case of component size known at compile time. If the array
620 -- size is definitely in range, then we do not need a check.
622 if Known_Esize (Ctyp)
623 and then Siz * Esize (Ctyp) < Check_Siz
625 Uintp.Release (Umark);
629 -- Here if a dynamic check is required
631 -- What we do is to build an expression for the size of the array,
632 -- which is computed as the 'Size of the array component, times
633 -- the size of each dimension.
635 Uintp.Release (Umark);
638 Make_Attribute_Reference (Loc,
639 Prefix => New_Occurrence_Of (Ctyp, Loc),
640 Attribute_Name => Name_Size);
642 Indx := First_Index (Typ);
644 for J in 1 .. Number_Dimensions (Typ) loop
646 if Sloc (Etype (Indx)) = Sloc (N) then
647 Ensure_Defined (Etype (Indx), N);
651 Make_Op_Multiply (Loc,
654 Make_Attribute_Reference (Loc,
655 Prefix => New_Occurrence_Of (Typ, Loc),
656 Attribute_Name => Name_Length,
657 Expressions => New_List (
658 Make_Integer_Literal (Loc, J))));
663 Make_Raise_Storage_Error (Loc,
668 Make_Integer_Literal (Loc, Check_Siz)));
670 Set_Size_Check_Code (Defining_Identifier (N), Code);
671 Insert_Action (N, Code);
673 end Apply_Array_Size_Check;
675 ----------------------------
676 -- Apply_Constraint_Check --
677 ----------------------------
679 procedure Apply_Constraint_Check
682 No_Sliding : Boolean := False)
684 Desig_Typ : Entity_Id;
687 if Inside_A_Generic then
690 elsif Is_Scalar_Type (Typ) then
691 Apply_Scalar_Range_Check (N, Typ);
693 elsif Is_Array_Type (Typ) then
695 -- A useful optimization: an aggregate with only an Others clause
696 -- always has the right bounds.
698 if Nkind (N) = N_Aggregate
699 and then No (Expressions (N))
701 (First (Choices (First (Component_Associations (N)))))
707 if Is_Constrained (Typ) then
708 Apply_Length_Check (N, Typ);
711 Apply_Range_Check (N, Typ);
714 Apply_Range_Check (N, Typ);
717 elsif (Is_Record_Type (Typ)
718 or else Is_Private_Type (Typ))
719 and then Has_Discriminants (Base_Type (Typ))
720 and then Is_Constrained (Typ)
722 Apply_Discriminant_Check (N, Typ);
724 elsif Is_Access_Type (Typ) then
726 Desig_Typ := Designated_Type (Typ);
728 -- No checks necessary if expression statically null
730 if Nkind (N) = N_Null then
733 -- No sliding possible on access to arrays
735 elsif Is_Array_Type (Desig_Typ) then
736 if Is_Constrained (Desig_Typ) then
737 Apply_Length_Check (N, Typ);
740 Apply_Range_Check (N, Typ);
742 elsif Has_Discriminants (Base_Type (Desig_Typ))
743 and then Is_Constrained (Desig_Typ)
745 Apply_Discriminant_Check (N, Typ);
748 end Apply_Constraint_Check;
750 ------------------------------
751 -- Apply_Discriminant_Check --
752 ------------------------------
754 procedure Apply_Discriminant_Check
757 Lhs : Node_Id := Empty)
759 Loc : constant Source_Ptr := Sloc (N);
760 Do_Access : constant Boolean := Is_Access_Type (Typ);
761 S_Typ : Entity_Id := Etype (N);
765 function Is_Aliased_Unconstrained_Component return Boolean;
766 -- It is possible for an aliased component to have a nominal
767 -- unconstrained subtype (through instantiation). If this is a
768 -- discriminated component assigned in the expansion of an aggregate
769 -- in an initialization, the check must be suppressed. This unusual
770 -- situation requires a predicate of its own (see 7503-008).
772 ----------------------------------------
773 -- Is_Aliased_Unconstrained_Component --
774 ----------------------------------------
776 function Is_Aliased_Unconstrained_Component return Boolean is
781 if Nkind (Lhs) /= N_Selected_Component then
784 Comp := Entity (Selector_Name (Lhs));
785 Pref := Prefix (Lhs);
788 if Ekind (Comp) /= E_Component
789 or else not Is_Aliased (Comp)
794 return not Comes_From_Source (Pref)
796 and then not Is_Constrained (Etype (Comp));
797 end Is_Aliased_Unconstrained_Component;
799 -- Start of processing for Apply_Discriminant_Check
803 T_Typ := Designated_Type (Typ);
808 -- Nothing to do if discriminant checks are suppressed or else no code
809 -- is to be generated
811 if not Expander_Active
812 or else Discriminant_Checks_Suppressed (T_Typ)
817 -- No discriminant checks necessary for access when expression
818 -- is statically Null. This is not only an optimization, this is
819 -- fundamental because otherwise discriminant checks may be generated
820 -- in init procs for types containing an access to a non-frozen yet
821 -- record, causing a deadly forward reference.
823 -- Also, if the expression is of an access type whose designated
824 -- type is incomplete, then the access value must be null and
825 -- we suppress the check.
827 if Nkind (N) = N_Null then
830 elsif Is_Access_Type (S_Typ) then
831 S_Typ := Designated_Type (S_Typ);
833 if Ekind (S_Typ) = E_Incomplete_Type then
838 -- If an assignment target is present, then we need to generate
839 -- the actual subtype if the target is a parameter or aliased
840 -- object with an unconstrained nominal subtype.
843 and then (Present (Param_Entity (Lhs))
844 or else (not Is_Constrained (T_Typ)
845 and then Is_Aliased_View (Lhs)
846 and then not Is_Aliased_Unconstrained_Component))
848 T_Typ := Get_Actual_Subtype (Lhs);
851 -- Nothing to do if the type is unconstrained (this is the case
852 -- where the actual subtype in the RM sense of N is unconstrained
853 -- and no check is required).
855 if not Is_Constrained (T_Typ) then
859 -- Suppress checks if the subtypes are the same.
860 -- the check must be preserved in an assignment to a formal, because
861 -- the constraint is given by the actual.
863 if Nkind (Original_Node (N)) /= N_Allocator
865 or else not Is_Entity_Name (Lhs)
866 or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter
867 and then Ekind (Entity (Lhs)) /= E_Out_Parameter))
870 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
871 and then not Is_Aliased_View (Lhs)
876 -- We can also eliminate checks on allocators with a subtype mark
877 -- that coincides with the context type. The context type may be a
878 -- subtype without a constraint (common case, a generic actual).
880 elsif Nkind (Original_Node (N)) = N_Allocator
881 and then Is_Entity_Name (Expression (Original_Node (N)))
884 Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N)));
888 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
889 and then Is_Entity_Name (
890 Subtype_Indication (Parent (T_Typ)))
891 and then Alloc_Typ = Base_Type (T_Typ))
899 -- See if we have a case where the types are both constrained, and
900 -- all the constraints are constants. In this case, we can do the
901 -- check successfully at compile time.
903 -- we skip this check for the case where the node is a rewritten`
904 -- allocator, because it already carries the context subtype, and
905 -- extracting the discriminants from the aggregate is messy.
907 if Is_Constrained (S_Typ)
908 and then Nkind (Original_Node (N)) /= N_Allocator
918 -- S_Typ may not have discriminants in the case where it is a
919 -- private type completed by a default discriminated type. In
920 -- that case, we need to get the constraints from the
921 -- underlying_type. If the underlying type is unconstrained (i.e.
922 -- has no default discriminants) no check is needed.
924 if Has_Discriminants (S_Typ) then
925 Discr := First_Discriminant (S_Typ);
926 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
929 Discr := First_Discriminant (Underlying_Type (S_Typ));
932 (Discriminant_Constraint (Underlying_Type (S_Typ)));
939 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
941 while Present (Discr) loop
942 ItemS := Node (DconS);
943 ItemT := Node (DconT);
946 not Is_OK_Static_Expression (ItemS)
948 not Is_OK_Static_Expression (ItemT);
950 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
951 if Do_Access then -- needs run-time check.
954 Apply_Compile_Time_Constraint_Error
955 (N, "incorrect value for discriminant&?", Ent => Discr);
962 Next_Discriminant (Discr);
971 -- Here we need a discriminant check. First build the expression
972 -- for the comparisons of the discriminants:
974 -- (n.disc1 /= typ.disc1) or else
975 -- (n.disc2 /= typ.disc2) or else
977 -- (n.discn /= typ.discn)
979 Cond := Build_Discriminant_Checks (N, T_Typ);
981 -- If Lhs is set and is a parameter, then the condition is
982 -- guarded by: lhs'constrained and then (condition built above)
984 if Present (Param_Entity (Lhs)) then
988 Make_Attribute_Reference (Loc,
989 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
990 Attribute_Name => Name_Constrained),
995 Cond := Guard_Access (Cond, Loc, N);
999 Make_Raise_Constraint_Error (Loc, Condition => Cond));
1001 end Apply_Discriminant_Check;
1003 ------------------------
1004 -- Apply_Divide_Check --
1005 ------------------------
1007 procedure Apply_Divide_Check (N : Node_Id) is
1008 Loc : constant Source_Ptr := Sloc (N);
1009 Typ : constant Entity_Id := Etype (N);
1010 Left : constant Node_Id := Left_Opnd (N);
1011 Right : constant Node_Id := Right_Opnd (N);
1023 and then Software_Overflow_Checking
1025 Determine_Range (Right, ROK, Rlo, Rhi);
1027 -- See if division by zero possible, and if so generate test. This
1028 -- part of the test is not controlled by the -gnato switch.
1030 if Do_Division_Check (N) then
1032 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1034 Make_Raise_Constraint_Error (Loc,
1037 Left_Opnd => Duplicate_Subexpr (Right),
1038 Right_Opnd => Make_Integer_Literal (Loc, 0))));
1042 -- Test for extremely annoying case of xxx'First divided by -1
1044 if Do_Overflow_Check (N) then
1046 if Nkind (N) = N_Op_Divide
1047 and then Is_Signed_Integer_Type (Typ)
1049 Determine_Range (Left, LOK, Llo, Lhi);
1050 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1052 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1054 ((not LOK) or else (Llo = LLB))
1057 Make_Raise_Constraint_Error (Loc,
1062 Left_Opnd => Duplicate_Subexpr (Left),
1063 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1066 Left_Opnd => Duplicate_Subexpr (Right),
1068 Make_Integer_Literal (Loc, -1)))));
1073 end Apply_Divide_Check;
1075 ------------------------
1076 -- Apply_Length_Check --
1077 ------------------------
1079 procedure Apply_Length_Check
1081 Target_Typ : Entity_Id;
1082 Source_Typ : Entity_Id := Empty)
1085 Apply_Selected_Length_Checks
1086 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1087 end Apply_Length_Check;
1089 -----------------------
1090 -- Apply_Range_Check --
1091 -----------------------
1093 procedure Apply_Range_Check
1095 Target_Typ : Entity_Id;
1096 Source_Typ : Entity_Id := Empty)
1099 Apply_Selected_Range_Checks
1100 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1101 end Apply_Range_Check;
1103 ------------------------------
1104 -- Apply_Scalar_Range_Check --
1105 ------------------------------
1107 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1108 -- flag off if it is already set on.
1110 procedure Apply_Scalar_Range_Check
1112 Target_Typ : Entity_Id;
1113 Source_Typ : Entity_Id := Empty;
1114 Fixed_Int : Boolean := False)
1116 Parnt : constant Node_Id := Parent (Expr);
1118 Arr : Node_Id := Empty; -- initialize to prevent warning
1119 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1122 Is_Subscr_Ref : Boolean;
1123 -- Set true if Expr is a subscript
1125 Is_Unconstrained_Subscr_Ref : Boolean;
1126 -- Set true if Expr is a subscript of an unconstrained array. In this
1127 -- case we do not attempt to do an analysis of the value against the
1128 -- range of the subscript, since we don't know the actual subtype.
1131 -- Set to True if Expr should be regarded as a real value
1132 -- even though the type of Expr might be discrete.
1134 procedure Bad_Value;
1135 -- Procedure called if value is determined to be out of range
1137 procedure Bad_Value is
1139 Apply_Compile_Time_Constraint_Error
1140 (Expr, "value not in range of}?",
1146 if Inside_A_Generic then
1149 -- Return if check obviously not needed. Note that we do not check
1150 -- for the expander being inactive, since this routine does not
1151 -- insert any code, but it does generate useful warnings sometimes,
1152 -- which we would like even if we are in semantics only mode.
1154 elsif Target_Typ = Any_Type
1155 or else not Is_Scalar_Type (Target_Typ)
1156 or else Raises_Constraint_Error (Expr)
1161 -- Now, see if checks are suppressed
1164 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1166 if Is_Subscr_Ref then
1167 Arr := Prefix (Parnt);
1168 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1171 if not Do_Range_Check (Expr) then
1173 -- Subscript reference. Check for Index_Checks suppressed
1175 if Is_Subscr_Ref then
1177 -- Check array type and its base type
1179 if Index_Checks_Suppressed (Arr_Typ)
1180 or else Suppress_Index_Checks (Base_Type (Arr_Typ))
1184 -- Check array itself if it is an entity name
1186 elsif Is_Entity_Name (Arr)
1187 and then Suppress_Index_Checks (Entity (Arr))
1191 -- Check expression itself if it is an entity name
1193 elsif Is_Entity_Name (Expr)
1194 and then Suppress_Index_Checks (Entity (Expr))
1199 -- All other cases, check for Range_Checks suppressed
1202 -- Check target type and its base type
1204 if Range_Checks_Suppressed (Target_Typ)
1205 or else Suppress_Range_Checks (Base_Type (Target_Typ))
1209 -- Check expression itself if it is an entity name
1211 elsif Is_Entity_Name (Expr)
1212 and then Suppress_Range_Checks (Entity (Expr))
1216 -- If Expr is part of an assignment statement, then check
1217 -- left side of assignment if it is an entity name.
1219 elsif Nkind (Parnt) = N_Assignment_Statement
1220 and then Is_Entity_Name (Name (Parnt))
1221 and then Suppress_Range_Checks (Entity (Name (Parnt)))
1228 -- Now see if we need a check
1230 if No (Source_Typ) then
1231 S_Typ := Etype (Expr);
1233 S_Typ := Source_Typ;
1236 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1240 Is_Unconstrained_Subscr_Ref :=
1241 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1243 -- Always do a range check if the source type includes infinities
1244 -- and the target type does not include infinities.
1246 if Is_Floating_Point_Type (S_Typ)
1247 and then Has_Infinities (S_Typ)
1248 and then not Has_Infinities (Target_Typ)
1250 Enable_Range_Check (Expr);
1253 -- Return if we know expression is definitely in the range of
1254 -- the target type as determined by Determine_Range. Right now
1255 -- we only do this for discrete types, and not fixed-point or
1256 -- floating-point types.
1258 -- The additional less-precise tests below catch these cases.
1260 -- Note: skip this if we are given a source_typ, since the point
1261 -- of supplying a Source_Typ is to stop us looking at the expression.
1262 -- could sharpen this test to be out parameters only ???
1264 if Is_Discrete_Type (Target_Typ)
1265 and then Is_Discrete_Type (Etype (Expr))
1266 and then not Is_Unconstrained_Subscr_Ref
1267 and then No (Source_Typ)
1270 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1271 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1276 if Compile_Time_Known_Value (Tlo)
1277 and then Compile_Time_Known_Value (Thi)
1279 Determine_Range (Expr, OK, Lo, Hi);
1283 Lov : constant Uint := Expr_Value (Tlo);
1284 Hiv : constant Uint := Expr_Value (Thi);
1287 if Lo >= Lov and then Hi <= Hiv then
1290 elsif Lov > Hi or else Hiv < Lo then
1301 Is_Floating_Point_Type (S_Typ)
1302 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1304 -- Check if we can determine at compile time whether Expr is in the
1305 -- range of the target type. Note that if S_Typ is within the
1306 -- bounds of Target_Typ then this must be the case. This checks is
1307 -- only meaningful if this is not a conversion between integer and
1310 if not Is_Unconstrained_Subscr_Ref
1312 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1314 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1316 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1320 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1324 -- Do not set range checks if they are killed
1326 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
1327 and then Kill_Range_Check (Expr)
1331 -- ??? We only need a runtime check if the target type is constrained
1332 -- (the predefined type Float is not for instance).
1333 -- so the following should really be
1335 -- elsif Is_Constrained (Target_Typ) then
1337 -- but it isn't because certain types do not have the Is_Constrained
1338 -- flag properly set (see 1503-003).
1341 Enable_Range_Check (Expr);
1345 end Apply_Scalar_Range_Check;
1347 ----------------------------------
1348 -- Apply_Selected_Length_Checks --
1349 ----------------------------------
1351 procedure Apply_Selected_Length_Checks
1353 Target_Typ : Entity_Id;
1354 Source_Typ : Entity_Id;
1355 Do_Static : Boolean)
1358 R_Result : Check_Result;
1361 Loc : constant Source_Ptr := Sloc (Ck_Node);
1362 Checks_On : constant Boolean :=
1363 (not Index_Checks_Suppressed (Target_Typ))
1365 (not Length_Checks_Suppressed (Target_Typ));
1368 if not Expander_Active or else not Checks_On then
1373 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1375 for J in 1 .. 2 loop
1377 R_Cno := R_Result (J);
1378 exit when No (R_Cno);
1380 -- A length check may mention an Itype which is attached to a
1381 -- subsequent node. At the top level in a package this can cause
1382 -- an order-of-elaboration problem, so we make sure that the itype
1383 -- is referenced now.
1385 if Ekind (Current_Scope) = E_Package
1386 and then Is_Compilation_Unit (Current_Scope)
1388 Ensure_Defined (Target_Typ, Ck_Node);
1390 if Present (Source_Typ) then
1391 Ensure_Defined (Source_Typ, Ck_Node);
1393 elsif Is_Itype (Etype (Ck_Node)) then
1394 Ensure_Defined (Etype (Ck_Node), Ck_Node);
1398 -- If the item is a conditional raise of constraint error,
1399 -- then have a look at what check is being performed and
1402 if Nkind (R_Cno) = N_Raise_Constraint_Error
1403 and then Present (Condition (R_Cno))
1405 Cond := Condition (R_Cno);
1407 if not Has_Dynamic_Length_Check (Ck_Node) then
1408 Insert_Action (Ck_Node, R_Cno);
1410 if not Do_Static then
1411 Set_Has_Dynamic_Length_Check (Ck_Node);
1416 -- Output a warning if the condition is known to be True
1418 if Is_Entity_Name (Cond)
1419 and then Entity (Cond) = Standard_True
1421 Apply_Compile_Time_Constraint_Error
1422 (Ck_Node, "wrong length for array of}?",
1426 -- If we were only doing a static check, or if checks are not
1427 -- on, then we want to delete the check, since it is not needed.
1428 -- We do this by replacing the if statement by a null statement
1430 elsif Do_Static or else not Checks_On then
1431 Rewrite (R_Cno, Make_Null_Statement (Loc));
1435 Install_Static_Check (R_Cno, Loc);
1440 end Apply_Selected_Length_Checks;
1442 ---------------------------------
1443 -- Apply_Selected_Range_Checks --
1444 ---------------------------------
1446 procedure Apply_Selected_Range_Checks
1448 Target_Typ : Entity_Id;
1449 Source_Typ : Entity_Id;
1450 Do_Static : Boolean)
1453 R_Result : Check_Result;
1456 Loc : constant Source_Ptr := Sloc (Ck_Node);
1457 Checks_On : constant Boolean :=
1458 (not Index_Checks_Suppressed (Target_Typ))
1460 (not Range_Checks_Suppressed (Target_Typ));
1463 if not Expander_Active or else not Checks_On then
1468 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1470 for J in 1 .. 2 loop
1472 R_Cno := R_Result (J);
1473 exit when No (R_Cno);
1475 -- If the item is a conditional raise of constraint error,
1476 -- then have a look at what check is being performed and
1479 if Nkind (R_Cno) = N_Raise_Constraint_Error
1480 and then Present (Condition (R_Cno))
1482 Cond := Condition (R_Cno);
1484 if not Has_Dynamic_Range_Check (Ck_Node) then
1485 Insert_Action (Ck_Node, R_Cno);
1487 if not Do_Static then
1488 Set_Has_Dynamic_Range_Check (Ck_Node);
1492 -- Output a warning if the condition is known to be True
1494 if Is_Entity_Name (Cond)
1495 and then Entity (Cond) = Standard_True
1497 -- Since an N_Range is technically not an expression, we
1498 -- have to set one of the bounds to C_E and then just flag
1499 -- the N_Range. The warning message will point to the
1500 -- lower bound and complain about a range, which seems OK.
1502 if Nkind (Ck_Node) = N_Range then
1503 Apply_Compile_Time_Constraint_Error
1504 (Low_Bound (Ck_Node), "static range out of bounds of}?",
1508 Set_Raises_Constraint_Error (Ck_Node);
1511 Apply_Compile_Time_Constraint_Error
1512 (Ck_Node, "static value out of range of}?",
1517 -- If we were only doing a static check, or if checks are not
1518 -- on, then we want to delete the check, since it is not needed.
1519 -- We do this by replacing the if statement by a null statement
1521 elsif Do_Static or else not Checks_On then
1522 Rewrite (R_Cno, Make_Null_Statement (Loc));
1526 Install_Static_Check (R_Cno, Loc);
1531 end Apply_Selected_Range_Checks;
1533 -------------------------------
1534 -- Apply_Static_Length_Check --
1535 -------------------------------
1537 procedure Apply_Static_Length_Check
1539 Target_Typ : Entity_Id;
1540 Source_Typ : Entity_Id := Empty)
1543 Apply_Selected_Length_Checks
1544 (Expr, Target_Typ, Source_Typ, Do_Static => True);
1545 end Apply_Static_Length_Check;
1547 -------------------------------------
1548 -- Apply_Subscript_Validity_Checks --
1549 -------------------------------------
1551 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
1555 pragma Assert (Nkind (Expr) = N_Indexed_Component);
1557 -- Loop through subscripts
1559 Sub := First (Expressions (Expr));
1560 while Present (Sub) loop
1562 -- Check one subscript. Note that we do not worry about
1563 -- enumeration type with holes, since we will convert the
1564 -- value to a Pos value for the subscript, and that convert
1565 -- will do the necessary validity check.
1567 Ensure_Valid (Sub, Holes_OK => True);
1569 -- Move to next subscript
1573 end Apply_Subscript_Validity_Checks;
1575 ----------------------------------
1576 -- Apply_Type_Conversion_Checks --
1577 ----------------------------------
1579 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
1580 Target_Type : constant Entity_Id := Etype (N);
1581 Target_Base : constant Entity_Id := Base_Type (Target_Type);
1583 Expr : constant Node_Id := Expression (N);
1584 Expr_Type : constant Entity_Id := Etype (Expr);
1587 if Inside_A_Generic then
1590 -- Skip these checks if errors detected, there are some nasty
1591 -- situations of incomplete trees that blow things up.
1593 elsif Errors_Detected > 0 then
1596 -- Scalar type conversions of the form Target_Type (Expr) require
1599 -- - First there is an overflow check to insure that Expr is
1600 -- in the base type of Target_Typ (4.6 (28)),
1602 -- - After we know Expr fits into the base type, we must perform a
1603 -- range check to ensure that Expr meets the constraints of the
1606 elsif Is_Scalar_Type (Target_Type) then
1608 Conv_OK : constant Boolean := Conversion_OK (N);
1609 -- If the Conversion_OK flag on the type conversion is set
1610 -- and no floating point type is involved in the type conversion
1611 -- then fixed point values must be read as integral values.
1616 if not Overflow_Checks_Suppressed (Target_Base)
1617 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
1619 Set_Do_Overflow_Check (N);
1622 if not Range_Checks_Suppressed (Target_Type)
1623 and then not Range_Checks_Suppressed (Expr_Type)
1625 Apply_Scalar_Range_Check
1626 (Expr, Target_Type, Fixed_Int => Conv_OK);
1630 elsif Comes_From_Source (N)
1631 and then Is_Record_Type (Target_Type)
1632 and then Is_Derived_Type (Target_Type)
1633 and then not Is_Tagged_Type (Target_Type)
1634 and then not Is_Constrained (Target_Type)
1635 and then Present (Girder_Constraint (Target_Type))
1637 -- A unconstrained derived type may have inherited discriminants.
1638 -- Build an actual discriminant constraint list using the girder
1639 -- constraint, to verify that the expression of the parent type
1640 -- satisfies the constraints imposed by the (unconstrained!)
1641 -- derived type. This applies to value conversions, not to view
1642 -- conversions of tagged types.
1645 Loc : constant Source_Ptr := Sloc (N);
1647 Constraint : Elmt_Id;
1648 Discr_Value : Node_Id;
1650 New_Constraints : Elist_Id := New_Elmt_List;
1651 Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type);
1654 Constraint := First_Elmt (Girder_Constraint (Target_Type));
1656 while Present (Constraint) loop
1657 Discr_Value := Node (Constraint);
1659 if Is_Entity_Name (Discr_Value)
1660 and then Ekind (Entity (Discr_Value)) = E_Discriminant
1662 Discr := Corresponding_Discriminant (Entity (Discr_Value));
1665 and then Scope (Discr) = Base_Type (Expr_Type)
1667 -- Parent is constrained by new discriminant. Obtain
1668 -- Value of original discriminant in expression. If
1669 -- the new discriminant has been used to constrain more
1670 -- than one of the girder ones, this will provide the
1671 -- required consistency check.
1674 Make_Selected_Component (Loc,
1676 Duplicate_Subexpr (Expr, Name_Req => True),
1678 Make_Identifier (Loc, Chars (Discr))),
1682 -- Discriminant of more remote ancestor ???
1687 -- Derived type definition has an explicit value for
1688 -- this girder discriminant.
1692 (Duplicate_Subexpr (Discr_Value), New_Constraints);
1695 Next_Elmt (Constraint);
1698 -- Use the unconstrained expression type to retrieve the
1699 -- discriminants of the parent, and apply momentarily the
1700 -- discriminant constraint synthesized above.
1702 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
1703 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
1704 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
1707 Make_Raise_Constraint_Error (Loc, Condition => Cond));
1710 -- should there be other checks here for array types ???
1716 end Apply_Type_Conversion_Checks;
1718 ----------------------------------------------
1719 -- Apply_Universal_Integer_Attribute_Checks --
1720 ----------------------------------------------
1722 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
1723 Loc : constant Source_Ptr := Sloc (N);
1724 Typ : constant Entity_Id := Etype (N);
1727 if Inside_A_Generic then
1730 -- Nothing to do if checks are suppressed
1732 elsif Range_Checks_Suppressed (Typ)
1733 and then Overflow_Checks_Suppressed (Typ)
1737 -- Nothing to do if the attribute does not come from source. The
1738 -- internal attributes we generate of this type do not need checks,
1739 -- and furthermore the attempt to check them causes some circular
1740 -- elaboration orders when dealing with packed types.
1742 elsif not Comes_From_Source (N) then
1745 -- Otherwise, replace the attribute node with a type conversion
1746 -- node whose expression is the attribute, retyped to universal
1747 -- integer, and whose subtype mark is the target type. The call
1748 -- to analyze this conversion will set range and overflow checks
1749 -- as required for proper detection of an out of range value.
1752 Set_Etype (N, Universal_Integer);
1753 Set_Analyzed (N, True);
1756 Make_Type_Conversion (Loc,
1757 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1758 Expression => Relocate_Node (N)));
1760 Analyze_And_Resolve (N, Typ);
1764 end Apply_Universal_Integer_Attribute_Checks;
1766 -------------------------------
1767 -- Build_Discriminant_Checks --
1768 -------------------------------
1770 function Build_Discriminant_Checks
1775 Loc : constant Source_Ptr := Sloc (N);
1778 Disc_Ent : Entity_Id;
1783 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
1785 -- For a fully private type, use the discriminants of the parent
1788 if Is_Private_Type (T_Typ)
1789 and then No (Full_View (T_Typ))
1791 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
1793 Disc_Ent := First_Discriminant (T_Typ);
1796 while Present (Disc) loop
1798 Dval := Node (Disc);
1800 if Nkind (Dval) = N_Identifier
1801 and then Ekind (Entity (Dval)) = E_Discriminant
1803 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
1805 Dval := Duplicate_Subexpr (Dval);
1808 Evolve_Or_Else (Cond,
1811 Make_Selected_Component (Loc,
1813 Duplicate_Subexpr (N, Name_Req => True),
1815 Make_Identifier (Loc, Chars (Disc_Ent))),
1816 Right_Opnd => Dval));
1819 Next_Discriminant (Disc_Ent);
1823 end Build_Discriminant_Checks;
1825 -----------------------------------
1826 -- Check_Valid_Lvalue_Subscripts --
1827 -----------------------------------
1829 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
1831 -- Skip this if range checks are suppressed
1833 if Range_Checks_Suppressed (Etype (Expr)) then
1836 -- Only do this check for expressions that come from source. We
1837 -- assume that expander generated assignments explicitly include
1838 -- any necessary checks. Note that this is not just an optimization,
1839 -- it avoids infinite recursions!
1841 elsif not Comes_From_Source (Expr) then
1844 -- For a selected component, check the prefix
1846 elsif Nkind (Expr) = N_Selected_Component then
1847 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1850 -- Case of indexed component
1852 elsif Nkind (Expr) = N_Indexed_Component then
1853 Apply_Subscript_Validity_Checks (Expr);
1855 -- Prefix may itself be or contain an indexed component, and
1856 -- these subscripts need checking as well
1858 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1860 end Check_Valid_Lvalue_Subscripts;
1862 ---------------------
1863 -- Determine_Range --
1864 ---------------------
1866 Cache_Size : constant := 2 ** 10;
1867 type Cache_Index is range 0 .. Cache_Size - 1;
1868 -- Determine size of below cache (power of 2 is more efficient!)
1870 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
1871 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
1872 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
1873 -- The above arrays are used to implement a small direct cache
1874 -- for Determine_Range calls. Because of the way Determine_Range
1875 -- recursively traces subexpressions, and because overflow checking
1876 -- calls the routine on the way up the tree, a quadratic behavior
1877 -- can otherwise be encountered in large expressions. The cache
1878 -- entry for node N is stored in the (N mod Cache_Size) entry, and
1879 -- can be validated by checking the actual node value stored there.
1881 procedure Determine_Range
1887 Typ : constant Entity_Id := Etype (N);
1898 Cindex : Cache_Index;
1900 function OK_Operands return Boolean;
1901 -- Used for binary operators. Determines the ranges of the left and
1902 -- right operands, and if they are both OK, returns True, and puts
1903 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
1909 function OK_Operands return Boolean is
1911 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
1917 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
1921 -- Start of processing for Determine_Range
1924 -- Prevent junk warnings by initializing range variables
1931 -- If the type is not discrete, or is undefined, then we can't
1932 -- do anything about determining the range.
1934 if No (Typ) or else not Is_Discrete_Type (Typ)
1935 or else Error_Posted (N)
1941 -- For all other cases, we can determine the range
1945 -- If value is compile time known, then the possible range is the
1946 -- one value that we know this expression definitely has!
1948 if Compile_Time_Known_Value (N) then
1949 Lo := Expr_Value (N);
1954 -- Return if already in the cache
1956 Cindex := Cache_Index (N mod Cache_Size);
1958 if Determine_Range_Cache_N (Cindex) = N then
1959 Lo := Determine_Range_Cache_Lo (Cindex);
1960 Hi := Determine_Range_Cache_Hi (Cindex);
1964 -- Otherwise, start by finding the bounds of the type of the
1965 -- expression, the value cannot be outside this range (if it
1966 -- is, then we have an overflow situation, which is a separate
1967 -- check, we are talking here only about the expression value).
1969 -- We use the actual bound unless it is dynamic, in which case
1970 -- use the corresponding base type bound if possible. If we can't
1973 Bound := Type_Low_Bound (Typ);
1975 if Compile_Time_Known_Value (Bound) then
1976 Lo := Expr_Value (Bound);
1978 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
1979 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1986 Bound := Type_High_Bound (Typ);
1988 if Compile_Time_Known_Value (Bound) then
1989 Hi := Expr_Value (Bound);
1991 elsif Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
1992 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2000 -- We may be able to refine this value in certain situations. If
2001 -- refinement is possible, then Lor and Hir are set to possibly
2002 -- tighter bounds, and OK1 is set to True.
2006 -- For unary plus, result is limited by range of operand
2009 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2011 -- For unary minus, determine range of operand, and negate it
2014 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2021 -- For binary addition, get range of each operand and do the
2022 -- addition to get the result range.
2026 Lor := Lo_Left + Lo_Right;
2027 Hir := Hi_Left + Hi_Right;
2030 -- Division is tricky. The only case we consider is where the
2031 -- right operand is a positive constant, and in this case we
2032 -- simply divide the bounds of the left operand
2036 if Lo_Right = Hi_Right
2037 and then Lo_Right > 0
2039 Lor := Lo_Left / Lo_Right;
2040 Hir := Hi_Left / Lo_Right;
2047 -- For binary subtraction, get range of each operand and do
2048 -- the worst case subtraction to get the result range.
2050 when N_Op_Subtract =>
2052 Lor := Lo_Left - Hi_Right;
2053 Hir := Hi_Left - Lo_Right;
2056 -- For MOD, if right operand is a positive constant, then
2057 -- result must be in the allowable range of mod results.
2061 if Lo_Right = Hi_Right then
2062 if Lo_Right > 0 then
2064 Hir := Lo_Right - 1;
2066 elsif Lo_Right < 0 then
2067 Lor := Lo_Right + 1;
2076 -- For REM, if right operand is a positive constant, then
2077 -- result must be in the allowable range of mod results.
2081 if Lo_Right = Hi_Right then
2083 Dval : constant Uint := (abs Lo_Right) - 1;
2086 -- The sign of the result depends on the sign of the
2087 -- dividend (but not on the sign of the divisor, hence
2088 -- the abs operation above).
2108 -- Attribute reference cases
2110 when N_Attribute_Reference =>
2111 case Attribute_Name (N) is
2113 -- For Pos/Val attributes, we can refine the range using the
2114 -- possible range of values of the attribute expression
2116 when Name_Pos | Name_Val =>
2117 Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
2119 -- For Length attribute, use the bounds of the corresponding
2120 -- index type to refine the range.
2124 Atyp : Entity_Id := Etype (Prefix (N));
2132 if Is_Access_Type (Atyp) then
2133 Atyp := Designated_Type (Atyp);
2136 -- For string literal, we know exact value
2138 if Ekind (Atyp) = E_String_Literal_Subtype then
2140 Lo := String_Literal_Length (Atyp);
2141 Hi := String_Literal_Length (Atyp);
2145 -- Otherwise check for expression given
2147 if No (Expressions (N)) then
2151 UI_To_Int (Expr_Value (First (Expressions (N))));
2154 Indx := First_Index (Atyp);
2155 for J in 2 .. Inum loop
2156 Indx := Next_Index (Indx);
2160 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
2164 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
2168 -- The maximum value for Length is the biggest
2169 -- possible gap between the values of the bounds.
2170 -- But of course, this value cannot be negative.
2172 Hir := UI_Max (Uint_0, UU - LL);
2174 -- For constrained arrays, the minimum value for
2175 -- Length is taken from the actual value of the
2176 -- bounds, since the index will be exactly of
2179 if Is_Constrained (Atyp) then
2180 Lor := UI_Max (Uint_0, UL - LU);
2182 -- For an unconstrained array, the minimum value
2183 -- for length is always zero.
2192 -- No special handling for other attributes
2193 -- Probably more opportunities exist here ???
2200 -- For type conversion from one discrete type to another, we
2201 -- can refine the range using the converted value.
2203 when N_Type_Conversion =>
2204 Determine_Range (Expression (N), OK1, Lor, Hir);
2206 -- Nothing special to do for all other expression kinds
2214 -- At this stage, if OK1 is true, then we know that the actual
2215 -- result of the computed expression is in the range Lor .. Hir.
2216 -- We can use this to restrict the possible range of results.
2220 -- If the refined value of the low bound is greater than the
2221 -- type high bound, then reset it to the more restrictive
2222 -- value. However, we do NOT do this for the case of a modular
2223 -- type where the possible upper bound on the value is above the
2224 -- base type high bound, because that means the result could wrap.
2227 and then not (Is_Modular_Integer_Type (Typ)
2228 and then Hir > Hbound)
2233 -- Similarly, if the refined value of the high bound is less
2234 -- than the value so far, then reset it to the more restrictive
2235 -- value. Again, we do not do this if the refined low bound is
2236 -- negative for a modular type, since this would wrap.
2239 and then not (Is_Modular_Integer_Type (Typ)
2240 and then Lor < Uint_0)
2246 -- Set cache entry for future call and we are all done
2248 Determine_Range_Cache_N (Cindex) := N;
2249 Determine_Range_Cache_Lo (Cindex) := Lo;
2250 Determine_Range_Cache_Hi (Cindex) := Hi;
2253 -- If any exception occurs, it means that we have some bug in the compiler
2254 -- possibly triggered by a previous error, or by some unforseen peculiar
2255 -- occurrence. However, this is only an optimization attempt, so there is
2256 -- really no point in crashing the compiler. Instead we just decide, too
2257 -- bad, we can't figure out a range in this case after all.
2262 -- Debug flag K disables this behavior (useful for debugging)
2264 if Debug_Flag_K then
2273 end Determine_Range;
2275 ------------------------------------
2276 -- Discriminant_Checks_Suppressed --
2277 ------------------------------------
2279 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
2281 return Scope_Suppress.Discriminant_Checks
2282 or else (Present (E) and then Suppress_Discriminant_Checks (E));
2283 end Discriminant_Checks_Suppressed;
2285 --------------------------------
2286 -- Division_Checks_Suppressed --
2287 --------------------------------
2289 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
2291 return Scope_Suppress.Division_Checks
2292 or else (Present (E) and then Suppress_Division_Checks (E));
2293 end Division_Checks_Suppressed;
2295 -----------------------------------
2296 -- Elaboration_Checks_Suppressed --
2297 -----------------------------------
2299 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
2301 return Scope_Suppress.Elaboration_Checks
2302 or else (Present (E) and then Suppress_Elaboration_Checks (E));
2303 end Elaboration_Checks_Suppressed;
2305 ------------------------
2306 -- Enable_Range_Check --
2307 ------------------------
2309 procedure Enable_Range_Check (N : Node_Id) is
2311 if Nkind (N) = N_Unchecked_Type_Conversion
2312 and then Kill_Range_Check (N)
2316 Set_Do_Range_Check (N, True);
2318 end Enable_Range_Check;
2324 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
2325 Typ : constant Entity_Id := Etype (Expr);
2328 -- Ignore call if we are not doing any validity checking
2330 if not Validity_Checks_On then
2333 -- No check required if expression is from the expander, we assume
2334 -- the expander will generate whatever checks are needed. Note that
2335 -- this is not just an optimization, it avoids infinite recursions!
2337 -- Unchecked conversions must be checked, unless they are initialized
2338 -- scalar values, as in a component assignment in an init_proc.
2340 elsif not Comes_From_Source (Expr)
2341 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
2342 or else Kill_Range_Check (Expr))
2346 -- No check required if expression is known to have valid value
2348 elsif Expr_Known_Valid (Expr) then
2351 -- No check required if checks off
2353 elsif Range_Checks_Suppressed (Typ) then
2356 -- Ignore case of enumeration with holes where the flag is set not
2357 -- to worry about holes, since no special validity check is needed
2359 elsif Is_Enumeration_Type (Typ)
2360 and then Has_Non_Standard_Rep (Typ)
2365 -- No check required on the left-hand side of an assignment.
2367 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
2368 and then Expr = Name (Parent (Expr))
2372 -- An annoying special case. If this is an out parameter of a scalar
2373 -- type, then the value is not going to be accessed, therefore it is
2374 -- inappropriate to do any validity check at the call site.
2377 -- Only need to worry about scalar types
2379 if Is_Scalar_Type (Typ) then
2389 -- Find actual argument (which may be a parameter association)
2390 -- and the parent of the actual argument (the call statement)
2395 if Nkind (P) = N_Parameter_Association then
2400 -- Only need to worry if we are argument of a procedure
2401 -- call since functions don't have out parameters.
2403 if Nkind (P) = N_Procedure_Call_Statement then
2404 L := Parameter_Associations (P);
2405 E := Entity (Name (P));
2407 -- Only need to worry if there are indeed actuals, and
2408 -- if this could be a procedure call, otherwise we cannot
2409 -- get a match (either we are not an argument, or the
2410 -- mode of the formal is not OUT). This test also filters
2411 -- out the generic case.
2413 if Is_Non_Empty_List (L)
2414 and then Is_Subprogram (E)
2416 -- This is the loop through parameters, looking to
2417 -- see if there is an OUT parameter for which we are
2420 F := First_Formal (E);
2423 while Present (F) loop
2424 if Ekind (F) = E_Out_Parameter and then A = N then
2437 -- If we fall through, a validity check is required. Note that it would
2438 -- not be good to set Do_Range_Check, even in contexts where this is
2439 -- permissible, since this flag causes checking against the target type,
2440 -- not the source type in contexts such as assignments
2442 Insert_Valid_Check (Expr);
2445 ----------------------
2446 -- Expr_Known_Valid --
2447 ----------------------
2449 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
2450 Typ : constant Entity_Id := Etype (Expr);
2453 -- Non-scalar types are always consdered valid, since they never
2454 -- give rise to the issues of erroneous or bounded error behavior
2455 -- that are the concern. In formal reference manual terms the
2456 -- notion of validity only applies to scalar types.
2458 if not Is_Scalar_Type (Typ) then
2461 -- If no validity checking, then everything is considered valid
2463 elsif not Validity_Checks_On then
2466 -- Floating-point types are considered valid unless floating-point
2467 -- validity checks have been specifically turned on.
2469 elsif Is_Floating_Point_Type (Typ)
2470 and then not Validity_Check_Floating_Point
2474 -- If the expression is the value of an object that is known to
2475 -- be valid, then clearly the expression value itself is valid.
2477 elsif Is_Entity_Name (Expr)
2478 and then Is_Known_Valid (Entity (Expr))
2482 -- If the type is one for which all values are known valid, then
2483 -- we are sure that the value is valid except in the slightly odd
2484 -- case where the expression is a reference to a variable whose size
2485 -- has been explicitly set to a value greater than the object size.
2487 elsif Is_Known_Valid (Typ) then
2488 if Is_Entity_Name (Expr)
2489 and then Ekind (Entity (Expr)) = E_Variable
2490 and then Esize (Entity (Expr)) > Esize (Typ)
2497 -- Integer and character literals always have valid values, where
2498 -- appropriate these will be range checked in any case.
2500 elsif Nkind (Expr) = N_Integer_Literal
2502 Nkind (Expr) = N_Character_Literal
2506 -- If we have a type conversion or a qualification of a known valid
2507 -- value, then the result will always be valid.
2509 elsif Nkind (Expr) = N_Type_Conversion
2511 Nkind (Expr) = N_Qualified_Expression
2513 return Expr_Known_Valid (Expression (Expr));
2515 -- The result of any function call or operator is always considered
2516 -- valid, since we assume the necessary checks are done by the call.
2518 elsif Nkind (Expr) in N_Binary_Op
2520 Nkind (Expr) in N_Unary_Op
2522 Nkind (Expr) = N_Function_Call
2526 -- For all other cases, we do not know the expression is valid
2531 end Expr_Known_Valid;
2533 ---------------------
2534 -- Get_Discriminal --
2535 ---------------------
2537 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
2538 Loc : constant Source_Ptr := Sloc (E);
2543 -- The entity E is the type of a private component of the protected
2544 -- type, or the type of a renaming of that component within a protected
2545 -- operation of that type.
2549 if Ekind (Sc) /= E_Protected_Type then
2552 if Ekind (Sc) /= E_Protected_Type then
2557 D := First_Discriminant (Sc);
2560 and then Chars (D) /= Chars (Bound)
2562 Next_Discriminant (D);
2565 return New_Occurrence_Of (Discriminal (D), Loc);
2566 end Get_Discriminal;
2572 function Guard_Access
2579 if Nkind (Cond) = N_Or_Else then
2580 Set_Paren_Count (Cond, 1);
2583 if Nkind (Ck_Node) = N_Allocator then
2590 Left_Opnd => Duplicate_Subexpr (Ck_Node),
2591 Right_Opnd => Make_Null (Loc)),
2592 Right_Opnd => Cond);
2596 -----------------------------
2597 -- Index_Checks_Suppressed --
2598 -----------------------------
2600 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
2602 return Scope_Suppress.Index_Checks
2603 or else (Present (E) and then Suppress_Index_Checks (E));
2604 end Index_Checks_Suppressed;
2610 procedure Initialize is
2612 for J in Determine_Range_Cache_N'Range loop
2613 Determine_Range_Cache_N (J) := Empty;
2617 -------------------------
2618 -- Insert_Range_Checks --
2619 -------------------------
2621 procedure Insert_Range_Checks
2622 (Checks : Check_Result;
2624 Suppress_Typ : Entity_Id;
2625 Static_Sloc : Source_Ptr := No_Location;
2626 Flag_Node : Node_Id := Empty;
2627 Do_Before : Boolean := False)
2629 Internal_Flag_Node : Node_Id := Flag_Node;
2630 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
2632 Check_Node : Node_Id;
2633 Checks_On : constant Boolean :=
2634 (not Index_Checks_Suppressed (Suppress_Typ))
2636 (not Range_Checks_Suppressed (Suppress_Typ));
2639 -- For now we just return if Checks_On is false, however this should
2640 -- be enhanced to check for an always True value in the condition
2641 -- and to generate a compilation warning???
2643 if not Expander_Active or else not Checks_On then
2647 if Static_Sloc = No_Location then
2648 Internal_Static_Sloc := Sloc (Node);
2651 if No (Flag_Node) then
2652 Internal_Flag_Node := Node;
2655 for J in 1 .. 2 loop
2656 exit when No (Checks (J));
2658 if Nkind (Checks (J)) = N_Raise_Constraint_Error
2659 and then Present (Condition (Checks (J)))
2661 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
2662 Check_Node := Checks (J);
2663 Mark_Rewrite_Insertion (Check_Node);
2666 Insert_Before_And_Analyze (Node, Check_Node);
2668 Insert_After_And_Analyze (Node, Check_Node);
2671 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
2676 Make_Raise_Constraint_Error (Internal_Static_Sloc);
2677 Mark_Rewrite_Insertion (Check_Node);
2680 Insert_Before_And_Analyze (Node, Check_Node);
2682 Insert_After_And_Analyze (Node, Check_Node);
2686 end Insert_Range_Checks;
2688 ------------------------
2689 -- Insert_Valid_Check --
2690 ------------------------
2692 procedure Insert_Valid_Check (Expr : Node_Id) is
2693 Loc : constant Source_Ptr := Sloc (Expr);
2696 -- Do not insert if checks off, or if not checking validity
2698 if Range_Checks_Suppressed (Etype (Expr))
2699 or else (not Validity_Checks_On)
2703 -- Otherwise insert the validity check. Note that we do this with
2704 -- validity checks turned off, to avoid recursion, we do not want
2705 -- validity checks on the validity checking code itself!
2708 Validity_Checks_On := False;
2711 Make_Raise_Constraint_Error (Loc,
2715 Make_Attribute_Reference (Loc,
2717 Duplicate_Subexpr (Expr, Name_Req => True),
2718 Attribute_Name => Name_Valid))),
2719 Suppress => All_Checks);
2720 Validity_Checks_On := True;
2722 end Insert_Valid_Check;
2724 --------------------------
2725 -- Install_Static_Check --
2726 --------------------------
2728 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
2729 Stat : constant Boolean := Is_Static_Expression (R_Cno);
2730 Typ : constant Entity_Id := Etype (R_Cno);
2733 Rewrite (R_Cno, Make_Raise_Constraint_Error (Loc));
2734 Set_Analyzed (R_Cno);
2735 Set_Etype (R_Cno, Typ);
2736 Set_Raises_Constraint_Error (R_Cno);
2737 Set_Is_Static_Expression (R_Cno, Stat);
2738 end Install_Static_Check;
2740 ------------------------------
2741 -- Length_Checks_Suppressed --
2742 ------------------------------
2744 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
2746 return Scope_Suppress.Length_Checks
2747 or else (Present (E) and then Suppress_Length_Checks (E));
2748 end Length_Checks_Suppressed;
2750 --------------------------------
2751 -- Overflow_Checks_Suppressed --
2752 --------------------------------
2754 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
2756 return Scope_Suppress.Overflow_Checks
2757 or else (Present (E) and then Suppress_Overflow_Checks (E));
2758 end Overflow_Checks_Suppressed;
2764 function Range_Check
2766 Target_Typ : Entity_Id;
2767 Source_Typ : Entity_Id := Empty;
2768 Warn_Node : Node_Id := Empty)
2772 return Selected_Range_Checks
2773 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
2776 -----------------------------
2777 -- Range_Checks_Suppressed --
2778 -----------------------------
2780 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
2782 -- Note: for now we always suppress range checks on Vax float types,
2783 -- since Gigi does not know how to generate these checks.
2785 return Scope_Suppress.Range_Checks
2786 or else (Present (E) and then Suppress_Range_Checks (E))
2787 or else Vax_Float (E);
2788 end Range_Checks_Suppressed;
2790 ----------------------------
2791 -- Selected_Length_Checks --
2792 ----------------------------
2794 function Selected_Length_Checks
2796 Target_Typ : Entity_Id;
2797 Source_Typ : Entity_Id;
2798 Warn_Node : Node_Id)
2801 Loc : constant Source_Ptr := Sloc (Ck_Node);
2804 Expr_Actual : Node_Id;
2806 Cond : Node_Id := Empty;
2807 Do_Access : Boolean := False;
2808 Wnode : Node_Id := Warn_Node;
2809 Ret_Result : Check_Result := (Empty, Empty);
2810 Num_Checks : Natural := 0;
2812 procedure Add_Check (N : Node_Id);
2813 -- Adds the action given to Ret_Result if N is non-Empty
2815 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
2816 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
2818 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
2819 -- True for equal literals and for nodes that denote the same constant
2820 -- entity, even if its value is not a static constant. This includes the
2821 -- case of a discriminal reference within an init_proc. Removes some
2822 -- obviously superfluous checks.
2824 function Length_E_Cond
2825 (Exptyp : Entity_Id;
2829 -- Returns expression to compute:
2830 -- Typ'Length /= Exptyp'Length
2832 function Length_N_Cond
2837 -- Returns expression to compute:
2838 -- Typ'Length /= Expr'Length
2844 procedure Add_Check (N : Node_Id) is
2848 -- For now, ignore attempt to place more than 2 checks ???
2850 if Num_Checks = 2 then
2854 pragma Assert (Num_Checks <= 1);
2855 Num_Checks := Num_Checks + 1;
2856 Ret_Result (Num_Checks) := N;
2864 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
2866 E1 : Entity_Id := E;
2867 Pt : Entity_Id := Scope (Scope (E));
2870 if Ekind (Scope (E)) = E_Record_Type
2871 and then Has_Discriminants (Scope (E))
2873 N := Build_Discriminal_Subtype_Of_Component (E);
2876 Insert_Action (Ck_Node, N);
2877 E1 := Defining_Identifier (N);
2881 if Ekind (E1) = E_String_Literal_Subtype then
2883 Make_Integer_Literal (Loc,
2884 Intval => String_Literal_Length (E1));
2886 elsif Ekind (Pt) = E_Protected_Type
2887 and then Has_Discriminants (Pt)
2888 and then Has_Completion (Pt)
2889 and then not Inside_Init_Proc
2892 -- If the type whose length is needed is a private component
2893 -- constrained by a discriminant, we must expand the 'Length
2894 -- attribute into an explicit computation, using the discriminal
2895 -- of the current protected operation. This is because the actual
2896 -- type of the prival is constructed after the protected opera-
2897 -- tion has been fully expanded.
2900 Indx_Type : Node_Id;
2903 Do_Expand : Boolean := False;
2906 Indx_Type := First_Index (E);
2908 for J in 1 .. Indx - 1 loop
2909 Next_Index (Indx_Type);
2912 Get_Index_Bounds (Indx_Type, Lo, Hi);
2914 if Nkind (Lo) = N_Identifier
2915 and then Ekind (Entity (Lo)) = E_In_Parameter
2917 Lo := Get_Discriminal (E, Lo);
2921 if Nkind (Hi) = N_Identifier
2922 and then Ekind (Entity (Hi)) = E_In_Parameter
2924 Hi := Get_Discriminal (E, Hi);
2929 if not Is_Entity_Name (Lo) then
2930 Lo := Duplicate_Subexpr (Lo);
2933 if not Is_Entity_Name (Hi) then
2934 Lo := Duplicate_Subexpr (Hi);
2940 Make_Op_Subtract (Loc,
2944 Right_Opnd => Make_Integer_Literal (Loc, 1));
2949 Make_Attribute_Reference (Loc,
2950 Attribute_Name => Name_Length,
2952 New_Occurrence_Of (E1, Loc));
2955 Set_Expressions (N, New_List (
2956 Make_Integer_Literal (Loc, Indx)));
2965 Make_Attribute_Reference (Loc,
2966 Attribute_Name => Name_Length,
2968 New_Occurrence_Of (E1, Loc));
2971 Set_Expressions (N, New_List (
2972 Make_Integer_Literal (Loc, Indx)));
2984 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
2987 Make_Attribute_Reference (Loc,
2988 Attribute_Name => Name_Length,
2990 Duplicate_Subexpr (N, Name_Req => True),
2991 Expressions => New_List (
2992 Make_Integer_Literal (Loc, Indx)));
3000 function Length_E_Cond
3001 (Exptyp : Entity_Id;
3009 Left_Opnd => Get_E_Length (Typ, Indx),
3010 Right_Opnd => Get_E_Length (Exptyp, Indx));
3018 function Length_N_Cond
3027 Left_Opnd => Get_E_Length (Typ, Indx),
3028 Right_Opnd => Get_N_Length (Expr, Indx));
3032 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
3035 (Nkind (L) = N_Integer_Literal
3036 and then Nkind (R) = N_Integer_Literal
3037 and then Intval (L) = Intval (R))
3041 and then Ekind (Entity (L)) = E_Constant
3042 and then ((Is_Entity_Name (R)
3043 and then Entity (L) = Entity (R))
3045 (Nkind (R) = N_Type_Conversion
3046 and then Is_Entity_Name (Expression (R))
3047 and then Entity (L) = Entity (Expression (R)))))
3051 and then Ekind (Entity (R)) = E_Constant
3052 and then Nkind (L) = N_Type_Conversion
3053 and then Is_Entity_Name (Expression (L))
3054 and then Entity (R) = Entity (Expression (L)))
3058 and then Is_Entity_Name (R)
3059 and then Entity (L) = Entity (R)
3060 and then Ekind (Entity (L)) = E_In_Parameter
3061 and then Inside_Init_Proc);
3064 -- Start of processing for Selected_Length_Checks
3067 if not Expander_Active then
3071 if Target_Typ = Any_Type
3072 or else Target_Typ = Any_Composite
3073 or else Raises_Constraint_Error (Ck_Node)
3082 T_Typ := Target_Typ;
3084 if No (Source_Typ) then
3085 S_Typ := Etype (Ck_Node);
3087 S_Typ := Source_Typ;
3090 if S_Typ = Any_Type or else S_Typ = Any_Composite then
3094 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3095 S_Typ := Designated_Type (S_Typ);
3096 T_Typ := Designated_Type (T_Typ);
3099 -- A simple optimization
3101 if Nkind (Ck_Node) = N_Null then
3106 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
3107 if Is_Constrained (T_Typ) then
3109 -- The checking code to be generated will freeze the
3110 -- corresponding array type. However, we must freeze the
3111 -- type now, so that the freeze node does not appear within
3112 -- the generated condional expression, but ahead of it.
3114 Freeze_Before (Ck_Node, T_Typ);
3116 Expr_Actual := Get_Referenced_Object (Ck_Node);
3117 Exptyp := Get_Actual_Subtype (Expr_Actual);
3119 if Is_Access_Type (Exptyp) then
3120 Exptyp := Designated_Type (Exptyp);
3123 -- String_Literal case. This needs to be handled specially be-
3124 -- cause no index types are available for string literals. The
3125 -- condition is simply:
3127 -- T_Typ'Length = string-literal-length
3129 if Nkind (Expr_Actual) = N_String_Literal then
3132 Left_Opnd => Get_E_Length (T_Typ, 1),
3134 Make_Integer_Literal (Loc,
3136 String_Literal_Length (Etype (Expr_Actual))));
3138 -- General array case. Here we have a usable actual subtype for
3139 -- the expression, and the condition is built from the two types
3142 -- T_Typ'Length /= Exptyp'Length or else
3143 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
3144 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
3147 elsif Is_Constrained (Exptyp) then
3151 Ndims : Nat := Number_Dimensions (T_Typ);
3162 L_Index := First_Index (T_Typ);
3163 R_Index := First_Index (Exptyp);
3165 for Indx in 1 .. Ndims loop
3166 if not (Nkind (L_Index) = N_Raise_Constraint_Error
3167 or else Nkind (R_Index) = N_Raise_Constraint_Error)
3169 Get_Index_Bounds (L_Index, L_Low, L_High);
3170 Get_Index_Bounds (R_Index, R_Low, R_High);
3172 -- Deal with compile time length check. Note that we
3173 -- skip this in the access case, because the access
3174 -- value may be null, so we cannot know statically.
3177 and then Compile_Time_Known_Value (L_Low)
3178 and then Compile_Time_Known_Value (L_High)
3179 and then Compile_Time_Known_Value (R_Low)
3180 and then Compile_Time_Known_Value (R_High)
3182 if Expr_Value (L_High) >= Expr_Value (L_Low) then
3183 L_Length := Expr_Value (L_High) -
3184 Expr_Value (L_Low) + 1;
3186 L_Length := UI_From_Int (0);
3189 if Expr_Value (R_High) >= Expr_Value (R_Low) then
3190 R_Length := Expr_Value (R_High) -
3191 Expr_Value (R_Low) + 1;
3193 R_Length := UI_From_Int (0);
3196 if L_Length > R_Length then
3198 (Compile_Time_Constraint_Error
3199 (Wnode, "too few elements for}?", T_Typ));
3201 elsif L_Length < R_Length then
3203 (Compile_Time_Constraint_Error
3204 (Wnode, "too many elements for}?", T_Typ));
3207 -- The comparison for an individual index subtype
3208 -- is omitted if the corresponding index subtypes
3209 -- statically match, since the result is known to
3210 -- be true. Note that this test is worth while even
3211 -- though we do static evaluation, because non-static
3212 -- subtypes can statically match.
3215 Subtypes_Statically_Match
3216 (Etype (L_Index), Etype (R_Index))
3219 (Same_Bounds (L_Low, R_Low)
3220 and then Same_Bounds (L_High, R_High))
3223 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
3232 -- Handle cases where we do not get a usable actual subtype that
3233 -- is constrained. This happens for example in the function call
3234 -- and explicit dereference cases. In these cases, we have to get
3235 -- the length or range from the expression itself, making sure we
3236 -- do not evaluate it more than once.
3238 -- Here Ck_Node is the original expression, or more properly the
3239 -- result of applying Duplicate_Expr to the original tree,
3240 -- forcing the result to be a name.
3244 Ndims : Nat := Number_Dimensions (T_Typ);
3247 -- Build the condition for the explicit dereference case
3249 for Indx in 1 .. Ndims loop
3251 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
3258 -- Construct the test and insert into the tree
3260 if Present (Cond) then
3262 Cond := Guard_Access (Cond, Loc, Ck_Node);
3265 Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond));
3270 end Selected_Length_Checks;
3272 ---------------------------
3273 -- Selected_Range_Checks --
3274 ---------------------------
3276 function Selected_Range_Checks
3278 Target_Typ : Entity_Id;
3279 Source_Typ : Entity_Id;
3280 Warn_Node : Node_Id)
3283 Loc : constant Source_Ptr := Sloc (Ck_Node);
3286 Expr_Actual : Node_Id;
3288 Cond : Node_Id := Empty;
3289 Do_Access : Boolean := False;
3290 Wnode : Node_Id := Warn_Node;
3291 Ret_Result : Check_Result := (Empty, Empty);
3292 Num_Checks : Integer := 0;
3294 procedure Add_Check (N : Node_Id);
3295 -- Adds the action given to Ret_Result if N is non-Empty
3297 function Discrete_Range_Cond
3301 -- Returns expression to compute:
3302 -- Low_Bound (Expr) < Typ'First
3304 -- High_Bound (Expr) > Typ'Last
3306 function Discrete_Expr_Cond
3310 -- Returns expression to compute:
3315 function Get_E_First_Or_Last
3320 -- Returns expression to compute:
3321 -- E'First or E'Last
3323 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
3324 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
3325 -- Returns expression to compute:
3326 -- N'First or N'Last using Duplicate_Subexpr
3328 function Range_E_Cond
3329 (Exptyp : Entity_Id;
3333 -- Returns expression to compute:
3334 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
3336 function Range_Equal_E_Cond
3337 (Exptyp : Entity_Id;
3341 -- Returns expression to compute:
3342 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
3344 function Range_N_Cond
3349 -- Return expression to compute:
3350 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
3356 procedure Add_Check (N : Node_Id) is
3360 -- For now, ignore attempt to place more than 2 checks ???
3362 if Num_Checks = 2 then
3366 pragma Assert (Num_Checks <= 1);
3367 Num_Checks := Num_Checks + 1;
3368 Ret_Result (Num_Checks) := N;
3372 -------------------------
3373 -- Discrete_Expr_Cond --
3374 -------------------------
3376 function Discrete_Expr_Cond
3387 Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3389 Convert_To (Base_Type (Typ),
3390 Get_E_First_Or_Last (Typ, 0, Name_First))),
3395 Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3399 Get_E_First_Or_Last (Typ, 0, Name_Last))));
3400 end Discrete_Expr_Cond;
3402 -------------------------
3403 -- Discrete_Range_Cond --
3404 -------------------------
3406 function Discrete_Range_Cond
3411 LB : Node_Id := Low_Bound (Expr);
3412 HB : Node_Id := High_Bound (Expr);
3414 Left_Opnd : Node_Id;
3415 Right_Opnd : Node_Id;
3418 if Nkind (LB) = N_Identifier
3419 and then Ekind (Entity (LB)) = E_Discriminant then
3420 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
3423 if Nkind (HB) = N_Identifier
3424 and then Ekind (Entity (HB)) = E_Discriminant then
3425 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
3432 (Base_Type (Typ), Duplicate_Subexpr (LB)),
3436 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
3438 if Base_Type (Typ) = Typ then
3441 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
3443 Compile_Time_Known_Value (High_Bound (Scalar_Range
3446 if Is_Floating_Point_Type (Typ) then
3447 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
3448 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
3454 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
3455 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
3466 (Base_Type (Typ), Duplicate_Subexpr (HB)),
3471 Get_E_First_Or_Last (Typ, 0, Name_Last)));
3473 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
3474 end Discrete_Range_Cond;
3476 -------------------------
3477 -- Get_E_First_Or_Last --
3478 -------------------------
3480 function Get_E_First_Or_Last
3492 if Is_Array_Type (E) then
3493 N := First_Index (E);
3495 for J in 2 .. Indx loop
3500 N := Scalar_Range (E);
3503 if Nkind (N) = N_Subtype_Indication then
3504 LB := Low_Bound (Range_Expression (Constraint (N)));
3505 HB := High_Bound (Range_Expression (Constraint (N)));
3507 elsif Is_Entity_Name (N) then
3508 LB := Type_Low_Bound (Etype (N));
3509 HB := Type_High_Bound (Etype (N));
3512 LB := Low_Bound (N);
3513 HB := High_Bound (N);
3516 if Nam = Name_First then
3522 if Nkind (Bound) = N_Identifier
3523 and then Ekind (Entity (Bound)) = E_Discriminant
3525 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
3527 elsif Nkind (Bound) = N_Identifier
3528 and then Ekind (Entity (Bound)) = E_In_Parameter
3529 and then not Inside_Init_Proc
3531 return Get_Discriminal (E, Bound);
3533 elsif Nkind (Bound) = N_Integer_Literal then
3534 return Make_Integer_Literal (Loc, Intval (Bound));
3537 return Duplicate_Subexpr (Bound);
3539 end Get_E_First_Or_Last;
3545 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
3548 Make_Attribute_Reference (Loc,
3549 Attribute_Name => Name_First,
3551 Duplicate_Subexpr (N, Name_Req => True),
3552 Expressions => New_List (
3553 Make_Integer_Literal (Loc, Indx)));
3561 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
3564 Make_Attribute_Reference (Loc,
3565 Attribute_Name => Name_Last,
3567 Duplicate_Subexpr (N, Name_Req => True),
3568 Expressions => New_List (
3569 Make_Integer_Literal (Loc, Indx)));
3577 function Range_E_Cond
3578 (Exptyp : Entity_Id;
3588 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3589 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3593 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3594 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3598 ------------------------
3599 -- Range_Equal_E_Cond --
3600 ------------------------
3602 function Range_Equal_E_Cond
3603 (Exptyp : Entity_Id;
3613 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3614 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3617 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3618 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3619 end Range_Equal_E_Cond;
3625 function Range_N_Cond
3636 Left_Opnd => Get_N_First (Expr, Indx),
3637 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3641 Left_Opnd => Get_N_Last (Expr, Indx),
3642 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3645 -- Start of processing for Selected_Range_Checks
3648 if not Expander_Active then
3652 if Target_Typ = Any_Type
3653 or else Target_Typ = Any_Composite
3654 or else Raises_Constraint_Error (Ck_Node)
3663 T_Typ := Target_Typ;
3665 if No (Source_Typ) then
3666 S_Typ := Etype (Ck_Node);
3668 S_Typ := Source_Typ;
3671 if S_Typ = Any_Type or else S_Typ = Any_Composite then
3675 -- The order of evaluating T_Typ before S_Typ seems to be critical
3676 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
3677 -- in, and since Node can be an N_Range node, it might be invalid.
3678 -- Should there be an assert check somewhere for taking the Etype of
3679 -- an N_Range node ???
3681 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3682 S_Typ := Designated_Type (S_Typ);
3683 T_Typ := Designated_Type (T_Typ);
3686 -- A simple optimization
3688 if Nkind (Ck_Node) = N_Null then
3693 -- For an N_Range Node, check for a null range and then if not
3694 -- null generate a range check action.
3696 if Nkind (Ck_Node) = N_Range then
3698 -- There's no point in checking a range against itself
3700 if Ck_Node = Scalar_Range (T_Typ) then
3705 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
3706 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
3707 LB : constant Node_Id := Low_Bound (Ck_Node);
3708 HB : constant Node_Id := High_Bound (Ck_Node);
3709 Null_Range : Boolean;
3711 Out_Of_Range_L : Boolean;
3712 Out_Of_Range_H : Boolean;
3715 -- Check for case where everything is static and we can
3716 -- do the check at compile time. This is skipped if we
3717 -- have an access type, since the access value may be null.
3719 -- ??? This code can be improved since you only need to know
3720 -- that the two respective bounds (LB & T_LB or HB & T_HB)
3721 -- are known at compile time to emit pertinent messages.
3723 if Compile_Time_Known_Value (LB)
3724 and then Compile_Time_Known_Value (HB)
3725 and then Compile_Time_Known_Value (T_LB)
3726 and then Compile_Time_Known_Value (T_HB)
3727 and then not Do_Access
3729 -- Floating-point case
3731 if Is_Floating_Point_Type (S_Typ) then
3732 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
3734 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
3736 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
3739 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
3741 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
3743 -- Fixed or discrete type case
3746 Null_Range := Expr_Value (HB) < Expr_Value (LB);
3748 (Expr_Value (LB) < Expr_Value (T_LB))
3750 (Expr_Value (LB) > Expr_Value (T_HB));
3753 (Expr_Value (HB) > Expr_Value (T_HB))
3755 (Expr_Value (HB) < Expr_Value (T_LB));
3758 if not Null_Range then
3759 if Out_Of_Range_L then
3760 if No (Warn_Node) then
3762 (Compile_Time_Constraint_Error
3763 (Low_Bound (Ck_Node),
3764 "static value out of range of}?", T_Typ));
3768 (Compile_Time_Constraint_Error
3770 "static range out of bounds of}?", T_Typ));
3774 if Out_Of_Range_H then
3775 if No (Warn_Node) then
3777 (Compile_Time_Constraint_Error
3778 (High_Bound (Ck_Node),
3779 "static value out of range of}?", T_Typ));
3783 (Compile_Time_Constraint_Error
3785 "static range out of bounds of}?", T_Typ));
3793 LB : Node_Id := Low_Bound (Ck_Node);
3794 HB : Node_Id := High_Bound (Ck_Node);
3798 -- If either bound is a discriminant and we are within
3799 -- the record declaration, it is a use of the discriminant
3800 -- in a constraint of a component, and nothing can be
3801 -- checked here. The check will be emitted within the
3802 -- init_proc. Before then, the discriminal has no real
3805 if Nkind (LB) = N_Identifier
3806 and then Ekind (Entity (LB)) = E_Discriminant
3808 if Current_Scope = Scope (Entity (LB)) then
3812 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
3816 if Nkind (HB) = N_Identifier
3817 and then Ekind (Entity (HB)) = E_Discriminant
3819 if Current_Scope = Scope (Entity (HB)) then
3823 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
3827 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
3828 Set_Paren_Count (Cond, 1);
3834 Left_Opnd => Duplicate_Subexpr (HB),
3835 Right_Opnd => Duplicate_Subexpr (LB)),
3836 Right_Opnd => Cond);
3842 elsif Is_Scalar_Type (S_Typ) then
3844 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
3845 -- except the above simply sets a flag in the node and lets
3846 -- gigi generate the check base on the Etype of the expression.
3847 -- Sometimes, however we want to do a dynamic check against an
3848 -- arbitrary target type, so we do that here.
3850 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
3851 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
3853 -- For literals, we can tell if the constraint error will be
3854 -- raised at compile time, so we never need a dynamic check, but
3855 -- if the exception will be raised, then post the usual warning,
3856 -- and replace the literal with a raise constraint error
3857 -- expression. As usual, skip this for access types
3859 elsif Compile_Time_Known_Value (Ck_Node)
3860 and then not Do_Access
3863 LB : constant Node_Id := Type_Low_Bound (T_Typ);
3864 UB : constant Node_Id := Type_High_Bound (T_Typ);
3866 Out_Of_Range : Boolean;
3867 Static_Bounds : constant Boolean :=
3868 Compile_Time_Known_Value (LB)
3869 and Compile_Time_Known_Value (UB);
3872 -- Following range tests should use Sem_Eval routine ???
3874 if Static_Bounds then
3875 if Is_Floating_Point_Type (S_Typ) then
3877 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
3879 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
3881 else -- fixed or discrete type
3883 Expr_Value (Ck_Node) < Expr_Value (LB)
3885 Expr_Value (Ck_Node) > Expr_Value (UB);
3888 -- Bounds of the type are static and the literal is
3889 -- out of range so make a warning message.
3891 if Out_Of_Range then
3892 if No (Warn_Node) then
3894 (Compile_Time_Constraint_Error
3896 "static value out of range of}?", T_Typ));
3900 (Compile_Time_Constraint_Error
3902 "static value out of range of}?", T_Typ));
3907 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
3911 -- Here for the case of a non-static expression, we need a runtime
3912 -- check unless the source type range is guaranteed to be in the
3913 -- range of the target type.
3916 if not In_Subrange_Of (S_Typ, T_Typ) then
3917 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
3922 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
3923 if Is_Constrained (T_Typ) then
3925 Expr_Actual := Get_Referenced_Object (Ck_Node);
3926 Exptyp := Get_Actual_Subtype (Expr_Actual);
3928 if Is_Access_Type (Exptyp) then
3929 Exptyp := Designated_Type (Exptyp);
3932 -- String_Literal case. This needs to be handled specially be-
3933 -- cause no index types are available for string literals. The
3934 -- condition is simply:
3936 -- T_Typ'Length = string-literal-length
3938 if Nkind (Expr_Actual) = N_String_Literal then
3941 -- General array case. Here we have a usable actual subtype for
3942 -- the expression, and the condition is built from the two types
3944 -- T_Typ'First < Exptyp'First or else
3945 -- T_Typ'Last > Exptyp'Last or else
3946 -- T_Typ'First(1) < Exptyp'First(1) or else
3947 -- T_Typ'Last(1) > Exptyp'Last(1) or else
3950 elsif Is_Constrained (Exptyp) then
3954 Ndims : Nat := Number_Dimensions (T_Typ);
3962 L_Index := First_Index (T_Typ);
3963 R_Index := First_Index (Exptyp);
3965 for Indx in 1 .. Ndims loop
3966 if not (Nkind (L_Index) = N_Raise_Constraint_Error
3967 or else Nkind (R_Index) = N_Raise_Constraint_Error)
3969 Get_Index_Bounds (L_Index, L_Low, L_High);
3970 Get_Index_Bounds (R_Index, R_Low, R_High);
3972 -- Deal with compile time length check. Note that we
3973 -- skip this in the access case, because the access
3974 -- value may be null, so we cannot know statically.
3977 Subtypes_Statically_Match
3978 (Etype (L_Index), Etype (R_Index))
3980 -- If the target type is constrained then we
3981 -- have to check for exact equality of bounds
3982 -- (required for qualified expressions).
3984 if Is_Constrained (T_Typ) then
3987 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
3991 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
4002 -- Handle cases where we do not get a usable actual subtype that
4003 -- is constrained. This happens for example in the function call
4004 -- and explicit dereference cases. In these cases, we have to get
4005 -- the length or range from the expression itself, making sure we
4006 -- do not evaluate it more than once.
4008 -- Here Ck_Node is the original expression, or more properly the
4009 -- result of applying Duplicate_Expr to the original tree,
4010 -- forcing the result to be a name.
4014 Ndims : Nat := Number_Dimensions (T_Typ);
4017 -- Build the condition for the explicit dereference case
4019 for Indx in 1 .. Ndims loop
4021 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
4028 -- Generate an Action to check that the bounds of the
4029 -- source value are within the constraints imposed by the
4030 -- target type for a conversion to an unconstrained type.
4033 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
4035 Opnd_Index : Node_Id;
4036 Targ_Index : Node_Id;
4040 := First_Index (Get_Actual_Subtype (Ck_Node));
4041 Targ_Index := First_Index (T_Typ);
4043 while Opnd_Index /= Empty loop
4044 if Nkind (Opnd_Index) = N_Range then
4046 (Low_Bound (Opnd_Index), Etype (Targ_Index))
4049 (High_Bound (Opnd_Index), Etype (Targ_Index))
4053 elsif Is_Out_Of_Range
4054 (Low_Bound (Opnd_Index), Etype (Targ_Index))
4057 (High_Bound (Opnd_Index), Etype (Targ_Index))
4060 (Compile_Time_Constraint_Error
4061 (Wnode, "value out of range of}?", T_Typ));
4067 (Opnd_Index, Etype (Targ_Index)));
4071 Next_Index (Opnd_Index);
4072 Next_Index (Targ_Index);
4079 -- Construct the test and insert into the tree
4081 if Present (Cond) then
4083 Cond := Guard_Access (Cond, Loc, Ck_Node);
4086 Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond));
4091 end Selected_Range_Checks;
4093 -------------------------------
4094 -- Storage_Checks_Suppressed --
4095 -------------------------------
4097 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
4099 return Scope_Suppress.Storage_Checks
4100 or else (Present (E) and then Suppress_Storage_Checks (E));
4101 end Storage_Checks_Suppressed;
4103 ---------------------------
4104 -- Tag_Checks_Suppressed --
4105 ---------------------------
4107 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
4109 return Scope_Suppress.Tag_Checks
4110 or else (Present (E) and then Suppress_Tag_Checks (E));
4111 end Tag_Checks_Suppressed;