| blob | 5442819566bf6589217442d27ae393ab43aaa07e |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- C H E C K S --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
25 -- --
26 ------------------------------------------------------------------------------
57 -- General note: many of these routines are concerned with generating
58 -- checking code to make sure that constraint error is raised at runtime.
59 -- Clearly this code is only needed if the expander is active, since
60 -- otherwise we will not be generating code or going into the runtime
61 -- execution anyway.
63 -- We therefore disconnect most of these checks if the expander is
64 -- inactive. This has the additional benefit that we do not need to
65 -- worry about the tree being messed up by previous errors (since errors
66 -- turn off expansion anyway).
68 -- There are a few exceptions to the above rule. For instance routines
69 -- such as Apply_Scalar_Range_Check that do not insert any code can be
70 -- safely called even when the Expander is inactive (but Errors_Detected
71 -- is 0). The benefit of executing this code when expansion is off, is
72 -- the ability to emit constraint error warning for static expressions
73 -- even when we are not generating code.
75 ----------------------------
76 -- Local Subprogram Specs --
77 ----------------------------
79 procedure Apply_Selected_Length_Checks
84 -- This is the subprogram that does all the work for Apply_Length_Check
85 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
86 -- described for the above routines. The Do_Static flag indicates that
87 -- only a static check is to be done.
89 procedure Apply_Selected_Range_Checks
94 -- This is the subprogram that does all the work for Apply_Range_Check.
95 -- Expr, Target_Typ and Source_Typ are as described for the above
96 -- routine. The Do_Static flag indicates that only a static check is
97 -- to be done.
100 -- If a discriminal is used in constraining a prival, Return reference
101 -- to the discriminal of the protected body (which renames the parameter
102 -- of the enclosing protected operation). This clumsy transformation is
103 -- needed because privals are created too late and their actual subtypes
104 -- are not available when analysing the bodies of the protected operations.
105 -- To be cleaned up???
107 function Guard_Access
112 -- In the access type case, guard the test with a test to ensure
113 -- that the access value is non-null, since the checks do not
114 -- not apply to null access values.
117 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
118 -- Constraint_Error node.
120 function Selected_Length_Checks
126 -- Like Apply_Selected_Length_Checks, except it doesn't modify
127 -- anything, just returns a list of nodes as described in the spec of
128 -- this package for the Range_Check function.
130 function Selected_Range_Checks
136 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
137 -- just returns a list of nodes as described in the spec of this package
138 -- for the Range_Check function.
140 ------------------------------
141 -- Access_Checks_Suppressed --
142 ------------------------------
145 begin
150 -------------------------------------
151 -- Accessibility_Checks_Suppressed --
152 -------------------------------------
155 begin
160 -------------------------
161 -- Append_Range_Checks --
162 -------------------------
164 procedure Append_Range_Checks
170 is
175 or else
178 begin
179 -- For now we just return if Checks_On is false, however this should
180 -- be enhanced to check for an always True value in the condition
181 -- and to generate a compilation warning???
192 then
198 else
199 Append_To
207 ------------------------
208 -- Apply_Access_Check --
209 ------------------------
214 begin
225 then
231 else
236 -------------------------------
237 -- Apply_Accessibility_Check --
238 -------------------------------
246 begin
250 -- Only apply the run-time check if the access parameter
251 -- has an associated extra access level parameter and
252 -- when the level of the type is less deep than the level
253 -- of the access parameter.
261 then
262 Param_Level :=
265 Type_Level :=
268 -- Raise Program_Error if the accessibility level of the
269 -- the access parameter is deeper than the level of the
270 -- target access type.
274 Condition =>
284 ---------------------------
285 -- Apply_Alignment_Check --
286 ---------------------------
293 begin
306 then
314 -- Here Expr is the address value. See if we know that the
315 -- value is unacceptable at compile time.
319 then
324 Error_Msg_NE
329 -- Here we do not know if the value is acceptable, generate
330 -- code to raise PE if alignment is inappropriate.
332 else
333 -- Skip generation of this code if we don't want elab code
338 Condition =>
340 Left_Opnd =>
342 Left_Opnd =>
343 Unchecked_Convert_To
346 Right_Opnd =>
359 -------------------------------------
360 -- Apply_Arithmetic_Overflow_Check --
361 -------------------------------------
363 -- This routine is called only if the type is an integer type, and
364 -- a software arithmetic overflow check must be performed for op
365 -- (add, subtract, multiply). The check is performed only if
366 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
367 -- is set. In this case we expand the operation into a more complex
368 -- sequence of tests that ensures that overflow is properly caught.
384 begin
385 if Backend_Overflow_Checks_On_Target
387 or not Expander_Active
388 then
392 -- Nothing to do if the range of the result is known OK
396 -- Note in the test below that we assume that if a bound of the
397 -- range is equal to that of the type. That's not quite accurate
398 -- but we do this for the following reasons:
400 -- a) The way that Determine_Range works, it will typically report
401 -- the bounds of the value are the bounds of the type, because
402 -- it either can't tell anything more precise, or does not think
403 -- it is worth the effort to be more precise.
405 -- b) It is very unusual to have a situation in which this would
406 -- generate an unnecessary overflow check (an example would be
407 -- a subtype with a range 0 .. Integer'Last - 1 to which the
408 -- literal value one is added.
410 -- c) The alternative is a lot of special casing in this routine
411 -- which would partially duplicate the Determine_Range processing.
413 if OK
416 then
420 -- None of the special case optimizations worked, so there is nothing
421 -- for it but to generate the full general case code:
423 -- x op y
425 -- is expanded into
427 -- Typ (Checktyp (x) op Checktyp (y));
429 -- where Typ is the type of the original expression, and Checktyp is
430 -- an integer type of sufficient length to hold the largest possible
431 -- result.
433 -- In the case where check type exceeds the size of Long_Long_Integer,
434 -- we use a different approach, expanding to:
436 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
438 -- where xxx is Add, Multiply or Subtract as appropriate
440 -- Find check type if one exists
448 -- No check type exists, use runtime call
450 else
457 else
474 -- If we fall through, we have the case where we do the arithmetic in
475 -- the next higher type and get the check by conversion. In these cases
476 -- Ctyp is set to the type to be used as the check type.
494 -- The type of the operation changes to the base type of the check
495 -- type, and we reset the overflow check indication, since clearly
496 -- no overflow is possible now that we are using a double length
497 -- type. We also set the Analyzed flag to avoid a recursive attempt
498 -- to expand the node.
504 -- Now build the outer conversion
516 ----------------------------
517 -- Apply_Array_Size_Check --
518 ----------------------------
520 -- Note: Really of course this entre check should be in the backend,
521 -- and perhaps this is not quite the right value, but it is good
522 -- enough to catch the normal cases (and the relevant ACVC tests!)
540 -- Set false if any index subtye bound is non-static
543 -- We can throw away all the Uint computations here, since they are
544 -- done only to generate boolean test results.
547 -- Size to check against
550 -- Determines if Decl is an address clause or Import/Interface pragma
551 -- that references the defining identifier of the current declaration.
553 --------------------------
554 -- Is_Address_Or_Import --
555 --------------------------
558 begin
563 return
565 and then
567 and then
572 or else
575 then
576 declare
580 begin
581 return
583 and then
585 and then
587 and then
591 else
595 else
600 -- Start of processing for Apply_Array_Size_Check
602 begin
603 if not Expander_Active
605 then
609 -- It is pointless to insert this check inside an _init_proc, because
610 -- that's too late, we have already built the object to be the right
611 -- size, and if it's too large, too bad!
617 -- Look head for pragma interface/import or address clause applying
618 -- to this entity. If found, we suppress the check entirely. For now
619 -- we only look ahead 20 declarations to stop this becoming too slow
620 -- Note that eventually this whole routine gets moved to gigi.
632 -- First step is to calculate the maximum number of elements. For this
633 -- calculation, we use the actual size of the subtype if it is static,
634 -- and if a bound of a subtype is non-static, we go to the bound of the
635 -- base type.
644 -- If any bound raises constraint error, we will never get this
645 -- far, so there is no need to generate any kind of check.
648 or else
650 then
655 -- Otherwise get bounds values
659 else
666 else
675 -- Compute the limit against which we want to check. For subprograms,
676 -- where the array will go on the stack, we use 8*2**24, which (in
677 -- bits) is the size of a 16 megabyte array.
681 else
685 -- If we have all static bounds and Siz is too large, then we know we
686 -- know we have a storage error right now, so generate message
699 -- Case of component size known at compile time. If the array
700 -- size is definitely in range, then we do not need a check.
704 then
709 -- Here if a dynamic check is required
711 -- What we do is to build an expression for the size of the array,
712 -- which is computed as the 'Size of the array component, times
713 -- the size of each dimension.
717 Sizx :=
730 Sizx :=
733 Right_Opnd =>
742 Code :=
744 Condition =>
747 Right_Opnd =>
755 ----------------------------
756 -- Apply_Constraint_Check --
757 ----------------------------
759 procedure Apply_Constraint_Check
763 is
766 begin
775 -- A useful optimization: an aggregate with only an Others clause
776 -- always has the right bounds.
780 and then Nkind
782 = N_Others_Choice
783 then
793 else
801 then
808 -- No checks necessary if expression statically null
813 -- No sliding possible on access to arrays
824 then
830 ------------------------------
831 -- Apply_Discriminant_Check --
832 ------------------------------
834 procedure Apply_Discriminant_Check
838 is
846 -- It is possible for an aliased component to have a nominal
847 -- unconstrained subtype (through instantiation). If this is a
848 -- discriminated component assigned in the expansion of an aggregate
849 -- in an initialization, the check must be suppressed. This unusual
850 -- situation requires a predicate of its own (see 7503-008).
852 ----------------------------------------
853 -- Is_Aliased_Unconstrained_Component --
854 ----------------------------------------
860 begin
863 else
870 then
875 and then In_Instance
879 -- Start of processing for Apply_Discriminant_Check
881 begin
884 else
888 -- Nothing to do if discriminant checks are suppressed or else no code
889 -- is to be generated
891 if not Expander_Active
893 then
897 -- No discriminant checks necessary for access when expression
898 -- is statically Null. This is not only an optimization, this is
899 -- fundamental because otherwise discriminant checks may be generated
900 -- in init procs for types containing an access to a non-frozen yet
901 -- record, causing a deadly forward reference.
903 -- Also, if the expression is of an access type whose designated
904 -- type is incomplete, then the access value must be null and
905 -- we suppress the check.
918 -- If an assignment target is present, then we need to generate
919 -- the actual subtype if the target is a parameter or aliased
920 -- object with an unconstrained nominal subtype.
927 then
931 -- Nothing to do if the type is unconstrained (this is the case
932 -- where the actual subtype in the RM sense of N is unconstrained
933 -- and no check is required).
939 -- Suppress checks if the subtypes are the same.
940 -- the check must be preserved in an assignment to a formal, because
941 -- the constraint is given by the actual.
948 then
952 then
956 -- We can also eliminate checks on allocators with a subtype mark
957 -- that coincides with the context type. The context type may be a
958 -- subtype without a constraint (common case, a generic actual).
962 then
963 declare
966 begin
973 then
979 -- See if we have a case where the types are both constrained, and
980 -- all the constraints are constants. In this case, we can do the
981 -- check successfully at compile time.
983 -- we skip this check for the case where the node is a rewritten`
984 -- allocator, because it already carries the context subtype, and
985 -- extracting the discriminants from the aggregate is messy.
989 then
990 declare
997 begin
998 -- S_Typ may not have discriminants in the case where it is a
999 -- private type completed by a default discriminated type. In
1000 -- that case, we need to get the constraints from the
1001 -- underlying_type. If the underlying type is unconstrained (i.e.
1002 -- has no default discriminants) no check is needed.
1008 else
1010 DconS :=
1011 First_Elmt
1025 exit when
1027 or else
1033 else
1034 Apply_Compile_Time_Constraint_Error
1052 -- Here we need a discriminant check. First build the expression
1053 -- for the comparisons of the discriminants:
1055 -- (n.disc1 /= typ.disc1) or else
1056 -- (n.disc2 /= typ.disc2) or else
1057 -- ...
1058 -- (n.discn /= typ.discn)
1062 -- If Lhs is set and is a parameter, then the condition is
1063 -- guarded by: lhs'constrained and then (condition built above)
1066 Cond :=
1068 Left_Opnd =>
1086 ------------------------
1087 -- Apply_Divide_Check --
1088 ------------------------
1104 begin
1105 if Expander_Active
1106 and not Backend_Divide_Checks_On_Target
1107 then
1110 -- See if division by zero possible, and if so generate test. This
1111 -- part of the test is not controlled by the -gnato switch.
1118 Condition =>
1126 -- Test for extremely annoying case of xxx'First divided by -1
1132 then
1137 and then
1139 then
1142 Condition =>
1151 Right_Opnd =>
1160 ------------------------
1161 -- Apply_Length_Check --
1162 ------------------------
1164 procedure Apply_Length_Check
1168 is
1169 begin
1170 Apply_Selected_Length_Checks
1174 -----------------------
1175 -- Apply_Range_Check --
1176 -----------------------
1178 procedure Apply_Range_Check
1182 is
1183 begin
1184 Apply_Selected_Range_Checks
1188 ------------------------------
1189 -- Apply_Scalar_Range_Check --
1190 ------------------------------
1192 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1193 -- flag off if it is already set on.
1195 procedure Apply_Scalar_Range_Check
1200 is
1208 -- Set true if Expr is a subscript
1211 -- Set true if Expr is a subscript of an unconstrained array. In this
1212 -- case we do not attempt to do an analysis of the value against the
1213 -- range of the subscript, since we don't know the actual subtype.
1216 -- Set to True if Expr should be regarded as a real value
1217 -- even though the type of Expr might be discrete.
1220 -- Procedure called if value is determined to be out of range
1223 begin
1224 Apply_Compile_Time_Constraint_Error
1230 begin
1234 -- Return if check obviously not needed. Note that we do not check
1235 -- for the expander being inactive, since this routine does not
1236 -- insert any code, but it does generate useful warnings sometimes,
1237 -- which we would like even if we are in semantics only mode.
1242 then
1246 -- Now, see if checks are suppressed
1248 Is_Subscr_Ref :=
1258 -- Subscript reference. Check for Index_Checks suppressed
1262 -- Check array type and its base type
1266 then
1269 -- Check array itself if it is an entity name
1273 then
1276 -- Check expression itself if it is an entity name
1280 then
1284 -- All other cases, check for Range_Checks suppressed
1286 else
1287 -- Check target type and its base type
1291 then
1294 -- Check expression itself if it is an entity name
1298 then
1301 -- If Expr is part of an assignment statement, then check
1302 -- left side of assignment if it is an entity name.
1307 then
1313 -- Now see if we need a check
1317 else
1325 Is_Unconstrained_Subscr_Ref :=
1328 -- Always do a range check if the source type includes infinities
1329 -- and the target type does not include infinities.
1334 then
1338 -- Return if we know expression is definitely in the range of
1339 -- the target type as determined by Determine_Range. Right now
1340 -- we only do this for discrete types, and not fixed-point or
1341 -- floating-point types.
1343 -- The additional less-precise tests below catch these cases.
1345 -- Note: skip this if we are given a source_typ, since the point
1346 -- of supplying a Source_Typ is to stop us looking at the expression.
1347 -- could sharpen this test to be out parameters only ???
1351 and then not Is_Unconstrained_Subscr_Ref
1353 then
1354 declare
1360 begin
1363 then
1367 declare
1371 begin
1376 Bad_Value;
1385 Int_Real :=
1389 -- Check if we can determine at compile time whether Expr is in the
1390 -- range of the target type. Note that if S_Typ is within the
1391 -- bounds of Target_Typ then this must be the case. This checks is
1392 -- only meaningful if this is not a conversion between integer and
1393 -- real types.
1395 if not Is_Unconstrained_Subscr_Ref
1396 and then
1398 and then
1400 or else
1402 then
1406 Bad_Value;
1409 -- Do not set range checks if they are killed
1413 then
1416 -- ??? We only need a runtime check if the target type is constrained
1417 -- (the predefined type Float is not for instance).
1418 -- so the following should really be
1419 --
1420 -- elsif Is_Constrained (Target_Typ) then
1421 --
1422 -- but it isn't because certain types do not have the Is_Constrained
1423 -- flag properly set (see 1503-003).
1425 else
1432 ----------------------------------
1433 -- Apply_Selected_Length_Checks --
1434 ----------------------------------
1436 procedure Apply_Selected_Length_Checks
1441 is
1449 or else
1452 begin
1457 R_Result :=
1465 -- A length check may mention an Itype which is attached to a
1466 -- subsequent node. At the top level in a package this can cause
1467 -- an order-of-elaboration problem, so we make sure that the itype
1468 -- is referenced now.
1472 then
1483 -- If the item is a conditional raise of constraint error,
1484 -- then have a look at what check is being performed and
1485 -- ???
1489 then
1493 and then Checks_On
1494 then
1502 -- Output a warning if the condition is known to be True
1506 then
1507 Apply_Compile_Time_Constraint_Error
1509 CE_Length_Check_Failed,
1513 -- If we were only doing a static check, or if checks are not
1514 -- on, then we want to delete the check, since it is not needed.
1515 -- We do this by replacing the if statement by a null statement
1521 else
1529 ---------------------------------
1530 -- Apply_Selected_Range_Checks --
1531 ---------------------------------
1533 procedure Apply_Selected_Range_Checks
1538 is
1546 or else
1549 begin
1554 R_Result :=
1562 -- If the item is a conditional raise of constraint error,
1563 -- then have a look at what check is being performed and
1564 -- ???
1568 then
1579 -- Output a warning if the condition is known to be True
1583 then
1584 -- Since an N_Range is technically not an expression, we
1585 -- have to set one of the bounds to C_E and then just flag
1586 -- the N_Range. The warning message will point to the
1587 -- lower bound and complain about a range, which seems OK.
1590 Apply_Compile_Time_Constraint_Error
1592 CE_Range_Check_Failed,
1598 else
1599 Apply_Compile_Time_Constraint_Error
1601 CE_Range_Check_Failed,
1606 -- If we were only doing a static check, or if checks are not
1607 -- on, then we want to delete the check, since it is not needed.
1608 -- We do this by replacing the if statement by a null statement
1614 else
1622 -------------------------------
1623 -- Apply_Static_Length_Check --
1624 -------------------------------
1626 procedure Apply_Static_Length_Check
1630 is
1631 begin
1632 Apply_Selected_Length_Checks
1636 -------------------------------------
1637 -- Apply_Subscript_Validity_Checks --
1638 -------------------------------------
1643 begin
1646 -- Loop through subscripts
1651 -- Check one subscript. Note that we do not worry about
1652 -- enumeration type with holes, since we will convert the
1653 -- value to a Pos value for the subscript, and that convert
1654 -- will do the necessary validity check.
1658 -- Move to next subscript
1664 ----------------------------------
1665 -- Apply_Type_Conversion_Checks --
1666 ----------------------------------
1675 begin
1679 -- Skip these checks if serious errors detected, there are some nasty
1680 -- situations of incomplete trees that blow things up.
1685 -- Scalar type conversions of the form Target_Type (Expr) require
1686 -- two checks:
1687 --
1688 -- - First there is an overflow check to insure that Expr is
1689 -- in the base type of Target_Typ (4.6 (28)),
1690 --
1691 -- - After we know Expr fits into the base type, we must perform a
1692 -- range check to ensure that Expr meets the constraints of the
1693 -- Target_Type.
1696 declare
1698 -- If the Conversion_OK flag on the type conversion is set
1699 -- and no floating point type is involved in the type conversion
1700 -- then fixed point values must be read as integral values.
1702 begin
1703 -- Overflow check.
1707 then
1713 then
1714 Apply_Scalar_Range_Check
1725 then
1726 -- A unconstrained derived type may have inherited discriminants.
1727 -- Build an actual discriminant constraint list using the girder
1728 -- constraint, to verify that the expression of the parent type
1729 -- satisfies the constraints imposed by the (unconstrained!)
1730 -- derived type. This applies to value conversions, not to view
1731 -- conversions of tagged types.
1733 declare
1742 begin
1750 then
1755 then
1756 -- Parent is constrained by new discriminant. Obtain
1757 -- Value of original discriminant in expression. If
1758 -- the new discriminant has been used to constrain more
1759 -- than one of the girder ones, this will provide the
1760 -- required consistency check.
1762 Append_Elmt (
1764 Prefix =>
1766 Selector_Name =>
1768 New_Constraints);
1770 else
1771 -- Discriminant of more remote ancestor ???
1776 -- Derived type definition has an explicit value for
1777 -- this girder discriminant.
1779 else
1780 Append_Elmt
1787 -- Use the unconstrained expression type to retrieve the
1788 -- discriminants of the parent, and apply momentarily the
1789 -- discriminant constraint synthesized above.
1801 -- should there be other checks here for array types ???
1803 else
1809 ----------------------------------------------
1810 -- Apply_Universal_Integer_Attribute_Checks --
1811 ----------------------------------------------
1817 begin
1821 -- Nothing to do if checks are suppressed
1825 then
1828 -- Nothing to do if the attribute does not come from source. The
1829 -- internal attributes we generate of this type do not need checks,
1830 -- and furthermore the attempt to check them causes some circular
1831 -- elaboration orders when dealing with packed types.
1836 -- Otherwise, replace the attribute node with a type conversion
1837 -- node whose expression is the attribute, retyped to universal
1838 -- integer, and whose subtype mark is the target type. The call
1839 -- to analyze this conversion will set range and overflow checks
1840 -- as required for proper detection of an out of range value.
1842 else
1857 -------------------------------
1858 -- Build_Discriminant_Checks --
1859 -------------------------------
1861 function Build_Discriminant_Checks
1864 return Node_Id
1865 is
1872 begin
1876 -- For a fully private type, use the discriminants of the parent
1877 -- type.
1881 then
1883 else
1893 then
1895 else
1901 Left_Opnd =>
1903 Prefix =>
1905 Selector_Name =>
1916 -----------------------------------
1917 -- Check_Valid_Lvalue_Subscripts --
1918 -----------------------------------
1921 begin
1922 -- Skip this if range checks are suppressed
1927 -- Only do this check for expressions that come from source. We
1928 -- assume that expander generated assignments explicitly include
1929 -- any necessary checks. Note that this is not just an optimization,
1930 -- it avoids infinite recursions!
1935 -- For a selected component, check the prefix
1941 -- Case of indexed component
1946 -- Prefix may itself be or contain an indexed component, and
1947 -- these subscripts need checking as well
1953 ---------------------
1954 -- Determine_Range --
1955 ---------------------
1959 -- Determine size of below cache (power of 2 is more efficient!)
1964 -- The above arrays are used to implement a small direct cache
1965 -- for Determine_Range calls. Because of the way Determine_Range
1966 -- recursively traces subexpressions, and because overflow checking
1967 -- calls the routine on the way up the tree, a quadratic behavior
1968 -- can otherwise be encountered in large expressions. The cache
1969 -- entry for node N is stored in the (N mod Cache_Size) entry, and
1970 -- can be validated by checking the actual node value stored there.
1972 procedure Determine_Range
1977 is
1982 -- Lo and Hi bounds of left operand
1986 -- Lo and Hi bounds of right (or only) operand
1989 -- Temp variable used to hold a bound node
1992 -- High bound of base type of expression
1996 -- Refined values for low and high bounds, after tightening
1999 -- Used in lower level calls to indicate if call succeeded
2002 -- Used to search cache
2005 -- Used for binary operators. Determines the ranges of the left and
2006 -- right operands, and if they are both OK, returns True, and puts
2007 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2009 -----------------
2010 -- OK_Operands --
2011 -----------------
2014 begin
2025 -- Start of processing for Determine_Range
2027 begin
2028 -- Prevent junk warnings by initializing range variables
2035 -- If the type is not discrete, or is undefined, then we can't
2036 -- do anything about determining the range.
2040 then
2045 -- For all other cases, we can determine the range
2049 -- If value is compile time known, then the possible range is the
2050 -- one value that we know this expression definitely has!
2058 -- Return if already in the cache
2068 -- Otherwise, start by finding the bounds of the type of the
2069 -- expression, the value cannot be outside this range (if it
2070 -- is, then we have an overflow situation, which is a separate
2071 -- check, we are talking here only about the expression value).
2073 -- We use the actual bound unless it is dynamic, in which case
2074 -- use the corresponding base type bound if possible. If we can't
2075 -- get a bound then we figure we can't determine the range (a
2076 -- peculiar case, that perhaps cannot happen, but there is no
2077 -- point in bombing in this optimization circuit.
2079 -- First the low bound
2089 else
2094 -- Now the high bound
2098 -- We need the high bound of the base type later on, and this should
2099 -- always be compile time known. Again, it is not clear that this
2100 -- can ever be false, but no point in bombing.
2106 else
2111 -- If we have a static subtype, then that may have a tighter bound
2112 -- so use the upper bound of the subtype instead in this case.
2118 -- We may be able to refine this value in certain situations. If
2119 -- refinement is possible, then Lor and Hir are set to possibly
2120 -- tighter bounds, and OK1 is set to True.
2124 -- For unary plus, result is limited by range of operand
2129 -- For unary minus, determine range of operand, and negate it
2139 -- For binary addition, get range of each operand and do the
2140 -- addition to get the result range.
2148 -- Division is tricky. The only case we consider is where the
2149 -- right operand is a positive constant, and in this case we
2150 -- simply divide the bounds of the left operand
2156 then
2160 else
2165 -- For binary subtraction, get range of each operand and do
2166 -- the worst case subtraction to get the result range.
2174 -- For MOD, if right operand is a positive constant, then
2175 -- result must be in the allowable range of mod results.
2189 else
2194 -- For REM, if right operand is a positive constant, then
2195 -- result must be in the allowable range of mod results.
2200 declare
2203 begin
2204 -- The sign of the result depends on the sign of the
2205 -- dividend (but not on the sign of the divisor, hence
2206 -- the abs operation above).
2210 else
2216 else
2221 else
2226 -- Attribute reference cases
2231 -- For Pos/Val attributes, we can refine the range using the
2232 -- possible range of values of the attribute expression
2237 -- For Length attribute, use the bounds of the corresponding
2238 -- index type to refine the range.
2241 declare
2249 begin
2254 -- For string literal, we know exact value
2263 -- Otherwise check for expression given
2267 else
2268 Inum :=
2277 Determine_Range
2281 Determine_Range
2286 -- The maximum value for Length is the biggest
2287 -- possible gap between the values of the bounds.
2288 -- But of course, this value cannot be negative.
2292 -- For constrained arrays, the minimum value for
2293 -- Length is taken from the actual value of the
2294 -- bounds, since the index will be exactly of
2295 -- this subtype.
2300 -- For an unconstrained array, the minimum value
2301 -- for length is always zero.
2303 else
2310 -- No special handling for other attributes
2311 -- Probably more opportunities exist here ???
2318 -- For type conversion from one discrete type to another, we
2319 -- can refine the range using the converted value.
2324 -- Nothing special to do for all other expression kinds
2332 -- At this stage, if OK1 is true, then we know that the actual
2333 -- result of the computed expression is in the range Lor .. Hir.
2334 -- We can use this to restrict the possible range of results.
2338 -- If the refined value of the low bound is greater than the
2339 -- type high bound, then reset it to the more restrictive
2340 -- value. However, we do NOT do this for the case of a modular
2341 -- type where the possible upper bound on the value is above the
2342 -- base type high bound, because that means the result could wrap.
2347 then
2351 -- Similarly, if the refined value of the high bound is less
2352 -- than the value so far, then reset it to the more restrictive
2353 -- value. Again, we do not do this if the refined low bound is
2354 -- negative for a modular type, since this would wrap.
2359 then
2364 -- Set cache entry for future call and we are all done
2371 -- If any exception occurs, it means that we have some bug in the compiler
2372 -- possibly triggered by a previous error, or by some unforseen peculiar
2373 -- occurrence. However, this is only an optimization attempt, so there is
2374 -- really no point in crashing the compiler. Instead we just decide, too
2375 -- bad, we can't figure out a range in this case after all.
2377 exception
2380 -- Debug flag K disables this behavior (useful for debugging)
2384 else
2393 ------------------------------------
2394 -- Discriminant_Checks_Suppressed --
2395 ------------------------------------
2398 begin
2403 --------------------------------
2404 -- Division_Checks_Suppressed --
2405 --------------------------------
2408 begin
2413 -----------------------------------
2414 -- Elaboration_Checks_Suppressed --
2415 -----------------------------------
2418 begin
2423 ------------------------
2424 -- Enable_Range_Check --
2425 ------------------------
2428 begin
2431 then
2433 else
2438 ------------------
2439 -- Ensure_Valid --
2440 ------------------
2445 begin
2446 -- Ignore call if we are not doing any validity checking
2451 -- No check required if expression is from the expander, we assume
2452 -- the expander will generate whatever checks are needed. Note that
2453 -- this is not just an optimization, it avoids infinite recursions!
2455 -- Unchecked conversions must be checked, unless they are initialized
2456 -- scalar values, as in a component assignment in an init_proc.
2461 then
2464 -- No check required if expression is known to have valid value
2469 -- No check required if checks off
2474 -- Ignore case of enumeration with holes where the flag is set not
2475 -- to worry about holes, since no special validity check is needed
2479 and then Holes_OK
2480 then
2483 -- No check required on the left-hand side of an assignment.
2487 then
2490 -- An annoying special case. If this is an out parameter of a scalar
2491 -- type, then the value is not going to be accessed, therefore it is
2492 -- inappropriate to do any validity check at the call site.
2494 else
2495 -- Only need to worry about scalar types
2498 declare
2506 begin
2507 -- Find actual argument (which may be a parameter association)
2508 -- and the parent of the actual argument (the call statement)
2518 -- Only need to worry if we are argument of a procedure
2519 -- call since functions don't have out parameters.
2525 -- Only need to worry if there are indeed actuals, and
2526 -- if this could be a procedure call, otherwise we cannot
2527 -- get a match (either we are not an argument, or the
2528 -- mode of the formal is not OUT). This test also filters
2529 -- out the generic case.
2533 then
2534 -- This is the loop through parameters, looking to
2535 -- see if there is an OUT parameter for which we are
2536 -- the argument.
2555 -- If we fall through, a validity check is required. Note that it would
2556 -- not be good to set Do_Range_Check, even in contexts where this is
2557 -- permissible, since this flag causes checking against the target type,
2558 -- not the source type in contexts such as assignments
2563 ----------------------
2564 -- Expr_Known_Valid --
2565 ----------------------
2570 begin
2571 -- Non-scalar types are always consdered valid, since they never
2572 -- give rise to the issues of erroneous or bounded error behavior
2573 -- that are the concern. In formal reference manual terms the
2574 -- notion of validity only applies to scalar types.
2579 -- If no validity checking, then everything is considered valid
2584 -- Floating-point types are considered valid unless floating-point
2585 -- validity checks have been specifically turned on.
2588 and then not Validity_Check_Floating_Point
2589 then
2592 -- If the expression is the value of an object that is known to
2593 -- be valid, then clearly the expression value itself is valid.
2597 then
2600 -- If the type is one for which all values are known valid, then
2601 -- we are sure that the value is valid except in the slightly odd
2602 -- case where the expression is a reference to a variable whose size
2603 -- has been explicitly set to a value greater than the object size.
2609 then
2611 else
2615 -- Integer and character literals always have valid values, where
2616 -- appropriate these will be range checked in any case.
2619 or else
2621 then
2624 -- If we have a type conversion or a qualification of a known valid
2625 -- value, then the result will always be valid.
2628 or else
2630 then
2633 -- The result of any function call or operator is always considered
2634 -- valid, since we assume the necessary checks are done by the call.
2637 or else
2639 or else
2641 then
2644 -- For all other cases, we do not know the expression is valid
2646 else
2651 ---------------------
2652 -- Get_Discriminal --
2653 ---------------------
2660 begin
2661 -- The entity E is the type of a private component of the protected
2662 -- type, or the type of a renaming of that component within a protected
2663 -- operation of that type.
2679 loop
2686 ------------------
2687 -- Guard_Access --
2688 ------------------
2690 function Guard_Access
2694 return Node_Id
2695 is
2696 begin
2703 else
2704 return
2706 Left_Opnd =>
2714 -----------------------------
2715 -- Index_Checks_Suppressed --
2716 -----------------------------
2719 begin
2724 ----------------
2725 -- Initialize --
2726 ----------------
2729 begin
2735 -------------------------
2736 -- Insert_Range_Checks --
2737 -------------------------
2739 procedure Insert_Range_Checks
2746 is
2753 or else
2756 begin
2757 -- For now we just return if Checks_On is false, however this should
2758 -- be enhanced to check for an always True value in the condition
2759 -- and to generate a compilation warning???
2778 then
2785 else
2792 else
2793 Check_Node :=
2800 else
2807 ------------------------
2808 -- Insert_Valid_Check --
2809 ------------------------
2815 begin
2816 -- Do not insert if checks off, or if not checking validity
2820 then
2824 -- If we have a checked conversion, then validity check applies to
2825 -- the expression inside the conversion, not the result, since if
2826 -- the expression inside is valid, then so is the conversion result.
2833 -- Insert the validity check. Note that we do this with validity
2834 -- checks turned off, to avoid recursion, we do not want validity
2835 -- checks on the validity checking code itself!
2838 Insert_Action
2841 Condition =>
2843 Right_Opnd =>
2845 Prefix =>
2853 --------------------------
2854 -- Install_Static_Check --
2855 --------------------------
2861 begin
2871 ------------------------------
2872 -- Length_Checks_Suppressed --
2873 ------------------------------
2876 begin
2881 --------------------------------
2882 -- Overflow_Checks_Suppressed --
2883 --------------------------------
2886 begin
2891 -----------------
2892 -- Range_Check --
2893 -----------------
2895 function Range_Check
2900 return Check_Result
2901 is
2902 begin
2903 return Selected_Range_Checks
2907 -----------------------------
2908 -- Range_Checks_Suppressed --
2909 -----------------------------
2912 begin
2913 -- Note: for now we always suppress range checks on Vax float types,
2914 -- since Gigi does not know how to generate these checks.
2921 ----------------------------
2922 -- Selected_Length_Checks --
2923 ----------------------------
2925 function Selected_Length_Checks
2930 return Check_Result
2931 is
2944 -- Adds the action given to Ret_Result if N is non-Empty
2950 -- True for equal literals and for nodes that denote the same constant
2951 -- entity, even if its value is not a static constant. This includes the
2952 -- case of a discriminal reference within an init_proc. Removes some
2953 -- obviously superfluous checks.
2955 function Length_E_Cond
2960 -- Returns expression to compute:
2961 -- Typ'Length /= Exptyp'Length
2963 function Length_N_Cond
2968 -- Returns expression to compute:
2969 -- Typ'Length /= Expr'Length
2971 ---------------
2972 -- Add_Check --
2973 ---------------
2976 begin
2979 -- For now, ignore attempt to place more than 2 checks ???
2991 ------------------
2992 -- Get_E_Length --
2993 ------------------
3000 begin
3003 then
3013 return
3020 and then not Inside_Init_Proc
3021 then
3023 -- If the type whose length is needed is a private component
3024 -- constrained by a discriminant, we must expand the 'Length
3025 -- attribute into an explicit computation, using the discriminal
3026 -- of the current protected operation. This is because the actual
3027 -- type of the prival is constructed after the protected opera-
3028 -- tion has been fully expanded.
3030 declare
3036 begin
3047 then
3054 then
3068 N :=
3070 Left_Opnd =>
3078 else
3079 N :=
3082 Prefix =>
3094 else
3095 N :=
3098 Prefix =>
3111 ------------------
3112 -- Get_N_Length --
3113 ------------------
3116 begin
3117 return
3120 Prefix =>
3127 -------------------
3128 -- Length_E_Cond --
3129 -------------------
3131 function Length_E_Cond
3135 return Node_Id
3136 is
3137 begin
3138 return
3145 -------------------
3146 -- Length_N_Cond --
3147 -------------------
3149 function Length_N_Cond
3153 return Node_Id
3154 is
3155 begin
3156 return
3164 begin
3165 return
3170 or else
3175 or else
3180 or else
3187 or else
3195 -- Start of processing for Selected_Length_Checks
3197 begin
3205 then
3217 else
3230 -- A simple optimization
3240 -- The checking code to be generated will freeze the
3241 -- corresponding array type. However, we must freeze the
3242 -- type now, so that the freeze node does not appear within
3243 -- the generated condional expression, but ahead of it.
3254 -- String_Literal case. This needs to be handled specially be-
3255 -- cause no index types are available for string literals. The
3256 -- condition is simply:
3258 -- T_Typ'Length = string-literal-length
3261 Cond :=
3264 Right_Opnd =>
3266 Intval =>
3269 -- General array case. Here we have a usable actual subtype for
3270 -- the expression, and the condition is built from the two types
3271 -- (Do_Length):
3273 -- T_Typ'Length /= Exptyp'Length or else
3274 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
3275 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
3276 -- ...
3279 declare
3292 begin
3298 or else
3300 then
3304 -- Deal with compile time length check. Note that we
3305 -- skip this in the access case, because the access
3306 -- value may be null, so we cannot know statically.
3308 if not Do_Access
3313 then
3317 else
3324 else
3329 Add_Check
3330 (Compile_Time_Constraint_Error
3334 Add_Check
3335 (Compile_Time_Constraint_Error
3339 -- The comparison for an individual index subtype
3340 -- is omitted if the corresponding index subtypes
3341 -- statically match, since the result is known to
3342 -- be true. Note that this test is worth while even
3343 -- though we do static evaluation, because non-static
3344 -- subtypes can statically match.
3346 elsif not
3347 Subtypes_Statically_Match
3350 and then not
3353 then
3354 Evolve_Or_Else
3364 -- Handle cases where we do not get a usable actual subtype that
3365 -- is constrained. This happens for example in the function call
3366 -- and explicit dereference cases. In these cases, we have to get
3367 -- the length or range from the expression itself, making sure we
3368 -- do not evaluate it more than once.
3370 -- Here Ck_Node is the original expression, or more properly the
3371 -- result of applying Duplicate_Expr to the original tree,
3372 -- forcing the result to be a name.
3374 else
3375 declare
3378 begin
3379 -- Build the condition for the explicit dereference case
3382 Evolve_Or_Else
3390 -- Construct the test and insert into the tree
3397 Add_Check
3406 ---------------------------
3407 -- Selected_Range_Checks --
3408 ---------------------------
3410 function Selected_Range_Checks
3415 return Check_Result
3416 is
3429 -- Adds the action given to Ret_Result if N is non-Empty
3431 function Discrete_Range_Cond
3435 -- Returns expression to compute:
3436 -- Low_Bound (Expr) < Typ'First
3437 -- or else
3438 -- High_Bound (Expr) > Typ'Last
3440 function Discrete_Expr_Cond
3444 -- Returns expression to compute:
3445 -- Expr < Typ'First
3446 -- or else
3447 -- Expr > Typ'Last
3449 function Get_E_First_Or_Last
3454 -- Returns expression to compute:
3455 -- E'First or E'Last
3459 -- Returns expression to compute:
3460 -- N'First or N'Last using Duplicate_Subexpr
3462 function Range_E_Cond
3467 -- Returns expression to compute:
3468 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
3470 function Range_Equal_E_Cond
3475 -- Returns expression to compute:
3476 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
3478 function Range_N_Cond
3483 -- Return expression to compute:
3484 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
3486 ---------------
3487 -- Add_Check --
3488 ---------------
3491 begin
3494 -- For now, ignore attempt to place more than 2 checks ???
3506 -------------------------
3507 -- Discrete_Expr_Cond --
3508 -------------------------
3510 function Discrete_Expr_Cond
3513 return Node_Id
3514 is
3515 begin
3516 return
3518 Left_Opnd =>
3520 Left_Opnd =>
3522 Right_Opnd =>
3526 Right_Opnd =>
3528 Left_Opnd =>
3530 Right_Opnd =>
3531 Convert_To
3536 -------------------------
3537 -- Discrete_Range_Cond --
3538 -------------------------
3540 function Discrete_Range_Cond
3543 return Node_Id
3544 is
3551 begin
3562 Left_Opnd :=
3564 Left_Opnd =>
3565 Convert_To
3568 Right_Opnd =>
3569 Convert_To
3576 and then
3579 then
3583 then
3587 else
3590 then
3596 Right_Opnd :=
3598 Left_Opnd =>
3599 Convert_To
3602 Right_Opnd =>
3603 Convert_To
3610 -------------------------
3611 -- Get_E_First_Or_Last --
3612 -------------------------
3614 function Get_E_First_Or_Last
3618 return Node_Id
3619 is
3625 begin
3633 else
3645 else
3652 else
3658 then
3663 and then not Inside_Init_Proc
3664 then
3670 else
3675 -----------------
3676 -- Get_N_First --
3677 -----------------
3680 begin
3681 return
3684 Prefix =>
3691 ----------------
3692 -- Get_N_Last --
3693 ----------------
3696 begin
3697 return
3700 Prefix =>
3707 ------------------
3708 -- Range_E_Cond --
3709 ------------------
3711 function Range_E_Cond
3715 return Node_Id
3716 is
3717 begin
3718 return
3720 Left_Opnd =>
3725 Right_Opnd =>
3732 ------------------------
3733 -- Range_Equal_E_Cond --
3734 ------------------------
3736 function Range_Equal_E_Cond
3740 return Node_Id
3741 is
3742 begin
3743 return
3745 Left_Opnd =>
3749 Right_Opnd =>
3755 ------------------
3756 -- Range_N_Cond --
3757 ------------------
3759 function Range_N_Cond
3763 return Node_Id
3764 is
3765 begin
3766 return
3768 Left_Opnd =>
3773 Right_Opnd =>
3779 -- Start of processing for Selected_Range_Checks
3781 begin
3789 then
3801 else
3809 -- The order of evaluating T_Typ before S_Typ seems to be critical
3810 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
3811 -- in, and since Node can be an N_Range node, it might be invalid.
3812 -- Should there be an assert check somewhere for taking the Etype of
3813 -- an N_Range node ???
3820 -- A simple optimization
3827 -- For an N_Range Node, check for a null range and then if not
3828 -- null generate a range check action.
3832 -- There's no point in checking a range against itself
3838 declare
3848 begin
3849 -- Check for case where everything is static and we can
3850 -- do the check at compile time. This is skipped if we
3851 -- have an access type, since the access value may be null.
3853 -- ??? This code can be improved since you only need to know
3854 -- that the two respective bounds (LB & T_LB or HB & T_HB)
3855 -- are known at compile time to emit pertinent messages.
3861 and then not Do_Access
3862 then
3863 -- Floating-point case
3867 Out_Of_Range_L :=
3869 or else
3872 Out_Of_Range_H :=
3874 or else
3877 -- Fixed or discrete type case
3879 else
3881 Out_Of_Range_L :=
3883 or else
3886 Out_Of_Range_H :=
3888 or else
3895 Add_Check
3896 (Compile_Time_Constraint_Error
3900 else
3901 Add_Check
3902 (Compile_Time_Constraint_Error
3910 Add_Check
3911 (Compile_Time_Constraint_Error
3915 else
3916 Add_Check
3917 (Compile_Time_Constraint_Error
3925 else
3926 declare
3930 begin
3932 -- If either bound is a discriminant and we are within
3933 -- the record declaration, it is a use of the discriminant
3934 -- in a constraint of a component, and nothing can be
3935 -- checked here. The check will be emitted within the
3936 -- init_proc. Before then, the discriminal has no real
3937 -- meaning.
3941 then
3944 else
3945 LB :=
3952 then
3955 else
3956 HB :=
3964 Cond :=
3966 Left_Opnd =>
3978 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
3979 -- except the above simply sets a flag in the node and lets
3980 -- gigi generate the check base on the Etype of the expression.
3981 -- Sometimes, however we want to do a dynamic check against an
3982 -- arbitrary target type, so we do that here.
3987 -- For literals, we can tell if the constraint error will be
3988 -- raised at compile time, so we never need a dynamic check, but
3989 -- if the exception will be raised, then post the usual warning,
3990 -- and replace the literal with a raise constraint error
3991 -- expression. As usual, skip this for access types
3994 and then not Do_Access
3995 then
3996 declare
4005 begin
4006 -- Following range tests should use Sem_Eval routine ???
4010 Out_Of_Range :=
4012 or else
4016 Out_Of_Range :=
4018 or else
4022 -- Bounds of the type are static and the literal is
4023 -- out of range so make a warning message.
4027 Add_Check
4028 (Compile_Time_Constraint_Error
4032 else
4033 Add_Check
4034 (Compile_Time_Constraint_Error
4040 else
4045 -- Here for the case of a non-static expression, we need a runtime
4046 -- check unless the source type range is guaranteed to be in the
4047 -- range of the target type.
4049 else
4066 -- String_Literal case. This needs to be handled specially be-
4067 -- cause no index types are available for string literals. The
4068 -- condition is simply:
4070 -- T_Typ'Length = string-literal-length
4075 -- General array case. Here we have a usable actual subtype for
4076 -- the expression, and the condition is built from the two types
4078 -- T_Typ'First < Exptyp'First or else
4079 -- T_Typ'Last > Exptyp'Last or else
4080 -- T_Typ'First(1) < Exptyp'First(1) or else
4081 -- T_Typ'Last(1) > Exptyp'Last(1) or else
4082 -- ...
4085 declare
4095 begin
4101 or else
4103 then
4107 -- Deal with compile time length check. Note that we
4108 -- skip this in the access case, because the access
4109 -- value may be null, so we cannot know statically.
4111 if not
4112 Subtypes_Statically_Match
4114 then
4115 -- If the target type is constrained then we
4116 -- have to check for exact equality of bounds
4117 -- (required for qualified expressions).
4120 Evolve_Or_Else
4124 else
4125 Evolve_Or_Else
4137 -- Handle cases where we do not get a usable actual subtype that
4138 -- is constrained. This happens for example in the function call
4139 -- and explicit dereference cases. In these cases, we have to get
4140 -- the length or range from the expression itself, making sure we
4141 -- do not evaluate it more than once.
4143 -- Here Ck_Node is the original expression, or more properly the
4144 -- result of applying Duplicate_Expr to the original tree,
4145 -- forcing the result to be a name.
4147 else
4148 declare
4151 begin
4152 -- Build the condition for the explicit dereference case
4155 Evolve_Or_Else
4162 else
4163 -- Generate an Action to check that the bounds of the
4164 -- source value are within the constraints imposed by the
4165 -- target type for a conversion to an unconstrained type.
4166 -- Rule is 4.6(38).
4169 declare
4173 begin
4174 Opnd_Index
4180 if Is_In_Range
4182 and then
4183 Is_In_Range
4185 then
4188 elsif Is_Out_Of_Range
4190 or else
4191 Is_Out_Of_Range
4193 then
4194 Add_Check
4195 (Compile_Time_Constraint_Error
4198 else
4199 Evolve_Or_Else
4201 Discrete_Range_Cond
4214 -- Construct the test and insert into the tree
4221 Add_Check
4230 -------------------------------
4231 -- Storage_Checks_Suppressed --
4232 -------------------------------
4235 begin
4240 ---------------------------
4241 -- Tag_Checks_Suppressed --
4242 ---------------------------
4245 begin