1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch2; use Exp_Ch2;
32 with Exp_Util; use Exp_Util;
33 with Elists; use Elists;
34 with Freeze; use Freeze;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Restrict; use Restrict;
39 with Rtsfind; use Rtsfind;
41 with Sem_Eval; use Sem_Eval;
42 with Sem_Res; use Sem_Res;
43 with Sem_Util; use Sem_Util;
44 with Sem_Warn; use Sem_Warn;
45 with Sinfo; use Sinfo;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Targparm; use Targparm;
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);
200 Make_Raise_Constraint_Error (Internal_Static_Sloc,
201 Reason => CE_Range_Check_Failed));
204 end Append_Range_Checks;
206 ------------------------
207 -- Apply_Access_Check --
208 ------------------------
210 procedure Apply_Access_Check (N : Node_Id) is
211 P : constant Node_Id := Prefix (N);
214 if Inside_A_Generic then
218 if Is_Entity_Name (P) then
219 Check_Unset_Reference (P);
222 if Is_Entity_Name (P)
223 and then Access_Checks_Suppressed (Entity (P))
227 elsif Access_Checks_Suppressed (Etype (P)) then
231 Set_Do_Access_Check (N, True);
233 end Apply_Access_Check;
235 -------------------------------
236 -- Apply_Accessibility_Check --
237 -------------------------------
239 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
240 Loc : constant Source_Ptr := Sloc (N);
241 Param_Ent : constant Entity_Id := Param_Entity (N);
242 Param_Level : Node_Id;
243 Type_Level : Node_Id;
246 if Inside_A_Generic then
249 -- Only apply the run-time check if the access parameter
250 -- has an associated extra access level parameter and
251 -- when the level of the type is less deep than the level
252 -- of the access parameter.
254 elsif Present (Param_Ent)
255 and then Present (Extra_Accessibility (Param_Ent))
256 and then UI_Gt (Object_Access_Level (N),
257 Type_Access_Level (Typ))
258 and then not Accessibility_Checks_Suppressed (Param_Ent)
259 and then not Accessibility_Checks_Suppressed (Typ)
262 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
265 Make_Integer_Literal (Loc, Type_Access_Level (Typ));
267 -- Raise Program_Error if the accessibility level of the
268 -- the access parameter is deeper than the level of the
269 -- target access type.
272 Make_Raise_Program_Error (Loc,
275 Left_Opnd => Param_Level,
276 Right_Opnd => Type_Level),
277 Reason => PE_Accessibility_Check_Failed));
279 Analyze_And_Resolve (N);
281 end Apply_Accessibility_Check;
283 ---------------------------
284 -- Apply_Alignment_Check --
285 ---------------------------
287 procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
288 AC : constant Node_Id := Address_Clause (E);
293 if No (AC) or else Range_Checks_Suppressed (E) then
298 Expr := Expression (AC);
300 if Nkind (Expr) = N_Unchecked_Type_Conversion then
301 Expr := Expression (Expr);
303 elsif Nkind (Expr) = N_Function_Call
304 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
306 Expr := First (Parameter_Associations (Expr));
308 if Nkind (Expr) = N_Parameter_Association then
309 Expr := Explicit_Actual_Parameter (Expr);
313 -- Here Expr is the address value. See if we know that the
314 -- value is unacceptable at compile time.
316 if Compile_Time_Known_Value (Expr)
317 and then Known_Alignment (E)
319 if Expr_Value (Expr) mod Alignment (E) /= 0 then
321 Make_Raise_Program_Error (Loc,
322 Reason => PE_Misaligned_Address_Value));
324 ("?specified address for& not " &
325 "consistent with alignment", Expr, E);
328 -- Here we do not know if the value is acceptable, generate
329 -- code to raise PE if alignment is inappropriate.
332 -- Skip generation of this code if we don't want elab code
334 if not Restrictions (No_Elaboration_Code) then
335 Insert_After_And_Analyze (N,
336 Make_Raise_Program_Error (Loc,
343 (RTE (RE_Integer_Address),
344 Duplicate_Subexpr (Expr)),
346 Make_Attribute_Reference (Loc,
347 Prefix => New_Occurrence_Of (E, Loc),
348 Attribute_Name => Name_Alignment)),
349 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
350 Reason => PE_Misaligned_Address_Value),
351 Suppress => All_Checks);
356 end Apply_Alignment_Check;
358 -------------------------------------
359 -- Apply_Arithmetic_Overflow_Check --
360 -------------------------------------
362 -- This routine is called only if the type is an integer type, and
363 -- a software arithmetic overflow check must be performed for op
364 -- (add, subtract, multiply). The check is performed only if
365 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
366 -- is set. In this case we expand the operation into a more complex
367 -- sequence of tests that ensures that overflow is properly caught.
369 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
370 Loc : constant Source_Ptr := Sloc (N);
371 Typ : constant Entity_Id := Etype (N);
372 Rtyp : constant Entity_Id := Root_Type (Typ);
373 Siz : constant Int := UI_To_Int (Esize (Rtyp));
374 Dsiz : constant Int := Siz * 2;
384 if Backend_Overflow_Checks_On_Target
385 or not Do_Overflow_Check (N)
386 or not Expander_Active
391 -- Nothing to do if the range of the result is known OK
393 Determine_Range (N, OK, Lo, Hi);
395 -- Note in the test below that we assume that if a bound of the
396 -- range is equal to that of the type. That's not quite accurate
397 -- but we do this for the following reasons:
399 -- a) The way that Determine_Range works, it will typically report
400 -- the bounds of the value are the bounds of the type, because
401 -- it either can't tell anything more precise, or does not think
402 -- it is worth the effort to be more precise.
404 -- b) It is very unusual to have a situation in which this would
405 -- generate an unnecessary overflow check (an example would be
406 -- a subtype with a range 0 .. Integer'Last - 1 to which the
407 -- literal value one is added.
409 -- c) The alternative is a lot of special casing in this routine
410 -- which would partially duplicate the Determine_Range processing.
413 and then Lo > Expr_Value (Type_Low_Bound (Typ))
414 and then Hi < Expr_Value (Type_High_Bound (Typ))
419 -- None of the special case optimizations worked, so there is nothing
420 -- for it but to generate the full general case code:
426 -- Typ (Checktyp (x) op Checktyp (y));
428 -- where Typ is the type of the original expression, and Checktyp is
429 -- an integer type of sufficient length to hold the largest possible
432 -- In the case where check type exceeds the size of Long_Long_Integer,
433 -- we use a different approach, expanding to:
435 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
437 -- where xxx is Add, Multiply or Subtract as appropriate
439 -- Find check type if one exists
441 if Dsiz <= Standard_Integer_Size then
442 Ctyp := Standard_Integer;
444 elsif Dsiz <= Standard_Long_Long_Integer_Size then
445 Ctyp := Standard_Long_Long_Integer;
447 -- No check type exists, use runtime call
450 if Nkind (N) = N_Op_Add then
451 Cent := RE_Add_With_Ovflo_Check;
453 elsif Nkind (N) = N_Op_Multiply then
454 Cent := RE_Multiply_With_Ovflo_Check;
457 pragma Assert (Nkind (N) = N_Op_Subtract);
458 Cent := RE_Subtract_With_Ovflo_Check;
463 Make_Function_Call (Loc,
464 Name => New_Reference_To (RTE (Cent), Loc),
465 Parameter_Associations => New_List (
466 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
467 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
469 Analyze_And_Resolve (N, Typ);
473 -- If we fall through, we have the case where we do the arithmetic in
474 -- the next higher type and get the check by conversion. In these cases
475 -- Ctyp is set to the type to be used as the check type.
477 Opnod := Relocate_Node (N);
479 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
482 Set_Etype (Opnd, Ctyp);
483 Set_Analyzed (Opnd, True);
484 Set_Left_Opnd (Opnod, Opnd);
486 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
489 Set_Etype (Opnd, Ctyp);
490 Set_Analyzed (Opnd, True);
491 Set_Right_Opnd (Opnod, Opnd);
493 -- The type of the operation changes to the base type of the check
494 -- type, and we reset the overflow check indication, since clearly
495 -- no overflow is possible now that we are using a double length
496 -- type. We also set the Analyzed flag to avoid a recursive attempt
497 -- to expand the node.
499 Set_Etype (Opnod, Base_Type (Ctyp));
500 Set_Do_Overflow_Check (Opnod, False);
501 Set_Analyzed (Opnod, True);
503 -- Now build the outer conversion
505 Opnd := OK_Convert_To (Typ, Opnod);
508 Set_Etype (Opnd, Typ);
509 Set_Analyzed (Opnd, True);
510 Set_Do_Overflow_Check (Opnd, True);
513 end Apply_Arithmetic_Overflow_Check;
515 ----------------------------
516 -- Apply_Array_Size_Check --
517 ----------------------------
519 -- Note: Really of course this entre check should be in the backend,
520 -- and perhaps this is not quite the right value, but it is good
521 -- enough to catch the normal cases (and the relevant ACVC tests!)
523 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
524 Loc : constant Source_Ptr := Sloc (N);
525 Ctyp : constant Entity_Id := Component_Type (Typ);
526 Ent : constant Entity_Id := Defining_Identifier (N);
538 Static : Boolean := True;
539 -- Set false if any index subtye bound is non-static
541 Umark : constant Uintp.Save_Mark := Uintp.Mark;
542 -- We can throw away all the Uint computations here, since they are
543 -- done only to generate boolean test results.
546 -- Size to check against
548 function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
549 -- Determines if Decl is an address clause or Import/Interface pragma
550 -- that references the defining identifier of the current declaration.
552 --------------------------
553 -- Is_Address_Or_Import --
554 --------------------------
556 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
558 if Nkind (Decl) = N_At_Clause then
559 return Chars (Identifier (Decl)) = Chars (Ent);
561 elsif Nkind (Decl) = N_Attribute_Definition_Clause then
563 Chars (Decl) = Name_Address
565 Nkind (Name (Decl)) = N_Identifier
567 Chars (Name (Decl)) = Chars (Ent);
569 elsif Nkind (Decl) = N_Pragma then
570 if (Chars (Decl) = Name_Import
572 Chars (Decl) = Name_Interface)
573 and then Present (Pragma_Argument_Associations (Decl))
576 F : constant Node_Id :=
577 First (Pragma_Argument_Associations (Decl));
585 Nkind (Expression (Next (F))) = N_Identifier
587 Chars (Expression (Next (F))) = Chars (Ent);
597 end Is_Address_Or_Import;
599 -- Start of processing for Apply_Array_Size_Check
602 if not Expander_Active
603 or else Storage_Checks_Suppressed (Typ)
608 -- It is pointless to insert this check inside an _init_proc, because
609 -- that's too late, we have already built the object to be the right
610 -- size, and if it's too large, too bad!
612 if Inside_Init_Proc then
616 -- Look head for pragma interface/import or address clause applying
617 -- to this entity. If found, we suppress the check entirely. For now
618 -- we only look ahead 20 declarations to stop this becoming too slow
619 -- Note that eventually this whole routine gets moved to gigi.
622 for Ctr in 1 .. 20 loop
626 if Is_Address_Or_Import (Decl) then
631 -- First step is to calculate the maximum number of elements. For this
632 -- calculation, we use the actual size of the subtype if it is static,
633 -- and if a bound of a subtype is non-static, we go to the bound of the
637 Indx := First_Index (Typ);
638 while Present (Indx) loop
639 Xtyp := Etype (Indx);
640 Lo := Type_Low_Bound (Xtyp);
641 Hi := Type_High_Bound (Xtyp);
643 -- If any bound raises constraint error, we will never get this
644 -- far, so there is no need to generate any kind of check.
646 if Raises_Constraint_Error (Lo)
648 Raises_Constraint_Error (Hi)
650 Uintp.Release (Umark);
654 -- Otherwise get bounds values
656 if Is_Static_Expression (Lo) then
657 Lob := Expr_Value (Lo);
659 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
663 if Is_Static_Expression (Hi) then
664 Hib := Expr_Value (Hi);
666 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
670 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
674 -- Compute the limit against which we want to check. For subprograms,
675 -- where the array will go on the stack, we use 8*2**24, which (in
676 -- bits) is the size of a 16 megabyte array.
678 if Is_Subprogram (Scope (Ent)) then
679 Check_Siz := Uint_2 ** 27;
681 Check_Siz := Uint_2 ** 31;
684 -- If we have all static bounds and Siz is too large, then we know we
685 -- know we have a storage error right now, so generate message
687 if Static and then Siz >= Check_Siz then
689 Make_Raise_Storage_Error (Loc,
690 Reason => SE_Object_Too_Large));
691 Warn_On_Instance := True;
692 Error_Msg_N ("?Storage_Error will be raised at run-time", N);
693 Warn_On_Instance := False;
694 Uintp.Release (Umark);
698 -- Case of component size known at compile time. If the array
699 -- size is definitely in range, then we do not need a check.
701 if Known_Esize (Ctyp)
702 and then Siz * Esize (Ctyp) < Check_Siz
704 Uintp.Release (Umark);
708 -- Here if a dynamic check is required
710 -- What we do is to build an expression for the size of the array,
711 -- which is computed as the 'Size of the array component, times
712 -- the size of each dimension.
714 Uintp.Release (Umark);
717 Make_Attribute_Reference (Loc,
718 Prefix => New_Occurrence_Of (Ctyp, Loc),
719 Attribute_Name => Name_Size);
721 Indx := First_Index (Typ);
723 for J in 1 .. Number_Dimensions (Typ) loop
725 if Sloc (Etype (Indx)) = Sloc (N) then
726 Ensure_Defined (Etype (Indx), N);
730 Make_Op_Multiply (Loc,
733 Make_Attribute_Reference (Loc,
734 Prefix => New_Occurrence_Of (Typ, Loc),
735 Attribute_Name => Name_Length,
736 Expressions => New_List (
737 Make_Integer_Literal (Loc, J))));
742 Make_Raise_Storage_Error (Loc,
747 Make_Integer_Literal (Loc, Check_Siz)),
748 Reason => SE_Object_Too_Large);
750 Set_Size_Check_Code (Defining_Identifier (N), Code);
751 Insert_Action (N, Code);
752 end Apply_Array_Size_Check;
754 ----------------------------
755 -- Apply_Constraint_Check --
756 ----------------------------
758 procedure Apply_Constraint_Check
761 No_Sliding : Boolean := False)
763 Desig_Typ : Entity_Id;
766 if Inside_A_Generic then
769 elsif Is_Scalar_Type (Typ) then
770 Apply_Scalar_Range_Check (N, Typ);
772 elsif Is_Array_Type (Typ) then
774 -- A useful optimization: an aggregate with only an Others clause
775 -- always has the right bounds.
777 if Nkind (N) = N_Aggregate
778 and then No (Expressions (N))
780 (First (Choices (First (Component_Associations (N)))))
786 if Is_Constrained (Typ) then
787 Apply_Length_Check (N, Typ);
790 Apply_Range_Check (N, Typ);
793 Apply_Range_Check (N, Typ);
796 elsif (Is_Record_Type (Typ)
797 or else Is_Private_Type (Typ))
798 and then Has_Discriminants (Base_Type (Typ))
799 and then Is_Constrained (Typ)
801 Apply_Discriminant_Check (N, Typ);
803 elsif Is_Access_Type (Typ) then
805 Desig_Typ := Designated_Type (Typ);
807 -- No checks necessary if expression statically null
809 if Nkind (N) = N_Null then
812 -- No sliding possible on access to arrays
814 elsif Is_Array_Type (Desig_Typ) then
815 if Is_Constrained (Desig_Typ) then
816 Apply_Length_Check (N, Typ);
819 Apply_Range_Check (N, Typ);
821 elsif Has_Discriminants (Base_Type (Desig_Typ))
822 and then Is_Constrained (Desig_Typ)
824 Apply_Discriminant_Check (N, Typ);
827 end Apply_Constraint_Check;
829 ------------------------------
830 -- Apply_Discriminant_Check --
831 ------------------------------
833 procedure Apply_Discriminant_Check
836 Lhs : Node_Id := Empty)
838 Loc : constant Source_Ptr := Sloc (N);
839 Do_Access : constant Boolean := Is_Access_Type (Typ);
840 S_Typ : Entity_Id := Etype (N);
844 function Is_Aliased_Unconstrained_Component return Boolean;
845 -- It is possible for an aliased component to have a nominal
846 -- unconstrained subtype (through instantiation). If this is a
847 -- discriminated component assigned in the expansion of an aggregate
848 -- in an initialization, the check must be suppressed. This unusual
849 -- situation requires a predicate of its own (see 7503-008).
851 ----------------------------------------
852 -- Is_Aliased_Unconstrained_Component --
853 ----------------------------------------
855 function Is_Aliased_Unconstrained_Component return Boolean is
860 if Nkind (Lhs) /= N_Selected_Component then
863 Comp := Entity (Selector_Name (Lhs));
864 Pref := Prefix (Lhs);
867 if Ekind (Comp) /= E_Component
868 or else not Is_Aliased (Comp)
873 return not Comes_From_Source (Pref)
875 and then not Is_Constrained (Etype (Comp));
876 end Is_Aliased_Unconstrained_Component;
878 -- Start of processing for Apply_Discriminant_Check
882 T_Typ := Designated_Type (Typ);
887 -- Nothing to do if discriminant checks are suppressed or else no code
888 -- is to be generated
890 if not Expander_Active
891 or else Discriminant_Checks_Suppressed (T_Typ)
896 -- No discriminant checks necessary for access when expression
897 -- is statically Null. This is not only an optimization, this is
898 -- fundamental because otherwise discriminant checks may be generated
899 -- in init procs for types containing an access to a non-frozen yet
900 -- record, causing a deadly forward reference.
902 -- Also, if the expression is of an access type whose designated
903 -- type is incomplete, then the access value must be null and
904 -- we suppress the check.
906 if Nkind (N) = N_Null then
909 elsif Is_Access_Type (S_Typ) then
910 S_Typ := Designated_Type (S_Typ);
912 if Ekind (S_Typ) = E_Incomplete_Type then
917 -- If an assignment target is present, then we need to generate
918 -- the actual subtype if the target is a parameter or aliased
919 -- object with an unconstrained nominal subtype.
922 and then (Present (Param_Entity (Lhs))
923 or else (not Is_Constrained (T_Typ)
924 and then Is_Aliased_View (Lhs)
925 and then not Is_Aliased_Unconstrained_Component))
927 T_Typ := Get_Actual_Subtype (Lhs);
930 -- Nothing to do if the type is unconstrained (this is the case
931 -- where the actual subtype in the RM sense of N is unconstrained
932 -- and no check is required).
934 if not Is_Constrained (T_Typ) then
938 -- Suppress checks if the subtypes are the same.
939 -- the check must be preserved in an assignment to a formal, because
940 -- the constraint is given by the actual.
942 if Nkind (Original_Node (N)) /= N_Allocator
944 or else not Is_Entity_Name (Lhs)
945 or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter
946 and then Ekind (Entity (Lhs)) /= E_Out_Parameter))
949 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
950 and then not Is_Aliased_View (Lhs)
955 -- We can also eliminate checks on allocators with a subtype mark
956 -- that coincides with the context type. The context type may be a
957 -- subtype without a constraint (common case, a generic actual).
959 elsif Nkind (Original_Node (N)) = N_Allocator
960 and then Is_Entity_Name (Expression (Original_Node (N)))
963 Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N)));
967 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
968 and then Is_Entity_Name (
969 Subtype_Indication (Parent (T_Typ)))
970 and then Alloc_Typ = Base_Type (T_Typ))
978 -- See if we have a case where the types are both constrained, and
979 -- all the constraints are constants. In this case, we can do the
980 -- check successfully at compile time.
982 -- we skip this check for the case where the node is a rewritten`
983 -- allocator, because it already carries the context subtype, and
984 -- extracting the discriminants from the aggregate is messy.
986 if Is_Constrained (S_Typ)
987 and then Nkind (Original_Node (N)) /= N_Allocator
997 -- S_Typ may not have discriminants in the case where it is a
998 -- private type completed by a default discriminated type. In
999 -- that case, we need to get the constraints from the
1000 -- underlying_type. If the underlying type is unconstrained (i.e.
1001 -- has no default discriminants) no check is needed.
1003 if Has_Discriminants (S_Typ) then
1004 Discr := First_Discriminant (S_Typ);
1005 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1008 Discr := First_Discriminant (Underlying_Type (S_Typ));
1011 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1018 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
1020 while Present (Discr) loop
1021 ItemS := Node (DconS);
1022 ItemT := Node (DconT);
1025 not Is_OK_Static_Expression (ItemS)
1027 not Is_OK_Static_Expression (ItemT);
1029 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1030 if Do_Access then -- needs run-time check.
1033 Apply_Compile_Time_Constraint_Error
1034 (N, "incorrect value for discriminant&?",
1035 CE_Discriminant_Check_Failed, Ent => Discr);
1042 Next_Discriminant (Discr);
1051 -- Here we need a discriminant check. First build the expression
1052 -- for the comparisons of the discriminants:
1054 -- (n.disc1 /= typ.disc1) or else
1055 -- (n.disc2 /= typ.disc2) or else
1057 -- (n.discn /= typ.discn)
1059 Cond := Build_Discriminant_Checks (N, T_Typ);
1061 -- If Lhs is set and is a parameter, then the condition is
1062 -- guarded by: lhs'constrained and then (condition built above)
1064 if Present (Param_Entity (Lhs)) then
1068 Make_Attribute_Reference (Loc,
1069 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1070 Attribute_Name => Name_Constrained),
1071 Right_Opnd => Cond);
1075 Cond := Guard_Access (Cond, Loc, N);
1079 Make_Raise_Constraint_Error (Loc,
1081 Reason => CE_Discriminant_Check_Failed));
1083 end Apply_Discriminant_Check;
1085 ------------------------
1086 -- Apply_Divide_Check --
1087 ------------------------
1089 procedure Apply_Divide_Check (N : Node_Id) is
1090 Loc : constant Source_Ptr := Sloc (N);
1091 Typ : constant Entity_Id := Etype (N);
1092 Left : constant Node_Id := Left_Opnd (N);
1093 Right : constant Node_Id := Right_Opnd (N);
1105 and not Backend_Divide_Checks_On_Target
1107 Determine_Range (Right, ROK, Rlo, Rhi);
1109 -- See if division by zero possible, and if so generate test. This
1110 -- part of the test is not controlled by the -gnato switch.
1112 if Do_Division_Check (N) then
1114 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1116 Make_Raise_Constraint_Error (Loc,
1119 Left_Opnd => Duplicate_Subexpr (Right),
1120 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1121 Reason => CE_Divide_By_Zero));
1125 -- Test for extremely annoying case of xxx'First divided by -1
1127 if Do_Overflow_Check (N) then
1129 if Nkind (N) = N_Op_Divide
1130 and then Is_Signed_Integer_Type (Typ)
1132 Determine_Range (Left, LOK, Llo, Lhi);
1133 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1135 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1137 ((not LOK) or else (Llo = LLB))
1140 Make_Raise_Constraint_Error (Loc,
1145 Left_Opnd => Duplicate_Subexpr (Left),
1146 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1149 Left_Opnd => Duplicate_Subexpr (Right),
1151 Make_Integer_Literal (Loc, -1))),
1152 Reason => CE_Overflow_Check_Failed));
1157 end Apply_Divide_Check;
1159 ------------------------
1160 -- Apply_Length_Check --
1161 ------------------------
1163 procedure Apply_Length_Check
1165 Target_Typ : Entity_Id;
1166 Source_Typ : Entity_Id := Empty)
1169 Apply_Selected_Length_Checks
1170 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1171 end Apply_Length_Check;
1173 -----------------------
1174 -- Apply_Range_Check --
1175 -----------------------
1177 procedure Apply_Range_Check
1179 Target_Typ : Entity_Id;
1180 Source_Typ : Entity_Id := Empty)
1183 Apply_Selected_Range_Checks
1184 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1185 end Apply_Range_Check;
1187 ------------------------------
1188 -- Apply_Scalar_Range_Check --
1189 ------------------------------
1191 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1192 -- flag off if it is already set on.
1194 procedure Apply_Scalar_Range_Check
1196 Target_Typ : Entity_Id;
1197 Source_Typ : Entity_Id := Empty;
1198 Fixed_Int : Boolean := False)
1200 Parnt : constant Node_Id := Parent (Expr);
1202 Arr : Node_Id := Empty; -- initialize to prevent warning
1203 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1206 Is_Subscr_Ref : Boolean;
1207 -- Set true if Expr is a subscript
1209 Is_Unconstrained_Subscr_Ref : Boolean;
1210 -- Set true if Expr is a subscript of an unconstrained array. In this
1211 -- case we do not attempt to do an analysis of the value against the
1212 -- range of the subscript, since we don't know the actual subtype.
1215 -- Set to True if Expr should be regarded as a real value
1216 -- even though the type of Expr might be discrete.
1218 procedure Bad_Value;
1219 -- Procedure called if value is determined to be out of range
1221 procedure Bad_Value is
1223 Apply_Compile_Time_Constraint_Error
1224 (Expr, "value not in range of}?", CE_Range_Check_Failed,
1230 if Inside_A_Generic then
1233 -- Return if check obviously not needed. Note that we do not check
1234 -- for the expander being inactive, since this routine does not
1235 -- insert any code, but it does generate useful warnings sometimes,
1236 -- which we would like even if we are in semantics only mode.
1238 elsif Target_Typ = Any_Type
1239 or else not Is_Scalar_Type (Target_Typ)
1240 or else Raises_Constraint_Error (Expr)
1245 -- Now, see if checks are suppressed
1248 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1250 if Is_Subscr_Ref then
1251 Arr := Prefix (Parnt);
1252 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1255 if not Do_Range_Check (Expr) then
1257 -- Subscript reference. Check for Index_Checks suppressed
1259 if Is_Subscr_Ref then
1261 -- Check array type and its base type
1263 if Index_Checks_Suppressed (Arr_Typ)
1264 or else Suppress_Index_Checks (Base_Type (Arr_Typ))
1268 -- Check array itself if it is an entity name
1270 elsif Is_Entity_Name (Arr)
1271 and then Suppress_Index_Checks (Entity (Arr))
1275 -- Check expression itself if it is an entity name
1277 elsif Is_Entity_Name (Expr)
1278 and then Suppress_Index_Checks (Entity (Expr))
1283 -- All other cases, check for Range_Checks suppressed
1286 -- Check target type and its base type
1288 if Range_Checks_Suppressed (Target_Typ)
1289 or else Suppress_Range_Checks (Base_Type (Target_Typ))
1293 -- Check expression itself if it is an entity name
1295 elsif Is_Entity_Name (Expr)
1296 and then Suppress_Range_Checks (Entity (Expr))
1300 -- If Expr is part of an assignment statement, then check
1301 -- left side of assignment if it is an entity name.
1303 elsif Nkind (Parnt) = N_Assignment_Statement
1304 and then Is_Entity_Name (Name (Parnt))
1305 and then Suppress_Range_Checks (Entity (Name (Parnt)))
1312 -- Now see if we need a check
1314 if No (Source_Typ) then
1315 S_Typ := Etype (Expr);
1317 S_Typ := Source_Typ;
1320 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1324 Is_Unconstrained_Subscr_Ref :=
1325 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1327 -- Always do a range check if the source type includes infinities
1328 -- and the target type does not include infinities.
1330 if Is_Floating_Point_Type (S_Typ)
1331 and then Has_Infinities (S_Typ)
1332 and then not Has_Infinities (Target_Typ)
1334 Enable_Range_Check (Expr);
1337 -- Return if we know expression is definitely in the range of
1338 -- the target type as determined by Determine_Range. Right now
1339 -- we only do this for discrete types, and not fixed-point or
1340 -- floating-point types.
1342 -- The additional less-precise tests below catch these cases.
1344 -- Note: skip this if we are given a source_typ, since the point
1345 -- of supplying a Source_Typ is to stop us looking at the expression.
1346 -- could sharpen this test to be out parameters only ???
1348 if Is_Discrete_Type (Target_Typ)
1349 and then Is_Discrete_Type (Etype (Expr))
1350 and then not Is_Unconstrained_Subscr_Ref
1351 and then No (Source_Typ)
1354 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1355 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1360 if Compile_Time_Known_Value (Tlo)
1361 and then Compile_Time_Known_Value (Thi)
1363 Determine_Range (Expr, OK, Lo, Hi);
1367 Lov : constant Uint := Expr_Value (Tlo);
1368 Hiv : constant Uint := Expr_Value (Thi);
1371 if Lo >= Lov and then Hi <= Hiv then
1374 elsif Lov > Hi or else Hiv < Lo then
1385 Is_Floating_Point_Type (S_Typ)
1386 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1388 -- Check if we can determine at compile time whether Expr is in the
1389 -- range of the target type. Note that if S_Typ is within the
1390 -- bounds of Target_Typ then this must be the case. This checks is
1391 -- only meaningful if this is not a conversion between integer and
1394 if not Is_Unconstrained_Subscr_Ref
1396 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1398 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1400 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1404 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1408 -- Do not set range checks if they are killed
1410 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
1411 and then Kill_Range_Check (Expr)
1415 -- ??? We only need a runtime check if the target type is constrained
1416 -- (the predefined type Float is not for instance).
1417 -- so the following should really be
1419 -- elsif Is_Constrained (Target_Typ) then
1421 -- but it isn't because certain types do not have the Is_Constrained
1422 -- flag properly set (see 1503-003).
1425 Enable_Range_Check (Expr);
1429 end Apply_Scalar_Range_Check;
1431 ----------------------------------
1432 -- Apply_Selected_Length_Checks --
1433 ----------------------------------
1435 procedure Apply_Selected_Length_Checks
1437 Target_Typ : Entity_Id;
1438 Source_Typ : Entity_Id;
1439 Do_Static : Boolean)
1442 R_Result : Check_Result;
1445 Loc : constant Source_Ptr := Sloc (Ck_Node);
1446 Checks_On : constant Boolean :=
1447 (not Index_Checks_Suppressed (Target_Typ))
1449 (not Length_Checks_Suppressed (Target_Typ));
1452 if not Expander_Active then
1457 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1459 for J in 1 .. 2 loop
1461 R_Cno := R_Result (J);
1462 exit when No (R_Cno);
1464 -- A length check may mention an Itype which is attached to a
1465 -- subsequent node. At the top level in a package this can cause
1466 -- an order-of-elaboration problem, so we make sure that the itype
1467 -- is referenced now.
1469 if Ekind (Current_Scope) = E_Package
1470 and then Is_Compilation_Unit (Current_Scope)
1472 Ensure_Defined (Target_Typ, Ck_Node);
1474 if Present (Source_Typ) then
1475 Ensure_Defined (Source_Typ, Ck_Node);
1477 elsif Is_Itype (Etype (Ck_Node)) then
1478 Ensure_Defined (Etype (Ck_Node), Ck_Node);
1482 -- If the item is a conditional raise of constraint error,
1483 -- then have a look at what check is being performed and
1486 if Nkind (R_Cno) = N_Raise_Constraint_Error
1487 and then Present (Condition (R_Cno))
1489 Cond := Condition (R_Cno);
1491 if not Has_Dynamic_Length_Check (Ck_Node)
1494 Insert_Action (Ck_Node, R_Cno);
1496 if not Do_Static then
1497 Set_Has_Dynamic_Length_Check (Ck_Node);
1501 -- Output a warning if the condition is known to be True
1503 if Is_Entity_Name (Cond)
1504 and then Entity (Cond) = Standard_True
1506 Apply_Compile_Time_Constraint_Error
1507 (Ck_Node, "wrong length for array of}?",
1508 CE_Length_Check_Failed,
1512 -- If we were only doing a static check, or if checks are not
1513 -- on, then we want to delete the check, since it is not needed.
1514 -- We do this by replacing the if statement by a null statement
1516 elsif Do_Static or else not Checks_On then
1517 Rewrite (R_Cno, Make_Null_Statement (Loc));
1521 Install_Static_Check (R_Cno, Loc);
1526 end Apply_Selected_Length_Checks;
1528 ---------------------------------
1529 -- Apply_Selected_Range_Checks --
1530 ---------------------------------
1532 procedure Apply_Selected_Range_Checks
1534 Target_Typ : Entity_Id;
1535 Source_Typ : Entity_Id;
1536 Do_Static : Boolean)
1539 R_Result : Check_Result;
1542 Loc : constant Source_Ptr := Sloc (Ck_Node);
1543 Checks_On : constant Boolean :=
1544 (not Index_Checks_Suppressed (Target_Typ))
1546 (not Range_Checks_Suppressed (Target_Typ));
1549 if not Expander_Active or else not Checks_On then
1554 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1556 for J in 1 .. 2 loop
1558 R_Cno := R_Result (J);
1559 exit when No (R_Cno);
1561 -- If the item is a conditional raise of constraint error,
1562 -- then have a look at what check is being performed and
1565 if Nkind (R_Cno) = N_Raise_Constraint_Error
1566 and then Present (Condition (R_Cno))
1568 Cond := Condition (R_Cno);
1570 if not Has_Dynamic_Range_Check (Ck_Node) then
1571 Insert_Action (Ck_Node, R_Cno);
1573 if not Do_Static then
1574 Set_Has_Dynamic_Range_Check (Ck_Node);
1578 -- Output a warning if the condition is known to be True
1580 if Is_Entity_Name (Cond)
1581 and then Entity (Cond) = Standard_True
1583 -- Since an N_Range is technically not an expression, we
1584 -- have to set one of the bounds to C_E and then just flag
1585 -- the N_Range. The warning message will point to the
1586 -- lower bound and complain about a range, which seems OK.
1588 if Nkind (Ck_Node) = N_Range then
1589 Apply_Compile_Time_Constraint_Error
1590 (Low_Bound (Ck_Node), "static range out of bounds of}?",
1591 CE_Range_Check_Failed,
1595 Set_Raises_Constraint_Error (Ck_Node);
1598 Apply_Compile_Time_Constraint_Error
1599 (Ck_Node, "static value out of range of}?",
1600 CE_Range_Check_Failed,
1605 -- If we were only doing a static check, or if checks are not
1606 -- on, then we want to delete the check, since it is not needed.
1607 -- We do this by replacing the if statement by a null statement
1609 elsif Do_Static or else not Checks_On then
1610 Rewrite (R_Cno, Make_Null_Statement (Loc));
1614 Install_Static_Check (R_Cno, Loc);
1619 end Apply_Selected_Range_Checks;
1621 -------------------------------
1622 -- Apply_Static_Length_Check --
1623 -------------------------------
1625 procedure Apply_Static_Length_Check
1627 Target_Typ : Entity_Id;
1628 Source_Typ : Entity_Id := Empty)
1631 Apply_Selected_Length_Checks
1632 (Expr, Target_Typ, Source_Typ, Do_Static => True);
1633 end Apply_Static_Length_Check;
1635 -------------------------------------
1636 -- Apply_Subscript_Validity_Checks --
1637 -------------------------------------
1639 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
1643 pragma Assert (Nkind (Expr) = N_Indexed_Component);
1645 -- Loop through subscripts
1647 Sub := First (Expressions (Expr));
1648 while Present (Sub) loop
1650 -- Check one subscript. Note that we do not worry about
1651 -- enumeration type with holes, since we will convert the
1652 -- value to a Pos value for the subscript, and that convert
1653 -- will do the necessary validity check.
1655 Ensure_Valid (Sub, Holes_OK => True);
1657 -- Move to next subscript
1661 end Apply_Subscript_Validity_Checks;
1663 ----------------------------------
1664 -- Apply_Type_Conversion_Checks --
1665 ----------------------------------
1667 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
1668 Target_Type : constant Entity_Id := Etype (N);
1669 Target_Base : constant Entity_Id := Base_Type (Target_Type);
1671 Expr : constant Node_Id := Expression (N);
1672 Expr_Type : constant Entity_Id := Etype (Expr);
1675 if Inside_A_Generic then
1678 -- Skip these checks if serious errors detected, there are some nasty
1679 -- situations of incomplete trees that blow things up.
1681 elsif Serious_Errors_Detected > 0 then
1684 -- Scalar type conversions of the form Target_Type (Expr) require
1687 -- - First there is an overflow check to insure that Expr is
1688 -- in the base type of Target_Typ (4.6 (28)),
1690 -- - After we know Expr fits into the base type, we must perform a
1691 -- range check to ensure that Expr meets the constraints of the
1694 elsif Is_Scalar_Type (Target_Type) then
1696 Conv_OK : constant Boolean := Conversion_OK (N);
1697 -- If the Conversion_OK flag on the type conversion is set
1698 -- and no floating point type is involved in the type conversion
1699 -- then fixed point values must be read as integral values.
1704 if not Overflow_Checks_Suppressed (Target_Base)
1705 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
1707 Set_Do_Overflow_Check (N);
1710 if not Range_Checks_Suppressed (Target_Type)
1711 and then not Range_Checks_Suppressed (Expr_Type)
1713 Apply_Scalar_Range_Check
1714 (Expr, Target_Type, Fixed_Int => Conv_OK);
1718 elsif Comes_From_Source (N)
1719 and then Is_Record_Type (Target_Type)
1720 and then Is_Derived_Type (Target_Type)
1721 and then not Is_Tagged_Type (Target_Type)
1722 and then not Is_Constrained (Target_Type)
1723 and then Present (Girder_Constraint (Target_Type))
1725 -- A unconstrained derived type may have inherited discriminants.
1726 -- Build an actual discriminant constraint list using the girder
1727 -- constraint, to verify that the expression of the parent type
1728 -- satisfies the constraints imposed by the (unconstrained!)
1729 -- derived type. This applies to value conversions, not to view
1730 -- conversions of tagged types.
1733 Loc : constant Source_Ptr := Sloc (N);
1735 Constraint : Elmt_Id;
1736 Discr_Value : Node_Id;
1738 New_Constraints : Elist_Id := New_Elmt_List;
1739 Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type);
1742 Constraint := First_Elmt (Girder_Constraint (Target_Type));
1744 while Present (Constraint) loop
1745 Discr_Value := Node (Constraint);
1747 if Is_Entity_Name (Discr_Value)
1748 and then Ekind (Entity (Discr_Value)) = E_Discriminant
1750 Discr := Corresponding_Discriminant (Entity (Discr_Value));
1753 and then Scope (Discr) = Base_Type (Expr_Type)
1755 -- Parent is constrained by new discriminant. Obtain
1756 -- Value of original discriminant in expression. If
1757 -- the new discriminant has been used to constrain more
1758 -- than one of the girder ones, this will provide the
1759 -- required consistency check.
1762 Make_Selected_Component (Loc,
1764 Duplicate_Subexpr (Expr, Name_Req => True),
1766 Make_Identifier (Loc, Chars (Discr))),
1770 -- Discriminant of more remote ancestor ???
1775 -- Derived type definition has an explicit value for
1776 -- this girder discriminant.
1780 (Duplicate_Subexpr (Discr_Value), New_Constraints);
1783 Next_Elmt (Constraint);
1786 -- Use the unconstrained expression type to retrieve the
1787 -- discriminants of the parent, and apply momentarily the
1788 -- discriminant constraint synthesized above.
1790 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
1791 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
1792 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
1795 Make_Raise_Constraint_Error (Loc,
1797 Reason => CE_Discriminant_Check_Failed));
1800 -- should there be other checks here for array types ???
1806 end Apply_Type_Conversion_Checks;
1808 ----------------------------------------------
1809 -- Apply_Universal_Integer_Attribute_Checks --
1810 ----------------------------------------------
1812 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
1813 Loc : constant Source_Ptr := Sloc (N);
1814 Typ : constant Entity_Id := Etype (N);
1817 if Inside_A_Generic then
1820 -- Nothing to do if checks are suppressed
1822 elsif Range_Checks_Suppressed (Typ)
1823 and then Overflow_Checks_Suppressed (Typ)
1827 -- Nothing to do if the attribute does not come from source. The
1828 -- internal attributes we generate of this type do not need checks,
1829 -- and furthermore the attempt to check them causes some circular
1830 -- elaboration orders when dealing with packed types.
1832 elsif not Comes_From_Source (N) then
1835 -- Otherwise, replace the attribute node with a type conversion
1836 -- node whose expression is the attribute, retyped to universal
1837 -- integer, and whose subtype mark is the target type. The call
1838 -- to analyze this conversion will set range and overflow checks
1839 -- as required for proper detection of an out of range value.
1842 Set_Etype (N, Universal_Integer);
1843 Set_Analyzed (N, True);
1846 Make_Type_Conversion (Loc,
1847 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1848 Expression => Relocate_Node (N)));
1850 Analyze_And_Resolve (N, Typ);
1854 end Apply_Universal_Integer_Attribute_Checks;
1856 -------------------------------
1857 -- Build_Discriminant_Checks --
1858 -------------------------------
1860 function Build_Discriminant_Checks
1865 Loc : constant Source_Ptr := Sloc (N);
1868 Disc_Ent : Entity_Id;
1873 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
1875 -- For a fully private type, use the discriminants of the parent
1878 if Is_Private_Type (T_Typ)
1879 and then No (Full_View (T_Typ))
1881 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
1883 Disc_Ent := First_Discriminant (T_Typ);
1886 while Present (Disc) loop
1888 Dval := Node (Disc);
1890 if Nkind (Dval) = N_Identifier
1891 and then Ekind (Entity (Dval)) = E_Discriminant
1893 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
1895 Dval := Duplicate_Subexpr (Dval);
1898 Evolve_Or_Else (Cond,
1901 Make_Selected_Component (Loc,
1903 Duplicate_Subexpr (N, Name_Req => True),
1905 Make_Identifier (Loc, Chars (Disc_Ent))),
1906 Right_Opnd => Dval));
1909 Next_Discriminant (Disc_Ent);
1913 end Build_Discriminant_Checks;
1915 -----------------------------------
1916 -- Check_Valid_Lvalue_Subscripts --
1917 -----------------------------------
1919 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
1921 -- Skip this if range checks are suppressed
1923 if Range_Checks_Suppressed (Etype (Expr)) then
1926 -- Only do this check for expressions that come from source. We
1927 -- assume that expander generated assignments explicitly include
1928 -- any necessary checks. Note that this is not just an optimization,
1929 -- it avoids infinite recursions!
1931 elsif not Comes_From_Source (Expr) then
1934 -- For a selected component, check the prefix
1936 elsif Nkind (Expr) = N_Selected_Component then
1937 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1940 -- Case of indexed component
1942 elsif Nkind (Expr) = N_Indexed_Component then
1943 Apply_Subscript_Validity_Checks (Expr);
1945 -- Prefix may itself be or contain an indexed component, and
1946 -- these subscripts need checking as well
1948 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1950 end Check_Valid_Lvalue_Subscripts;
1952 ---------------------
1953 -- Determine_Range --
1954 ---------------------
1956 Cache_Size : constant := 2 ** 10;
1957 type Cache_Index is range 0 .. Cache_Size - 1;
1958 -- Determine size of below cache (power of 2 is more efficient!)
1960 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
1961 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
1962 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
1963 -- The above arrays are used to implement a small direct cache
1964 -- for Determine_Range calls. Because of the way Determine_Range
1965 -- recursively traces subexpressions, and because overflow checking
1966 -- calls the routine on the way up the tree, a quadratic behavior
1967 -- can otherwise be encountered in large expressions. The cache
1968 -- entry for node N is stored in the (N mod Cache_Size) entry, and
1969 -- can be validated by checking the actual node value stored there.
1971 procedure Determine_Range
1977 Typ : constant Entity_Id := Etype (N);
1981 -- Lo and Hi bounds of left operand
1985 -- Lo and Hi bounds of right (or only) operand
1988 -- Temp variable used to hold a bound node
1991 -- High bound of base type of expression
1995 -- Refined values for low and high bounds, after tightening
1998 -- Used in lower level calls to indicate if call succeeded
2000 Cindex : Cache_Index;
2001 -- Used to search cache
2003 function OK_Operands return Boolean;
2004 -- Used for binary operators. Determines the ranges of the left and
2005 -- right operands, and if they are both OK, returns True, and puts
2006 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2012 function OK_Operands return Boolean is
2014 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
2020 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2024 -- Start of processing for Determine_Range
2027 -- Prevent junk warnings by initializing range variables
2034 -- If the type is not discrete, or is undefined, then we can't
2035 -- do anything about determining the range.
2037 if No (Typ) or else not Is_Discrete_Type (Typ)
2038 or else Error_Posted (N)
2044 -- For all other cases, we can determine the range
2048 -- If value is compile time known, then the possible range is the
2049 -- one value that we know this expression definitely has!
2051 if Compile_Time_Known_Value (N) then
2052 Lo := Expr_Value (N);
2057 -- Return if already in the cache
2059 Cindex := Cache_Index (N mod Cache_Size);
2061 if Determine_Range_Cache_N (Cindex) = N then
2062 Lo := Determine_Range_Cache_Lo (Cindex);
2063 Hi := Determine_Range_Cache_Hi (Cindex);
2067 -- Otherwise, start by finding the bounds of the type of the
2068 -- expression, the value cannot be outside this range (if it
2069 -- is, then we have an overflow situation, which is a separate
2070 -- check, we are talking here only about the expression value).
2072 -- We use the actual bound unless it is dynamic, in which case
2073 -- use the corresponding base type bound if possible. If we can't
2074 -- get a bound then we figure we can't determine the range (a
2075 -- peculiar case, that perhaps cannot happen, but there is no
2076 -- point in bombing in this optimization circuit.
2078 -- First the low bound
2080 Bound := Type_Low_Bound (Typ);
2082 if Compile_Time_Known_Value (Bound) then
2083 Lo := Expr_Value (Bound);
2085 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
2086 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
2093 -- Now the high bound
2095 Bound := Type_High_Bound (Typ);
2097 -- We need the high bound of the base type later on, and this should
2098 -- always be compile time known. Again, it is not clear that this
2099 -- can ever be false, but no point in bombing.
2101 if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
2102 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2110 -- If we have a static subtype, then that may have a tighter bound
2111 -- so use the upper bound of the subtype instead in this case.
2113 if Compile_Time_Known_Value (Bound) then
2114 Hi := Expr_Value (Bound);
2117 -- We may be able to refine this value in certain situations. If
2118 -- refinement is possible, then Lor and Hir are set to possibly
2119 -- tighter bounds, and OK1 is set to True.
2123 -- For unary plus, result is limited by range of operand
2126 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2128 -- For unary minus, determine range of operand, and negate it
2131 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2138 -- For binary addition, get range of each operand and do the
2139 -- addition to get the result range.
2143 Lor := Lo_Left + Lo_Right;
2144 Hir := Hi_Left + Hi_Right;
2147 -- Division is tricky. The only case we consider is where the
2148 -- right operand is a positive constant, and in this case we
2149 -- simply divide the bounds of the left operand
2153 if Lo_Right = Hi_Right
2154 and then Lo_Right > 0
2156 Lor := Lo_Left / Lo_Right;
2157 Hir := Hi_Left / Lo_Right;
2164 -- For binary subtraction, get range of each operand and do
2165 -- the worst case subtraction to get the result range.
2167 when N_Op_Subtract =>
2169 Lor := Lo_Left - Hi_Right;
2170 Hir := Hi_Left - Lo_Right;
2173 -- For MOD, if right operand is a positive constant, then
2174 -- result must be in the allowable range of mod results.
2178 if Lo_Right = Hi_Right then
2179 if Lo_Right > 0 then
2181 Hir := Lo_Right - 1;
2183 elsif Lo_Right < 0 then
2184 Lor := Lo_Right + 1;
2193 -- For REM, if right operand is a positive constant, then
2194 -- result must be in the allowable range of mod results.
2198 if Lo_Right = Hi_Right then
2200 Dval : constant Uint := (abs Lo_Right) - 1;
2203 -- The sign of the result depends on the sign of the
2204 -- dividend (but not on the sign of the divisor, hence
2205 -- the abs operation above).
2225 -- Attribute reference cases
2227 when N_Attribute_Reference =>
2228 case Attribute_Name (N) is
2230 -- For Pos/Val attributes, we can refine the range using the
2231 -- possible range of values of the attribute expression
2233 when Name_Pos | Name_Val =>
2234 Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
2236 -- For Length attribute, use the bounds of the corresponding
2237 -- index type to refine the range.
2241 Atyp : Entity_Id := Etype (Prefix (N));
2249 if Is_Access_Type (Atyp) then
2250 Atyp := Designated_Type (Atyp);
2253 -- For string literal, we know exact value
2255 if Ekind (Atyp) = E_String_Literal_Subtype then
2257 Lo := String_Literal_Length (Atyp);
2258 Hi := String_Literal_Length (Atyp);
2262 -- Otherwise check for expression given
2264 if No (Expressions (N)) then
2268 UI_To_Int (Expr_Value (First (Expressions (N))));
2271 Indx := First_Index (Atyp);
2272 for J in 2 .. Inum loop
2273 Indx := Next_Index (Indx);
2277 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
2281 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
2285 -- The maximum value for Length is the biggest
2286 -- possible gap between the values of the bounds.
2287 -- But of course, this value cannot be negative.
2289 Hir := UI_Max (Uint_0, UU - LL);
2291 -- For constrained arrays, the minimum value for
2292 -- Length is taken from the actual value of the
2293 -- bounds, since the index will be exactly of
2296 if Is_Constrained (Atyp) then
2297 Lor := UI_Max (Uint_0, UL - LU);
2299 -- For an unconstrained array, the minimum value
2300 -- for length is always zero.
2309 -- No special handling for other attributes
2310 -- Probably more opportunities exist here ???
2317 -- For type conversion from one discrete type to another, we
2318 -- can refine the range using the converted value.
2320 when N_Type_Conversion =>
2321 Determine_Range (Expression (N), OK1, Lor, Hir);
2323 -- Nothing special to do for all other expression kinds
2331 -- At this stage, if OK1 is true, then we know that the actual
2332 -- result of the computed expression is in the range Lor .. Hir.
2333 -- We can use this to restrict the possible range of results.
2337 -- If the refined value of the low bound is greater than the
2338 -- type high bound, then reset it to the more restrictive
2339 -- value. However, we do NOT do this for the case of a modular
2340 -- type where the possible upper bound on the value is above the
2341 -- base type high bound, because that means the result could wrap.
2344 and then not (Is_Modular_Integer_Type (Typ)
2345 and then Hir > Hbound)
2350 -- Similarly, if the refined value of the high bound is less
2351 -- than the value so far, then reset it to the more restrictive
2352 -- value. Again, we do not do this if the refined low bound is
2353 -- negative for a modular type, since this would wrap.
2356 and then not (Is_Modular_Integer_Type (Typ)
2357 and then Lor < Uint_0)
2363 -- Set cache entry for future call and we are all done
2365 Determine_Range_Cache_N (Cindex) := N;
2366 Determine_Range_Cache_Lo (Cindex) := Lo;
2367 Determine_Range_Cache_Hi (Cindex) := Hi;
2370 -- If any exception occurs, it means that we have some bug in the compiler
2371 -- possibly triggered by a previous error, or by some unforseen peculiar
2372 -- occurrence. However, this is only an optimization attempt, so there is
2373 -- really no point in crashing the compiler. Instead we just decide, too
2374 -- bad, we can't figure out a range in this case after all.
2379 -- Debug flag K disables this behavior (useful for debugging)
2381 if Debug_Flag_K then
2390 end Determine_Range;
2392 ------------------------------------
2393 -- Discriminant_Checks_Suppressed --
2394 ------------------------------------
2396 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
2398 return Scope_Suppress.Discriminant_Checks
2399 or else (Present (E) and then Suppress_Discriminant_Checks (E));
2400 end Discriminant_Checks_Suppressed;
2402 --------------------------------
2403 -- Division_Checks_Suppressed --
2404 --------------------------------
2406 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
2408 return Scope_Suppress.Division_Checks
2409 or else (Present (E) and then Suppress_Division_Checks (E));
2410 end Division_Checks_Suppressed;
2412 -----------------------------------
2413 -- Elaboration_Checks_Suppressed --
2414 -----------------------------------
2416 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
2418 return Scope_Suppress.Elaboration_Checks
2419 or else (Present (E) and then Suppress_Elaboration_Checks (E));
2420 end Elaboration_Checks_Suppressed;
2422 ------------------------
2423 -- Enable_Range_Check --
2424 ------------------------
2426 procedure Enable_Range_Check (N : Node_Id) is
2428 if Nkind (N) = N_Unchecked_Type_Conversion
2429 and then Kill_Range_Check (N)
2433 Set_Do_Range_Check (N, True);
2435 end Enable_Range_Check;
2441 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
2442 Typ : constant Entity_Id := Etype (Expr);
2445 -- Ignore call if we are not doing any validity checking
2447 if not Validity_Checks_On then
2450 -- No check required if expression is from the expander, we assume
2451 -- the expander will generate whatever checks are needed. Note that
2452 -- this is not just an optimization, it avoids infinite recursions!
2454 -- Unchecked conversions must be checked, unless they are initialized
2455 -- scalar values, as in a component assignment in an init_proc.
2457 elsif not Comes_From_Source (Expr)
2458 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
2459 or else Kill_Range_Check (Expr))
2463 -- No check required if expression is known to have valid value
2465 elsif Expr_Known_Valid (Expr) then
2468 -- No check required if checks off
2470 elsif Range_Checks_Suppressed (Typ) then
2473 -- Ignore case of enumeration with holes where the flag is set not
2474 -- to worry about holes, since no special validity check is needed
2476 elsif Is_Enumeration_Type (Typ)
2477 and then Has_Non_Standard_Rep (Typ)
2482 -- No check required on the left-hand side of an assignment.
2484 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
2485 and then Expr = Name (Parent (Expr))
2489 -- An annoying special case. If this is an out parameter of a scalar
2490 -- type, then the value is not going to be accessed, therefore it is
2491 -- inappropriate to do any validity check at the call site.
2494 -- Only need to worry about scalar types
2496 if Is_Scalar_Type (Typ) then
2506 -- Find actual argument (which may be a parameter association)
2507 -- and the parent of the actual argument (the call statement)
2512 if Nkind (P) = N_Parameter_Association then
2517 -- Only need to worry if we are argument of a procedure
2518 -- call since functions don't have out parameters.
2520 if Nkind (P) = N_Procedure_Call_Statement then
2521 L := Parameter_Associations (P);
2522 E := Entity (Name (P));
2524 -- Only need to worry if there are indeed actuals, and
2525 -- if this could be a procedure call, otherwise we cannot
2526 -- get a match (either we are not an argument, or the
2527 -- mode of the formal is not OUT). This test also filters
2528 -- out the generic case.
2530 if Is_Non_Empty_List (L)
2531 and then Is_Subprogram (E)
2533 -- This is the loop through parameters, looking to
2534 -- see if there is an OUT parameter for which we are
2537 F := First_Formal (E);
2540 while Present (F) loop
2541 if Ekind (F) = E_Out_Parameter and then A = N then
2554 -- If we fall through, a validity check is required. Note that it would
2555 -- not be good to set Do_Range_Check, even in contexts where this is
2556 -- permissible, since this flag causes checking against the target type,
2557 -- not the source type in contexts such as assignments
2559 Insert_Valid_Check (Expr);
2562 ----------------------
2563 -- Expr_Known_Valid --
2564 ----------------------
2566 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
2567 Typ : constant Entity_Id := Etype (Expr);
2570 -- Non-scalar types are always consdered valid, since they never
2571 -- give rise to the issues of erroneous or bounded error behavior
2572 -- that are the concern. In formal reference manual terms the
2573 -- notion of validity only applies to scalar types.
2575 if not Is_Scalar_Type (Typ) then
2578 -- If no validity checking, then everything is considered valid
2580 elsif not Validity_Checks_On then
2583 -- Floating-point types are considered valid unless floating-point
2584 -- validity checks have been specifically turned on.
2586 elsif Is_Floating_Point_Type (Typ)
2587 and then not Validity_Check_Floating_Point
2591 -- If the expression is the value of an object that is known to
2592 -- be valid, then clearly the expression value itself is valid.
2594 elsif Is_Entity_Name (Expr)
2595 and then Is_Known_Valid (Entity (Expr))
2599 -- If the type is one for which all values are known valid, then
2600 -- we are sure that the value is valid except in the slightly odd
2601 -- case where the expression is a reference to a variable whose size
2602 -- has been explicitly set to a value greater than the object size.
2604 elsif Is_Known_Valid (Typ) then
2605 if Is_Entity_Name (Expr)
2606 and then Ekind (Entity (Expr)) = E_Variable
2607 and then Esize (Entity (Expr)) > Esize (Typ)
2614 -- Integer and character literals always have valid values, where
2615 -- appropriate these will be range checked in any case.
2617 elsif Nkind (Expr) = N_Integer_Literal
2619 Nkind (Expr) = N_Character_Literal
2623 -- If we have a type conversion or a qualification of a known valid
2624 -- value, then the result will always be valid.
2626 elsif Nkind (Expr) = N_Type_Conversion
2628 Nkind (Expr) = N_Qualified_Expression
2630 return Expr_Known_Valid (Expression (Expr));
2632 -- The result of any function call or operator is always considered
2633 -- valid, since we assume the necessary checks are done by the call.
2635 elsif Nkind (Expr) in N_Binary_Op
2637 Nkind (Expr) in N_Unary_Op
2639 Nkind (Expr) = N_Function_Call
2643 -- For all other cases, we do not know the expression is valid
2648 end Expr_Known_Valid;
2650 ---------------------
2651 -- Get_Discriminal --
2652 ---------------------
2654 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
2655 Loc : constant Source_Ptr := Sloc (E);
2660 -- The entity E is the type of a private component of the protected
2661 -- type, or the type of a renaming of that component within a protected
2662 -- operation of that type.
2666 if Ekind (Sc) /= E_Protected_Type then
2669 if Ekind (Sc) /= E_Protected_Type then
2674 D := First_Discriminant (Sc);
2677 and then Chars (D) /= Chars (Bound)
2679 Next_Discriminant (D);
2682 return New_Occurrence_Of (Discriminal (D), Loc);
2683 end Get_Discriminal;
2689 function Guard_Access
2696 if Nkind (Cond) = N_Or_Else then
2697 Set_Paren_Count (Cond, 1);
2700 if Nkind (Ck_Node) = N_Allocator then
2707 Left_Opnd => Duplicate_Subexpr (Ck_Node),
2708 Right_Opnd => Make_Null (Loc)),
2709 Right_Opnd => Cond);
2713 -----------------------------
2714 -- Index_Checks_Suppressed --
2715 -----------------------------
2717 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
2719 return Scope_Suppress.Index_Checks
2720 or else (Present (E) and then Suppress_Index_Checks (E));
2721 end Index_Checks_Suppressed;
2727 procedure Initialize is
2729 for J in Determine_Range_Cache_N'Range loop
2730 Determine_Range_Cache_N (J) := Empty;
2734 -------------------------
2735 -- Insert_Range_Checks --
2736 -------------------------
2738 procedure Insert_Range_Checks
2739 (Checks : Check_Result;
2741 Suppress_Typ : Entity_Id;
2742 Static_Sloc : Source_Ptr := No_Location;
2743 Flag_Node : Node_Id := Empty;
2744 Do_Before : Boolean := False)
2746 Internal_Flag_Node : Node_Id := Flag_Node;
2747 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
2749 Check_Node : Node_Id;
2750 Checks_On : constant Boolean :=
2751 (not Index_Checks_Suppressed (Suppress_Typ))
2753 (not Range_Checks_Suppressed (Suppress_Typ));
2756 -- For now we just return if Checks_On is false, however this should
2757 -- be enhanced to check for an always True value in the condition
2758 -- and to generate a compilation warning???
2760 if not Expander_Active or else not Checks_On then
2764 if Static_Sloc = No_Location then
2765 Internal_Static_Sloc := Sloc (Node);
2768 if No (Flag_Node) then
2769 Internal_Flag_Node := Node;
2772 for J in 1 .. 2 loop
2773 exit when No (Checks (J));
2775 if Nkind (Checks (J)) = N_Raise_Constraint_Error
2776 and then Present (Condition (Checks (J)))
2778 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
2779 Check_Node := Checks (J);
2780 Mark_Rewrite_Insertion (Check_Node);
2783 Insert_Before_And_Analyze (Node, Check_Node);
2785 Insert_After_And_Analyze (Node, Check_Node);
2788 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
2793 Make_Raise_Constraint_Error (Internal_Static_Sloc,
2794 Reason => CE_Range_Check_Failed);
2795 Mark_Rewrite_Insertion (Check_Node);
2798 Insert_Before_And_Analyze (Node, Check_Node);
2800 Insert_After_And_Analyze (Node, Check_Node);
2804 end Insert_Range_Checks;
2806 ------------------------
2807 -- Insert_Valid_Check --
2808 ------------------------
2810 procedure Insert_Valid_Check (Expr : Node_Id) is
2811 Loc : constant Source_Ptr := Sloc (Expr);
2815 -- Do not insert if checks off, or if not checking validity
2817 if Range_Checks_Suppressed (Etype (Expr))
2818 or else (not Validity_Checks_On)
2823 -- If we have a checked conversion, then validity check applies to
2824 -- the expression inside the conversion, not the result, since if
2825 -- the expression inside is valid, then so is the conversion result.
2828 while Nkind (Exp) = N_Type_Conversion loop
2829 Exp := Expression (Exp);
2832 -- Insert the validity check. Note that we do this with validity
2833 -- checks turned off, to avoid recursion, we do not want validity
2834 -- checks on the validity checking code itself!
2836 Validity_Checks_On := False;
2839 Make_Raise_Constraint_Error (Loc,
2843 Make_Attribute_Reference (Loc,
2845 Duplicate_Subexpr (Exp, Name_Req => True),
2846 Attribute_Name => Name_Valid)),
2847 Reason => CE_Invalid_Data),
2848 Suppress => All_Checks);
2849 Validity_Checks_On := True;
2850 end Insert_Valid_Check;
2852 --------------------------
2853 -- Install_Static_Check --
2854 --------------------------
2856 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
2857 Stat : constant Boolean := Is_Static_Expression (R_Cno);
2858 Typ : constant Entity_Id := Etype (R_Cno);
2862 Make_Raise_Constraint_Error (Loc,
2863 Reason => CE_Range_Check_Failed));
2864 Set_Analyzed (R_Cno);
2865 Set_Etype (R_Cno, Typ);
2866 Set_Raises_Constraint_Error (R_Cno);
2867 Set_Is_Static_Expression (R_Cno, Stat);
2868 end Install_Static_Check;
2870 ------------------------------
2871 -- Length_Checks_Suppressed --
2872 ------------------------------
2874 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
2876 return Scope_Suppress.Length_Checks
2877 or else (Present (E) and then Suppress_Length_Checks (E));
2878 end Length_Checks_Suppressed;
2880 --------------------------------
2881 -- Overflow_Checks_Suppressed --
2882 --------------------------------
2884 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
2886 return Scope_Suppress.Overflow_Checks
2887 or else (Present (E) and then Suppress_Overflow_Checks (E));
2888 end Overflow_Checks_Suppressed;
2894 function Range_Check
2896 Target_Typ : Entity_Id;
2897 Source_Typ : Entity_Id := Empty;
2898 Warn_Node : Node_Id := Empty)
2902 return Selected_Range_Checks
2903 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
2906 -----------------------------
2907 -- Range_Checks_Suppressed --
2908 -----------------------------
2910 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
2912 -- Note: for now we always suppress range checks on Vax float types,
2913 -- since Gigi does not know how to generate these checks.
2915 return Scope_Suppress.Range_Checks
2916 or else (Present (E) and then Suppress_Range_Checks (E))
2917 or else Vax_Float (E);
2918 end Range_Checks_Suppressed;
2924 procedure Remove_Checks (Expr : Node_Id) is
2925 Discard : Traverse_Result;
2927 function Process (N : Node_Id) return Traverse_Result;
2928 -- Process a single node during the traversal
2930 function Traverse is new Traverse_Func (Process);
2931 -- The traversal function itself
2937 function Process (N : Node_Id) return Traverse_Result is
2939 if Nkind (N) not in N_Subexpr then
2943 Set_Do_Range_Check (N, False);
2947 Discard := Traverse (Left_Opnd (N));
2950 when N_Attribute_Reference =>
2951 Set_Do_Access_Check (N, False);
2952 Set_Do_Overflow_Check (N, False);
2954 when N_Explicit_Dereference =>
2955 Set_Do_Access_Check (N, False);
2957 when N_Function_Call =>
2958 Set_Do_Tag_Check (N, False);
2960 when N_Indexed_Component =>
2961 Set_Do_Access_Check (N, False);
2964 Set_Do_Overflow_Check (N, False);
2968 Set_Do_Division_Check (N, False);
2971 Set_Do_Length_Check (N, False);
2974 Set_Do_Division_Check (N, False);
2977 Set_Do_Length_Check (N, False);
2980 Set_Do_Division_Check (N, False);
2983 Set_Do_Length_Check (N, False);
2990 Discard := Traverse (Left_Opnd (N));
2993 when N_Selected_Component =>
2994 Set_Do_Access_Check (N, False);
2995 Set_Do_Discriminant_Check (N, False);
2998 Set_Do_Access_Check (N, False);
3000 when N_Type_Conversion =>
3001 Set_Do_Length_Check (N, False);
3002 Set_Do_Overflow_Check (N, False);
3003 Set_Do_Tag_Check (N, False);
3012 -- Start of processing for Remove_Checks
3015 Discard := Traverse (Expr);
3018 ----------------------------
3019 -- Selected_Length_Checks --
3020 ----------------------------
3022 function Selected_Length_Checks
3024 Target_Typ : Entity_Id;
3025 Source_Typ : Entity_Id;
3026 Warn_Node : Node_Id)
3029 Loc : constant Source_Ptr := Sloc (Ck_Node);
3032 Expr_Actual : Node_Id;
3034 Cond : Node_Id := Empty;
3035 Do_Access : Boolean := False;
3036 Wnode : Node_Id := Warn_Node;
3037 Ret_Result : Check_Result := (Empty, Empty);
3038 Num_Checks : Natural := 0;
3040 procedure Add_Check (N : Node_Id);
3041 -- Adds the action given to Ret_Result if N is non-Empty
3043 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
3044 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
3046 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
3047 -- True for equal literals and for nodes that denote the same constant
3048 -- entity, even if its value is not a static constant. This includes the
3049 -- case of a discriminal reference within an init_proc. Removes some
3050 -- obviously superfluous checks.
3052 function Length_E_Cond
3053 (Exptyp : Entity_Id;
3057 -- Returns expression to compute:
3058 -- Typ'Length /= Exptyp'Length
3060 function Length_N_Cond
3065 -- Returns expression to compute:
3066 -- Typ'Length /= Expr'Length
3072 procedure Add_Check (N : Node_Id) is
3076 -- For now, ignore attempt to place more than 2 checks ???
3078 if Num_Checks = 2 then
3082 pragma Assert (Num_Checks <= 1);
3083 Num_Checks := Num_Checks + 1;
3084 Ret_Result (Num_Checks) := N;
3092 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
3094 E1 : Entity_Id := E;
3095 Pt : Entity_Id := Scope (Scope (E));
3098 if Ekind (Scope (E)) = E_Record_Type
3099 and then Has_Discriminants (Scope (E))
3101 N := Build_Discriminal_Subtype_Of_Component (E);
3104 Insert_Action (Ck_Node, N);
3105 E1 := Defining_Identifier (N);
3109 if Ekind (E1) = E_String_Literal_Subtype then
3111 Make_Integer_Literal (Loc,
3112 Intval => String_Literal_Length (E1));
3114 elsif Ekind (Pt) = E_Protected_Type
3115 and then Has_Discriminants (Pt)
3116 and then Has_Completion (Pt)
3117 and then not Inside_Init_Proc
3120 -- If the type whose length is needed is a private component
3121 -- constrained by a discriminant, we must expand the 'Length
3122 -- attribute into an explicit computation, using the discriminal
3123 -- of the current protected operation. This is because the actual
3124 -- type of the prival is constructed after the protected opera-
3125 -- tion has been fully expanded.
3128 Indx_Type : Node_Id;
3131 Do_Expand : Boolean := False;
3134 Indx_Type := First_Index (E);
3136 for J in 1 .. Indx - 1 loop
3137 Next_Index (Indx_Type);
3140 Get_Index_Bounds (Indx_Type, Lo, Hi);
3142 if Nkind (Lo) = N_Identifier
3143 and then Ekind (Entity (Lo)) = E_In_Parameter
3145 Lo := Get_Discriminal (E, Lo);
3149 if Nkind (Hi) = N_Identifier
3150 and then Ekind (Entity (Hi)) = E_In_Parameter
3152 Hi := Get_Discriminal (E, Hi);
3157 if not Is_Entity_Name (Lo) then
3158 Lo := Duplicate_Subexpr (Lo);
3161 if not Is_Entity_Name (Hi) then
3162 Lo := Duplicate_Subexpr (Hi);
3168 Make_Op_Subtract (Loc,
3172 Right_Opnd => Make_Integer_Literal (Loc, 1));
3177 Make_Attribute_Reference (Loc,
3178 Attribute_Name => Name_Length,
3180 New_Occurrence_Of (E1, Loc));
3183 Set_Expressions (N, New_List (
3184 Make_Integer_Literal (Loc, Indx)));
3193 Make_Attribute_Reference (Loc,
3194 Attribute_Name => Name_Length,
3196 New_Occurrence_Of (E1, Loc));
3199 Set_Expressions (N, New_List (
3200 Make_Integer_Literal (Loc, Indx)));
3212 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
3215 Make_Attribute_Reference (Loc,
3216 Attribute_Name => Name_Length,
3218 Duplicate_Subexpr (N, Name_Req => True),
3219 Expressions => New_List (
3220 Make_Integer_Literal (Loc, Indx)));
3228 function Length_E_Cond
3229 (Exptyp : Entity_Id;
3237 Left_Opnd => Get_E_Length (Typ, Indx),
3238 Right_Opnd => Get_E_Length (Exptyp, Indx));
3246 function Length_N_Cond
3255 Left_Opnd => Get_E_Length (Typ, Indx),
3256 Right_Opnd => Get_N_Length (Expr, Indx));
3260 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
3263 (Nkind (L) = N_Integer_Literal
3264 and then Nkind (R) = N_Integer_Literal
3265 and then Intval (L) = Intval (R))
3269 and then Ekind (Entity (L)) = E_Constant
3270 and then ((Is_Entity_Name (R)
3271 and then Entity (L) = Entity (R))
3273 (Nkind (R) = N_Type_Conversion
3274 and then Is_Entity_Name (Expression (R))
3275 and then Entity (L) = Entity (Expression (R)))))
3279 and then Ekind (Entity (R)) = E_Constant
3280 and then Nkind (L) = N_Type_Conversion
3281 and then Is_Entity_Name (Expression (L))
3282 and then Entity (R) = Entity (Expression (L)))
3286 and then Is_Entity_Name (R)
3287 and then Entity (L) = Entity (R)
3288 and then Ekind (Entity (L)) = E_In_Parameter
3289 and then Inside_Init_Proc);
3292 -- Start of processing for Selected_Length_Checks
3295 if not Expander_Active then
3299 if Target_Typ = Any_Type
3300 or else Target_Typ = Any_Composite
3301 or else Raises_Constraint_Error (Ck_Node)
3310 T_Typ := Target_Typ;
3312 if No (Source_Typ) then
3313 S_Typ := Etype (Ck_Node);
3315 S_Typ := Source_Typ;
3318 if S_Typ = Any_Type or else S_Typ = Any_Composite then
3322 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3323 S_Typ := Designated_Type (S_Typ);
3324 T_Typ := Designated_Type (T_Typ);
3327 -- A simple optimization
3329 if Nkind (Ck_Node) = N_Null then
3334 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
3335 if Is_Constrained (T_Typ) then
3337 -- The checking code to be generated will freeze the
3338 -- corresponding array type. However, we must freeze the
3339 -- type now, so that the freeze node does not appear within
3340 -- the generated condional expression, but ahead of it.
3342 Freeze_Before (Ck_Node, T_Typ);
3344 Expr_Actual := Get_Referenced_Object (Ck_Node);
3345 Exptyp := Get_Actual_Subtype (Expr_Actual);
3347 if Is_Access_Type (Exptyp) then
3348 Exptyp := Designated_Type (Exptyp);
3351 -- String_Literal case. This needs to be handled specially be-
3352 -- cause no index types are available for string literals. The
3353 -- condition is simply:
3355 -- T_Typ'Length = string-literal-length
3357 if Nkind (Expr_Actual) = N_String_Literal then
3360 Left_Opnd => Get_E_Length (T_Typ, 1),
3362 Make_Integer_Literal (Loc,
3364 String_Literal_Length (Etype (Expr_Actual))));
3366 -- General array case. Here we have a usable actual subtype for
3367 -- the expression, and the condition is built from the two types
3370 -- T_Typ'Length /= Exptyp'Length or else
3371 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
3372 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
3375 elsif Is_Constrained (Exptyp) then
3379 Ndims : Nat := Number_Dimensions (T_Typ);
3390 L_Index := First_Index (T_Typ);
3391 R_Index := First_Index (Exptyp);
3393 for Indx in 1 .. Ndims loop
3394 if not (Nkind (L_Index) = N_Raise_Constraint_Error
3396 Nkind (R_Index) = N_Raise_Constraint_Error)
3398 Get_Index_Bounds (L_Index, L_Low, L_High);
3399 Get_Index_Bounds (R_Index, R_Low, R_High);
3401 -- Deal with compile time length check. Note that we
3402 -- skip this in the access case, because the access
3403 -- value may be null, so we cannot know statically.
3406 and then Compile_Time_Known_Value (L_Low)
3407 and then Compile_Time_Known_Value (L_High)
3408 and then Compile_Time_Known_Value (R_Low)
3409 and then Compile_Time_Known_Value (R_High)
3411 if Expr_Value (L_High) >= Expr_Value (L_Low) then
3412 L_Length := Expr_Value (L_High) -
3413 Expr_Value (L_Low) + 1;
3415 L_Length := UI_From_Int (0);
3418 if Expr_Value (R_High) >= Expr_Value (R_Low) then
3419 R_Length := Expr_Value (R_High) -
3420 Expr_Value (R_Low) + 1;
3422 R_Length := UI_From_Int (0);
3425 if L_Length > R_Length then
3427 (Compile_Time_Constraint_Error
3428 (Wnode, "too few elements for}?", T_Typ));
3430 elsif L_Length < R_Length then
3432 (Compile_Time_Constraint_Error
3433 (Wnode, "too many elements for}?", T_Typ));
3436 -- The comparison for an individual index subtype
3437 -- is omitted if the corresponding index subtypes
3438 -- statically match, since the result is known to
3439 -- be true. Note that this test is worth while even
3440 -- though we do static evaluation, because non-static
3441 -- subtypes can statically match.
3444 Subtypes_Statically_Match
3445 (Etype (L_Index), Etype (R_Index))
3448 (Same_Bounds (L_Low, R_Low)
3449 and then Same_Bounds (L_High, R_High))
3452 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
3461 -- Handle cases where we do not get a usable actual subtype that
3462 -- is constrained. This happens for example in the function call
3463 -- and explicit dereference cases. In these cases, we have to get
3464 -- the length or range from the expression itself, making sure we
3465 -- do not evaluate it more than once.
3467 -- Here Ck_Node is the original expression, or more properly the
3468 -- result of applying Duplicate_Expr to the original tree,
3469 -- forcing the result to be a name.
3473 Ndims : Nat := Number_Dimensions (T_Typ);
3476 -- Build the condition for the explicit dereference case
3478 for Indx in 1 .. Ndims loop
3480 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
3487 -- Construct the test and insert into the tree
3489 if Present (Cond) then
3491 Cond := Guard_Access (Cond, Loc, Ck_Node);
3495 (Make_Raise_Constraint_Error (Loc,
3497 Reason => CE_Length_Check_Failed));
3501 end Selected_Length_Checks;
3503 ---------------------------
3504 -- Selected_Range_Checks --
3505 ---------------------------
3507 function Selected_Range_Checks
3509 Target_Typ : Entity_Id;
3510 Source_Typ : Entity_Id;
3511 Warn_Node : Node_Id)
3514 Loc : constant Source_Ptr := Sloc (Ck_Node);
3517 Expr_Actual : Node_Id;
3519 Cond : Node_Id := Empty;
3520 Do_Access : Boolean := False;
3521 Wnode : Node_Id := Warn_Node;
3522 Ret_Result : Check_Result := (Empty, Empty);
3523 Num_Checks : Integer := 0;
3525 procedure Add_Check (N : Node_Id);
3526 -- Adds the action given to Ret_Result if N is non-Empty
3528 function Discrete_Range_Cond
3532 -- Returns expression to compute:
3533 -- Low_Bound (Expr) < Typ'First
3535 -- High_Bound (Expr) > Typ'Last
3537 function Discrete_Expr_Cond
3541 -- Returns expression to compute:
3546 function Get_E_First_Or_Last
3551 -- Returns expression to compute:
3552 -- E'First or E'Last
3554 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
3555 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
3556 -- Returns expression to compute:
3557 -- N'First or N'Last using Duplicate_Subexpr
3559 function Range_E_Cond
3560 (Exptyp : Entity_Id;
3564 -- Returns expression to compute:
3565 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
3567 function Range_Equal_E_Cond
3568 (Exptyp : Entity_Id;
3572 -- Returns expression to compute:
3573 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
3575 function Range_N_Cond
3580 -- Return expression to compute:
3581 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
3587 procedure Add_Check (N : Node_Id) is
3591 -- For now, ignore attempt to place more than 2 checks ???
3593 if Num_Checks = 2 then
3597 pragma Assert (Num_Checks <= 1);
3598 Num_Checks := Num_Checks + 1;
3599 Ret_Result (Num_Checks) := N;
3603 -------------------------
3604 -- Discrete_Expr_Cond --
3605 -------------------------
3607 function Discrete_Expr_Cond
3618 Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3620 Convert_To (Base_Type (Typ),
3621 Get_E_First_Or_Last (Typ, 0, Name_First))),
3626 Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3630 Get_E_First_Or_Last (Typ, 0, Name_Last))));
3631 end Discrete_Expr_Cond;
3633 -------------------------
3634 -- Discrete_Range_Cond --
3635 -------------------------
3637 function Discrete_Range_Cond
3642 LB : Node_Id := Low_Bound (Expr);
3643 HB : Node_Id := High_Bound (Expr);
3645 Left_Opnd : Node_Id;
3646 Right_Opnd : Node_Id;
3649 if Nkind (LB) = N_Identifier
3650 and then Ekind (Entity (LB)) = E_Discriminant then
3651 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
3654 if Nkind (HB) = N_Identifier
3655 and then Ekind (Entity (HB)) = E_Discriminant then
3656 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
3663 (Base_Type (Typ), Duplicate_Subexpr (LB)),
3667 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
3669 if Base_Type (Typ) = Typ then
3672 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
3674 Compile_Time_Known_Value (High_Bound (Scalar_Range
3677 if Is_Floating_Point_Type (Typ) then
3678 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
3679 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
3685 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
3686 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
3697 (Base_Type (Typ), Duplicate_Subexpr (HB)),
3702 Get_E_First_Or_Last (Typ, 0, Name_Last)));
3704 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
3705 end Discrete_Range_Cond;
3707 -------------------------
3708 -- Get_E_First_Or_Last --
3709 -------------------------
3711 function Get_E_First_Or_Last
3723 if Is_Array_Type (E) then
3724 N := First_Index (E);
3726 for J in 2 .. Indx loop
3731 N := Scalar_Range (E);
3734 if Nkind (N) = N_Subtype_Indication then
3735 LB := Low_Bound (Range_Expression (Constraint (N)));
3736 HB := High_Bound (Range_Expression (Constraint (N)));
3738 elsif Is_Entity_Name (N) then
3739 LB := Type_Low_Bound (Etype (N));
3740 HB := Type_High_Bound (Etype (N));
3743 LB := Low_Bound (N);
3744 HB := High_Bound (N);
3747 if Nam = Name_First then
3753 if Nkind (Bound) = N_Identifier
3754 and then Ekind (Entity (Bound)) = E_Discriminant
3756 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
3758 elsif Nkind (Bound) = N_Identifier
3759 and then Ekind (Entity (Bound)) = E_In_Parameter
3760 and then not Inside_Init_Proc
3762 return Get_Discriminal (E, Bound);
3764 elsif Nkind (Bound) = N_Integer_Literal then
3765 return Make_Integer_Literal (Loc, Intval (Bound));
3768 return Duplicate_Subexpr (Bound);
3770 end Get_E_First_Or_Last;
3776 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
3779 Make_Attribute_Reference (Loc,
3780 Attribute_Name => Name_First,
3782 Duplicate_Subexpr (N, Name_Req => True),
3783 Expressions => New_List (
3784 Make_Integer_Literal (Loc, Indx)));
3792 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
3795 Make_Attribute_Reference (Loc,
3796 Attribute_Name => Name_Last,
3798 Duplicate_Subexpr (N, Name_Req => True),
3799 Expressions => New_List (
3800 Make_Integer_Literal (Loc, Indx)));
3808 function Range_E_Cond
3809 (Exptyp : Entity_Id;
3819 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3820 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3824 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3825 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3829 ------------------------
3830 -- Range_Equal_E_Cond --
3831 ------------------------
3833 function Range_Equal_E_Cond
3834 (Exptyp : Entity_Id;
3844 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3845 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3848 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3849 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3850 end Range_Equal_E_Cond;
3856 function Range_N_Cond
3867 Left_Opnd => Get_N_First (Expr, Indx),
3868 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3872 Left_Opnd => Get_N_Last (Expr, Indx),
3873 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3876 -- Start of processing for Selected_Range_Checks
3879 if not Expander_Active then
3883 if Target_Typ = Any_Type
3884 or else Target_Typ = Any_Composite
3885 or else Raises_Constraint_Error (Ck_Node)
3894 T_Typ := Target_Typ;
3896 if No (Source_Typ) then
3897 S_Typ := Etype (Ck_Node);
3899 S_Typ := Source_Typ;
3902 if S_Typ = Any_Type or else S_Typ = Any_Composite then
3906 -- The order of evaluating T_Typ before S_Typ seems to be critical
3907 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
3908 -- in, and since Node can be an N_Range node, it might be invalid.
3909 -- Should there be an assert check somewhere for taking the Etype of
3910 -- an N_Range node ???
3912 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3913 S_Typ := Designated_Type (S_Typ);
3914 T_Typ := Designated_Type (T_Typ);
3917 -- A simple optimization
3919 if Nkind (Ck_Node) = N_Null then
3924 -- For an N_Range Node, check for a null range and then if not
3925 -- null generate a range check action.
3927 if Nkind (Ck_Node) = N_Range then
3929 -- There's no point in checking a range against itself
3931 if Ck_Node = Scalar_Range (T_Typ) then
3936 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
3937 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
3938 LB : constant Node_Id := Low_Bound (Ck_Node);
3939 HB : constant Node_Id := High_Bound (Ck_Node);
3940 Null_Range : Boolean;
3942 Out_Of_Range_L : Boolean;
3943 Out_Of_Range_H : Boolean;
3946 -- Check for case where everything is static and we can
3947 -- do the check at compile time. This is skipped if we
3948 -- have an access type, since the access value may be null.
3950 -- ??? This code can be improved since you only need to know
3951 -- that the two respective bounds (LB & T_LB or HB & T_HB)
3952 -- are known at compile time to emit pertinent messages.
3954 if Compile_Time_Known_Value (LB)
3955 and then Compile_Time_Known_Value (HB)
3956 and then Compile_Time_Known_Value (T_LB)
3957 and then Compile_Time_Known_Value (T_HB)
3958 and then not Do_Access
3960 -- Floating-point case
3962 if Is_Floating_Point_Type (S_Typ) then
3963 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
3965 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
3967 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
3970 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
3972 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
3974 -- Fixed or discrete type case
3977 Null_Range := Expr_Value (HB) < Expr_Value (LB);
3979 (Expr_Value (LB) < Expr_Value (T_LB))
3981 (Expr_Value (LB) > Expr_Value (T_HB));
3984 (Expr_Value (HB) > Expr_Value (T_HB))
3986 (Expr_Value (HB) < Expr_Value (T_LB));
3989 if not Null_Range then
3990 if Out_Of_Range_L then
3991 if No (Warn_Node) then
3993 (Compile_Time_Constraint_Error
3994 (Low_Bound (Ck_Node),
3995 "static value out of range of}?", T_Typ));
3999 (Compile_Time_Constraint_Error
4001 "static range out of bounds of}?", T_Typ));
4005 if Out_Of_Range_H then
4006 if No (Warn_Node) then
4008 (Compile_Time_Constraint_Error
4009 (High_Bound (Ck_Node),
4010 "static value out of range of}?", T_Typ));
4014 (Compile_Time_Constraint_Error
4016 "static range out of bounds of}?", T_Typ));
4024 LB : Node_Id := Low_Bound (Ck_Node);
4025 HB : Node_Id := High_Bound (Ck_Node);
4029 -- If either bound is a discriminant and we are within
4030 -- the record declaration, it is a use of the discriminant
4031 -- in a constraint of a component, and nothing can be
4032 -- checked here. The check will be emitted within the
4033 -- init_proc. Before then, the discriminal has no real
4036 if Nkind (LB) = N_Identifier
4037 and then Ekind (Entity (LB)) = E_Discriminant
4039 if Current_Scope = Scope (Entity (LB)) then
4043 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
4047 if Nkind (HB) = N_Identifier
4048 and then Ekind (Entity (HB)) = E_Discriminant
4050 if Current_Scope = Scope (Entity (HB)) then
4054 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
4058 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
4059 Set_Paren_Count (Cond, 1);
4065 Left_Opnd => Duplicate_Subexpr (HB),
4066 Right_Opnd => Duplicate_Subexpr (LB)),
4067 Right_Opnd => Cond);
4073 elsif Is_Scalar_Type (S_Typ) then
4075 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
4076 -- except the above simply sets a flag in the node and lets
4077 -- gigi generate the check base on the Etype of the expression.
4078 -- Sometimes, however we want to do a dynamic check against an
4079 -- arbitrary target type, so we do that here.
4081 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
4082 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
4084 -- For literals, we can tell if the constraint error will be
4085 -- raised at compile time, so we never need a dynamic check, but
4086 -- if the exception will be raised, then post the usual warning,
4087 -- and replace the literal with a raise constraint error
4088 -- expression. As usual, skip this for access types
4090 elsif Compile_Time_Known_Value (Ck_Node)
4091 and then not Do_Access
4094 LB : constant Node_Id := Type_Low_Bound (T_Typ);
4095 UB : constant Node_Id := Type_High_Bound (T_Typ);
4097 Out_Of_Range : Boolean;
4098 Static_Bounds : constant Boolean :=
4099 Compile_Time_Known_Value (LB)
4100 and Compile_Time_Known_Value (UB);
4103 -- Following range tests should use Sem_Eval routine ???
4105 if Static_Bounds then
4106 if Is_Floating_Point_Type (S_Typ) then
4108 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
4110 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
4112 else -- fixed or discrete type
4114 Expr_Value (Ck_Node) < Expr_Value (LB)
4116 Expr_Value (Ck_Node) > Expr_Value (UB);
4119 -- Bounds of the type are static and the literal is
4120 -- out of range so make a warning message.
4122 if Out_Of_Range then
4123 if No (Warn_Node) then
4125 (Compile_Time_Constraint_Error
4127 "static value out of range of}?", T_Typ));
4131 (Compile_Time_Constraint_Error
4133 "static value out of range of}?", T_Typ));
4138 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
4142 -- Here for the case of a non-static expression, we need a runtime
4143 -- check unless the source type range is guaranteed to be in the
4144 -- range of the target type.
4147 if not In_Subrange_Of (S_Typ, T_Typ) then
4148 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
4153 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
4154 if Is_Constrained (T_Typ) then
4156 Expr_Actual := Get_Referenced_Object (Ck_Node);
4157 Exptyp := Get_Actual_Subtype (Expr_Actual);
4159 if Is_Access_Type (Exptyp) then
4160 Exptyp := Designated_Type (Exptyp);
4163 -- String_Literal case. This needs to be handled specially be-
4164 -- cause no index types are available for string literals. The
4165 -- condition is simply:
4167 -- T_Typ'Length = string-literal-length
4169 if Nkind (Expr_Actual) = N_String_Literal then
4172 -- General array case. Here we have a usable actual subtype for
4173 -- the expression, and the condition is built from the two types
4175 -- T_Typ'First < Exptyp'First or else
4176 -- T_Typ'Last > Exptyp'Last or else
4177 -- T_Typ'First(1) < Exptyp'First(1) or else
4178 -- T_Typ'Last(1) > Exptyp'Last(1) or else
4181 elsif Is_Constrained (Exptyp) then
4185 Ndims : Nat := Number_Dimensions (T_Typ);
4193 L_Index := First_Index (T_Typ);
4194 R_Index := First_Index (Exptyp);
4196 for Indx in 1 .. Ndims loop
4197 if not (Nkind (L_Index) = N_Raise_Constraint_Error
4199 Nkind (R_Index) = N_Raise_Constraint_Error)
4201 Get_Index_Bounds (L_Index, L_Low, L_High);
4202 Get_Index_Bounds (R_Index, R_Low, R_High);
4204 -- Deal with compile time length check. Note that we
4205 -- skip this in the access case, because the access
4206 -- value may be null, so we cannot know statically.
4209 Subtypes_Statically_Match
4210 (Etype (L_Index), Etype (R_Index))
4212 -- If the target type is constrained then we
4213 -- have to check for exact equality of bounds
4214 -- (required for qualified expressions).
4216 if Is_Constrained (T_Typ) then
4219 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
4223 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
4234 -- Handle cases where we do not get a usable actual subtype that
4235 -- is constrained. This happens for example in the function call
4236 -- and explicit dereference cases. In these cases, we have to get
4237 -- the length or range from the expression itself, making sure we
4238 -- do not evaluate it more than once.
4240 -- Here Ck_Node is the original expression, or more properly the
4241 -- result of applying Duplicate_Expr to the original tree,
4242 -- forcing the result to be a name.
4246 Ndims : Nat := Number_Dimensions (T_Typ);
4249 -- Build the condition for the explicit dereference case
4251 for Indx in 1 .. Ndims loop
4253 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
4260 -- Generate an Action to check that the bounds of the
4261 -- source value are within the constraints imposed by the
4262 -- target type for a conversion to an unconstrained type.
4265 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
4267 Opnd_Index : Node_Id;
4268 Targ_Index : Node_Id;
4272 := First_Index (Get_Actual_Subtype (Ck_Node));
4273 Targ_Index := First_Index (T_Typ);
4275 while Opnd_Index /= Empty loop
4276 if Nkind (Opnd_Index) = N_Range then
4278 (Low_Bound (Opnd_Index), Etype (Targ_Index))
4281 (High_Bound (Opnd_Index), Etype (Targ_Index))
4285 elsif Is_Out_Of_Range
4286 (Low_Bound (Opnd_Index), Etype (Targ_Index))
4289 (High_Bound (Opnd_Index), Etype (Targ_Index))
4292 (Compile_Time_Constraint_Error
4293 (Wnode, "value out of range of}?", T_Typ));
4299 (Opnd_Index, Etype (Targ_Index)));
4303 Next_Index (Opnd_Index);
4304 Next_Index (Targ_Index);
4311 -- Construct the test and insert into the tree
4313 if Present (Cond) then
4315 Cond := Guard_Access (Cond, Loc, Ck_Node);
4319 (Make_Raise_Constraint_Error (Loc,
4321 Reason => CE_Range_Check_Failed));
4325 end Selected_Range_Checks;
4327 -------------------------------
4328 -- Storage_Checks_Suppressed --
4329 -------------------------------
4331 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
4333 return Scope_Suppress.Storage_Checks
4334 or else (Present (E) and then Suppress_Storage_Checks (E));
4335 end Storage_Checks_Suppressed;
4337 ---------------------------
4338 -- Tag_Checks_Suppressed --
4339 ---------------------------
4341 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
4343 return Scope_Suppress.Tag_Checks
4344 or else (Present (E) and then Suppress_Tag_Checks (E));
4345 end Tag_Checks_Suppressed;