| blob | 45e902bccff692438cd02c7caa29907b64003f4f |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ R E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 -- Second pass (top-down) type checking and overload resolution procedures
81 -- Typ is the type required by context. These procedures propagate the
82 -- type information recursively to the descendants of N. If the node
83 -- is not overloaded, its Etype is established in the first pass. If
84 -- overloaded, the Resolve routines set the correct type. For arith.
85 -- operators, the Etype is the base type of the context.
87 -- Note that Resolve_Attribute is separated off in Sem_Attr
90 -- Give list of candidate interpretations when a character literal cannot
91 -- be resolved.
94 -- N is a binary operator node which may possibly operate on Boolean
95 -- operands. If the operator does have Boolean operands, then a call is
96 -- made to check the restriction No_Direct_Boolean_Operators.
99 -- Enforce the restrictions on the use of discriminants when constraining
100 -- a component of a discriminated type (record or concurrent type).
103 -- Given a node for an operator associated with type T, check that
104 -- the operator is visible. Operators all of whose operands are
105 -- universal must be checked for visibility during resolution
106 -- because their type is not determinable based on their operands.
109 -- Given a call node, N, which is known to occur immediately within the
110 -- subprogram being called, determines whether it is a detectable case of
111 -- an infinite recursion, and if so, outputs appropriate messages. Returns
112 -- True if an infinite recursion is detected, and False otherwise.
115 -- If the type of the object being initialized uses the secondary stack
116 -- directly or indirectly, create a transient scope for the call to the
117 -- init proc. This is because we do not create transient scopes for the
118 -- initialization of individual components within the init proc itself.
119 -- Could be optimized away perhaps?
122 -- Utility to check whether the name in the call is a predefined
123 -- operator, in which case the call is made into an operator node.
124 -- An instance of an intrinsic conversion operation may be given
125 -- an operator name, but is not treated like an operator.
128 -- If a default expression in entry call N depends on the discriminants
129 -- of the task, it must be replaced with a reference to the discriminant
130 -- of the task being called.
165 function Operator_Kind
168 -- Utility to map the name of an operator into the corresponding Node. Used
169 -- by other node rewriting procedures.
172 -- Resolve actuals of call, and add default expressions for missing ones.
173 -- N is the Node_Id for the subprogram call, and Nam is the entity of the
174 -- called subprogram.
177 -- Called from Resolve_Call, when the prefix denotes an entry or element
178 -- of entry family. Actuals are resolved as for subprograms, and the node
179 -- is rebuilt as an entry call. Also called for protected operations. Typ
180 -- is the context type, which is used when the operation is a protected
181 -- function with no arguments, and the return value is indexed.
184 -- A call to a user-defined intrinsic operator is rewritten as a call
185 -- to the corresponding predefined operator, with suitable conversions.
188 -- Ditto, for unary operators (only arithmetic ones)
191 -- If an operator node resolves to a call to a user-defined operator,
192 -- rewrite the node as a function call.
194 procedure Make_Call_Into_Operator
198 -- Inverse transformation: if an operator is given in functional notation,
199 -- then after resolving the node, transform into an operator node, so
200 -- that operands are resolved properly. Recall that predefined operators
201 -- do not have a full signature and special resolution rules apply.
203 procedure Rewrite_Renamed_Operator
207 -- An operator can rename another, e.g. in an instantiation. In that
208 -- case, the proper operator node must be constructed and resolved.
211 -- The String_Literal_Subtype is built for all strings that are not
212 -- operands of a static concatenation operation. If the argument is
213 -- not a N_String_Literal node, then the call has no effect.
216 -- Build subtype of array type, with the range specified by the slice
219 -- A universal_fixed expression in an universal context is unambiguous
220 -- if there is only one applicable fixed point type. Determining whether
221 -- there is only one requires a search over all visible entities, and
222 -- happens only in very pathological cases (see 6115-006).
224 function Valid_Conversion
228 -- Verify legality rules given in 4.6 (8-23). Target is the target
229 -- type of the conversion, which may be an implicit conversion of
230 -- an actual parameter to an anonymous access type (in which case
231 -- N denotes the actual parameter and N = Operand).
233 -------------------------
234 -- Ambiguous_Character --
235 -------------------------
240 begin
243 Error_Msg_N
254 -------------------------
255 -- Analyze_And_Resolve --
256 -------------------------
259 begin
265 begin
270 -- Version withs check(s) suppressed
272 procedure Analyze_And_Resolve
276 is
279 begin
281 declare
283 begin
289 else
290 declare
293 begin
301 and then Scope_Is_Transient
302 then
303 -- This can only happen if a transient scope was created
304 -- for an inner expression, which will be removed upon
305 -- completion of the analysis of an enclosing construct.
306 -- The transient scope must have the suppress status of
307 -- the enclosing environment, not of this Analyze call.
310 Scope_Suppress;
314 procedure Analyze_And_Resolve
317 is
320 begin
322 declare
324 begin
330 else
331 declare
334 begin
342 and then Scope_Is_Transient
343 then
345 Scope_Suppress;
349 -----------------------------
350 -- Check_Direct_Boolean_Op --
351 -----------------------------
354 begin
357 then
362 ----------------------------
363 -- Check_Discriminant_Use --
364 ----------------------------
372 begin
373 -- Any use in a default expression is legal
380 -- Discriminant cannot be used to constrain a scalar type
387 then
392 -- The following check catches the unusual case where
393 -- a discriminant appears within an index constraint
394 -- that is part of a larger expression within a constraint
395 -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
396 -- For now we only check case of record components, and
397 -- note that a similar check should also apply in the
398 -- case of discriminant constraints below. ???
400 -- Note that the check for N_Subtype_Declaration below is to
401 -- detect the valid use of discriminants in the constraints of a
402 -- subtype declaration when this subtype declaration appears
403 -- inside the scope of a record type (which is syntactically
404 -- illegal, but which may be created as part of derived type
405 -- processing for records). See Sem_Ch3.Build_Derived_Record_Type
406 -- for more info.
410 and then not
412 and then
414 or else
417 then
418 Error_Msg_N
423 -- Detect a common beginner error:
425 -- type R (D : Positive := 100) is record
426 -- Name : String (1 .. D);
427 -- end record;
429 -- The default value causes an object of type R to be
430 -- allocated with room for Positive'Last characters.
432 declare
439 -- Return True if type T has a large enough range that
440 -- any array whose index type covered the whole range of
441 -- the type would likely raise Storage_Error.
443 ------------------------
444 -- Large_Storage_Type --
445 ------------------------
448 begin
449 return
450 T = Standard_Integer
451 or else
452 T = Standard_Positive
453 or else
457 begin
458 -- Check that the Disc has a large range
464 -- If the enclosing type is limited, we allocate only the
465 -- default value, not the maximum, and there is no need for
466 -- a warning.
472 -- Check that it is the high bound
476 then
480 -- Check the array allows a large range at this bound.
481 -- First find the array
495 -- Next, find the dimension
503 loop
512 -- Now, check the dimension has a large range
518 -- Warn about the danger
520 Error_Msg_N
530 -- Legal case is in index or discriminant constraint
534 then
536 Error_Msg_N
541 then
542 Error_Msg_N
548 -- Otherwise, context is an expression. It should not be within
549 -- (i.e. a subexpression of) a constraint for a component.
551 else
557 loop
563 -- If the discriminant is used in an expression that is a bound
564 -- of a scalar type, an Itype is created and the bounds are attached
565 -- to its range, not to the original subtype indication. Such use
566 -- is of course a double fault.
569 and then
571 or else
575 -- The constraint itself may be given by a subtype indication,
576 -- rather than by a more common discrete range.
579 and then
583 then
584 Error_Msg_N
590 --------------------------------
591 -- Check_For_Visible_Operator --
592 --------------------------------
595 begin
597 Error_Msg_NE
603 ------------------------------
604 -- Check_Infinite_Recursion --
605 ------------------------------
612 -- Check whether list of actuals is identical to list of formals
613 -- of called function (which is also the enclosing scope).
615 ------------------------
616 -- Same_Argument_List --
617 ------------------------
624 begin
627 else
636 then
647 -- Start of processing for Check_Infinite_Recursion
649 begin
650 -- Loop moving up tree, quitting if something tells us we are
651 -- definitely not in an infinite recursion situation.
654 loop
662 then
667 then
668 -- If the call is the expression of a return statement and
669 -- the actuals are identical to the formals, it's worth a
670 -- warning. However, we skip this if there is an immediately
671 -- preceding raise statement, since the call is never executed.
673 -- Furthermore, this corresponds to a common idiom:
675 -- function F (L : Thing) return Boolean is
676 -- begin
677 -- raise Program_Error;
678 -- return F (L);
679 -- end F;
681 -- for generating a stub function
684 and then Same_Argument_List
685 then
688 -- OK, return statement is in a statement list, look for raise
690 declare
693 begin
694 -- Skip past N_Freeze_Entity nodes generated by expansion
699 loop
703 -- If no raise statement, give warning
706 and then
714 else
725 -------------------------------
726 -- Check_Initialization_Call --
727 -------------------------------
733 -- Check whether the creation of an object of the type will involve
734 -- use of the secondary stack. If T is a record type, this is true
735 -- if the expression for some component uses the secondary stack, eg.
736 -- through a call to a function that returns an unconstrained value.
737 -- False if T is controlled, because cleanups occur elsewhere.
739 -------------
740 -- Uses_SS --
741 -------------
747 begin
759 then
762 -- The expression for a dynamic component may be
763 -- rewritten as a dereference. Retrieve original
764 -- call.
768 then
781 else
786 -- Start of processing for Check_Initialization_Call
788 begin
789 -- Nothing to do if functions do not use the secondary stack for
790 -- returns (i.e. they use a depressed stack pointer instead).
795 -- Otherwise establish a transient scope if the type needs it
802 ------------------------------
803 -- Check_Parameterless_Call --
804 ------------------------------
810 -- If the prefix is of an access_to_subprogram type, the node must be
811 -- rewritten as a call. Ditto if the prefix is overloaded and all its
812 -- interpretations are access to subprograms.
814 ---------------------------
815 -- Prefix_Is_Access_Subp --
816 ---------------------------
822 begin
824 return
827 else
832 then
843 -- Start of processing for Check_Parameterless_Call
845 begin
846 -- Defend against junk stuff if errors already detected
853 then
860 -- If the context expects a value, and the name is a procedure,
861 -- this is most likely a missing 'Access. Do not try to resolve
862 -- the parameterless call, error will be caught when the outer
863 -- call is analyzed.
868 and then
872 then
876 -- Rewrite as call if overloadable entity that is (or could be, in
877 -- the overloaded case) a function call. If we know for sure that
878 -- the entity is an enumeration literal, we do not rewrite it.
885 -- Rewrite as call if it is an explicit deference of an expression of
886 -- a subprogram access type, and the suprogram type is not that of a
887 -- procedure or entry.
889 or else
892 -- Rewrite as call if it is a selected component which is a function,
893 -- this is the case of a call to a protected function (which may be
894 -- overloaded with other protected operations).
896 or else
899 or else
901 or else
905 -- If one of the above three conditions is met, rewrite as call.
906 -- Apply the rewriting only once.
908 then
911 then
914 -- If overloaded, overload set belongs to new copy
918 -- Change node to parameterless function call (note that the
919 -- Parameter_Associations associations field is left set to Empty,
920 -- its normal default value since there are no parameters)
933 ----------------------
934 -- Is_Predefined_Op --
935 ----------------------
938 begin
946 -----------------------------
947 -- Make_Call_Into_Operator --
948 -----------------------------
950 procedure Make_Call_Into_Operator
954 is
969 -- Determine whether E is an access type declared by an access decla-
970 -- ration, and not an (anonymous) allocator type.
973 -- If the operand is not universal, and the operator is given by a
974 -- expanded name, verify that the operand has an interpretation with
975 -- a type defined in the given scope of the operator.
978 -- Find a type of the given class in the package Pack that contains
979 -- the operator.
981 -----------------------------
982 -- Is_Definite_Access_Type --
983 -----------------------------
987 begin
993 ---------------------------
994 -- Operand_Type_In_Scope --
995 ---------------------------
1002 begin
1006 else
1020 ---------------
1021 -- Type_In_P --
1022 ---------------
1028 -- Verify that node is not part of the type declaration for the
1029 -- candidate type, which would otherwise be invisible.
1031 -------------
1032 -- In_Decl --
1033 -------------
1039 begin
1048 else
1051 loop
1054 else
1063 -- Start of processing for Type_In_P
1065 begin
1066 -- If the context type is declared in the prefix package, this
1067 -- is the desired base type.
1071 then
1074 else
1078 and then not In_Decl
1079 then
1090 -- Start of processing for Make_Call_Into_Operator
1092 begin
1095 -- Binary operator
1105 -- Unary operator
1107 else
1113 -- If the operator is denoted by an expanded name, and the prefix is
1114 -- not Standard, but the operator is a predefined one whose scope is
1115 -- Standard, then this is an implicit_operator, inserted as an
1116 -- interpretation by the procedure of the same name. This procedure
1117 -- overestimates the presence of implicit operators, because it does
1118 -- not examine the type of the operands. Verify now that the operand
1119 -- type appears in the given scope. If right operand is universal,
1120 -- check the other operand. In the case of concatenation, either
1121 -- argument can be the component type, so check the type of the result.
1122 -- If both arguments are literals, look for a type of the right kind
1123 -- defined in the given scope. This elaborate nonsense is brought to
1124 -- you courtesy of b33302a. The type itself must be frozen, so we must
1125 -- find the type of the proper class in the given scope.
1127 -- A final wrinkle is the multiplication operator for fixed point
1128 -- types, which is defined in Standard only, and not in the scope of
1129 -- the fixed_point type itself.
1134 -- If the entity being called is defined in the given package,
1135 -- it is a renaming of a predefined operator, and known to be
1136 -- legal.
1140 then
1143 -- Visibility does not need to be checked in an instance: if the
1144 -- operator was not visible in the generic it has been diagnosed
1145 -- already, else there is an implicit copy of it in the instance.
1154 then
1159 else
1168 and then Is_Binary
1170 then
1176 -- Verify that the scope contains a type that corresponds to
1177 -- the given literal. Optimize the case where Pack is Standard.
1199 else
1208 else
1217 then
1220 -- If the type is defined elsewhere, and the operator is not
1221 -- defined in the given scope (by a renaming declaration, e.g.)
1222 -- then this is an error as well. If an extension of System is
1223 -- present, and the type may be defined there, Pack must be
1224 -- System itself.
1231 then
1234 else
1240 then
1247 Error_Msg_NE
1258 else
1262 -- If this is a call to a function that renames a predefined equality,
1263 -- the renaming declaration provides a type that must be used to
1264 -- resolve the operands. This must be done now because resolution of
1265 -- the equality node will not resolve any remaining ambiguity, and it
1266 -- assumes that the first operand is not overloaded.
1271 then
1280 -- If this is an arithmetic operator and the result type is private,
1281 -- the operands and the result must be wrapped in conversion to
1282 -- expose the underlying numeric type and expand the proper checks,
1283 -- e.g. on division.
1287 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
1288 N_Op_Expon | N_Op_Mod | N_Op_Rem =>
1297 else
1301 -- For predefined operators on literals, the operation freezes
1302 -- their type.
1310 -------------------
1311 -- Operator_Kind --
1312 -------------------
1314 function Operator_Kind
1317 is
1320 begin
1339 else
1343 -- Unary operators
1345 else
1350 else
1358 -----------------------------
1359 -- Pre_Analyze_And_Resolve --
1360 -----------------------------
1365 begin
1369 -- We suppress all checks for this analysis, since the checks will
1370 -- be applied properly, and in the right location, when the default
1371 -- expression is reanalyzed and reexpanded later on.
1375 Expander_Mode_Restore;
1379 -- Version without context type
1384 begin
1391 Expander_Mode_Restore;
1395 ----------------------------------
1396 -- Replace_Actual_Discriminants --
1397 ----------------------------------
1405 -------------------
1406 -- Process_Discr --
1407 -------------------
1412 begin
1418 then
1434 -- Start of processing for Replace_Actual_Discriminants
1436 begin
1450 else
1455 -------------
1456 -- Resolve --
1457 -------------
1472 -- Try and fix up a literal so that it matches its expected type. New
1473 -- literals are manufactured if necessary to avoid cascaded errors.
1476 -- Called when attempt at resolving current expression fails
1478 --------------------
1479 -- Patch_Up_Value --
1480 --------------------
1483 begin
1486 then
1495 then
1503 then
1508 Char_Literal_Value =>
1515 then
1526 -----------------------
1527 -- Resolution_Failed --
1528 -----------------------
1531 begin
1537 -- The caller will return without calling the expander, so we need
1538 -- to set the analyzed flag. Note that it is fine to set Analyzed
1539 -- to True even if we are in the middle of a shallow analysis,
1540 -- (see the spec of sem for more details) since this is an error
1541 -- situation anyway, and there is no point in repeating the
1542 -- analysis later (indeed it won't work to repeat it later, since
1543 -- we haven't got a clear resolution of which entity is being
1544 -- referenced.)
1550 -- Start of processing for Resolve
1552 begin
1557 -- Access attribute on remote subprogram cannot be used for
1558 -- a non-remote access-to-subprogram type.
1569 then
1570 Error_Msg_N
1574 -- If the context is a Remote_Access_To_Subprogram, access attributes
1575 -- must be resolved with the corresponding fat pointer. There is no need
1576 -- to check for the attribute name since the return type of an
1577 -- attribute is never a remote type.
1583 then
1584 declare
1592 begin
1593 -- Check that Typ is a remote access-to-subprogram type
1596 -- Prefix (N) must statically denote a remote subprogram
1597 -- declared in a package specification.
1614 or else
1616 then
1618 Error_Msg_N
1620 N);
1624 -- If we are generating code for a distributed program.
1625 -- perform semantic checks against the corresponding
1626 -- remote entities.
1631 and then Expander_Active
1633 then
1634 Check_Subtype_Conformant
1636 Old_Id => Designated_Type
1656 then
1661 -- Return if already analyzed
1667 -- Return if type = Any_Type (previous error encountered)
1676 -- If not overloaded, then we know the type, and all that needs doing
1677 -- is to check that this type is compatible with the context.
1683 -- In the overloaded case, we must select the interpretation that
1684 -- is compatible with the context (i.e. the type passed to Resolve)
1686 else
1687 -- Loop through possible interpretations
1692 -- We are only interested in interpretations that are compatible
1693 -- with the expected type, any other interpretations are ignored
1698 Write_Eol;
1701 else
1702 -- First matching interpretation
1710 -- Matching interpretation that is not the first, maybe an
1711 -- error, but there are some cases where preference rules are
1712 -- used to choose between the two possibilities. These and
1713 -- some more obscure cases are handled in Disambiguate.
1715 else
1719 -- Disambiguation has succeeded. Skip the remaining
1720 -- interpretations.
1730 else
1731 -- Before we issue an ambiguity complaint, check for
1732 -- the case of a subprogram call where at least one
1733 -- of the arguments is Any_Type, and if so, suppress
1734 -- the message, since it is a cascaded error.
1738 then
1739 declare
1743 begin
1755 Write_Eol;
1768 then
1773 then
1777 -- Not that special case, so issue message using the
1778 -- flag Ambiguous to control printing of the header
1779 -- message only at the start of an ambiguous set.
1782 Error_Msg_NE
1786 Error_Msg_N
1793 -- By default, the error message refers to the candidate
1794 -- interpretation. But if it is a predefined operator,
1795 -- it is implicitly declared at the declaration of
1796 -- the type of the operand. Recover the sloc of that
1797 -- declaration for the error message.
1803 /= Standard_Standard
1804 then
1809 then
1817 /= Standard_Standard
1818 then
1823 then
1826 else
1833 then
1834 Error_Msg_N
1836 else
1843 -- We have a matching interpretation, Expr_Type is the
1844 -- type from this interpretation, and Seen is the entity.
1846 -- For an operator, just set the entity name. The type will
1847 -- be set by the specific operator resolution routine.
1856 -- For an explicit dereference, attribute reference, range,
1857 -- short-circuit form (which is not an operator node),
1858 -- or a call with a name that is an explicit dereference,
1859 -- there is nothing to be done at this point.
1870 then
1873 -- For procedure or function calls, set the type of the
1874 -- name, and also the entity pointer for the prefix
1880 then
1887 then
1892 -- For all other cases, just set the type of the Name
1894 else
1900 -- Move to next interpretation
1908 -- At this stage Found indicates whether or not an acceptable
1909 -- interpretation exists. If not, then we have an error, except
1910 -- that if the context is Any_Type as a result of some other error,
1911 -- then we suppress the error report.
1916 -- If type we are looking for is Void, then this is the
1917 -- procedure call case, and the error is simply that what
1918 -- we gave is not a procedure name (we think of procedure
1919 -- calls as expressions with types internally, but the user
1920 -- doesn't think of them this way!)
1924 -- Special case message if function used as a procedure
1929 then
1930 Error_Msg_NE
1934 -- Otherwise give general message (not clear what cases
1935 -- this covers, but no harm in providing for them!)
1937 else
1943 -- Otherwise we do have a subexpression with the wrong type
1945 -- Check for the case of an allocator which uses an access
1946 -- type instead of the designated type. This is a common
1947 -- error and we specialize the message, posting an error
1948 -- on the operand of the allocator, complaining that we
1949 -- expected the designated type of the allocator.
1955 then
1959 -- Check for view mismatch on Null in instances, for
1960 -- which the view-swapping mechanism has no identifier.
1966 then
1971 -- Check for an aggregate. Sometimes we can get bogus
1972 -- aggregates from misuse of parentheses, and we are
1973 -- about to complain about the aggregate without even
1974 -- looking inside it.
1976 -- Instead, if we have an aggregate of type Any_Composite,
1977 -- then analyze and resolve the component fields, and then
1978 -- only issue another message if we get no errors doing
1979 -- this (otherwise assume that the errors in the aggregate
1980 -- caused the problem).
1984 then
1985 -- Disable expansion in any case. If there is a type mismatch
1986 -- it may be fatal to try to expand the aggregate. The flag
1987 -- would otherwise be set to false when the error is posted.
1991 declare
1993 -- Check one aggregate, and set Found to True if we
1994 -- have a definite error in any of its elements
1997 -- Check one element of aggregate and set Found to
1998 -- True if we definitely have an error in the element.
2003 begin
2021 ----------------
2022 -- Check_Elmt --
2023 ----------------
2026 begin
2027 -- If we have a nested aggregate, go inside it (to
2028 -- attempt a naked analyze-resolve of the aggregate
2029 -- can cause undesirable cascaded errors). Do not
2030 -- resolve expression if it needs a type from context,
2031 -- as for integer * fixed expression.
2036 else
2041 then
2051 begin
2056 -- If an error message was issued already, Found got reset
2057 -- to True, so if it is still False, issue the standard
2058 -- Wrong_Type message.
2063 then
2064 declare
2066 begin
2072 -- Protected operation: retrieve operation name
2075 else
2085 declare
2089 begin
2100 else
2103 else
2109 Resolution_Failed;
2112 -- Test if we have more than one interpretation for the context
2115 Resolution_Failed;
2118 -- Here we have an acceptable interpretation for the context
2120 else
2121 -- Propagate type information and normalize tree for various
2122 -- predefined operations. If the context only imposes a class of
2123 -- types, rather than a specific type, propagate the actual type
2124 -- downward.
2131 then
2134 -- Any_Fixed is legal in a real context only if a specific
2135 -- fixed point type is imposed. If Norman Cohen can be
2136 -- confused by this, it deserves a separate message.
2140 then
2147 -- A user-defined operator is tranformed into a function call at
2148 -- this point, so that further processing knows that operators are
2149 -- really operators (i.e. are predefined operators). User-defined
2150 -- operators that are intrinsic are just renamings of the predefined
2151 -- ones, and need not be turned into calls either, but if they rename
2152 -- a different operator, we must transform the node accordingly.
2153 -- Instantiations of Unchecked_Conversion are intrinsic but are
2154 -- treated as functions, even if given an operator designator.
2159 then
2165 and then
2167 = N_Subprogram_Renaming_Declaration
2168 then
2171 -- If the node is rewritten, it will be fully resolved in
2172 -- Rewrite_Renamed_Operator.
2182 when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
2184 when N_Allocator => Resolve_Allocator (N, Ctx_Type);
2186 when N_And_Then | N_Or_Else
2187 => Resolve_Short_Circuit (N, Ctx_Type);
2189 when N_Attribute_Reference
2190 => Resolve_Attribute (N, Ctx_Type);
2192 when N_Character_Literal
2193 => Resolve_Character_Literal (N, Ctx_Type);
2195 when N_Conditional_Expression
2196 => Resolve_Conditional_Expression (N, Ctx_Type);
2198 when N_Expanded_Name
2199 => Resolve_Entity_Name (N, Ctx_Type);
2201 when N_Extension_Aggregate
2202 => Resolve_Extension_Aggregate (N, Ctx_Type);
2204 when N_Explicit_Dereference
2205 => Resolve_Explicit_Dereference (N, Ctx_Type);
2207 when N_Function_Call
2208 => Resolve_Call (N, Ctx_Type);
2210 when N_Identifier
2211 => Resolve_Entity_Name (N, Ctx_Type);
2213 when N_In | N_Not_In
2214 => Resolve_Membership_Op (N, Ctx_Type);
2216 when N_Indexed_Component
2217 => Resolve_Indexed_Component (N, Ctx_Type);
2219 when N_Integer_Literal
2220 => Resolve_Integer_Literal (N, Ctx_Type);
2222 when N_Null => Resolve_Null (N, Ctx_Type);
2224 when N_Op_And | N_Op_Or | N_Op_Xor
2225 => Resolve_Logical_Op (N, Ctx_Type);
2227 when N_Op_Eq | N_Op_Ne
2228 => Resolve_Equality_Op (N, Ctx_Type);
2230 when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
2231 => Resolve_Comparison_Op (N, Ctx_Type);
2233 when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
2235 when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
2236 N_Op_Divide | N_Op_Mod | N_Op_Rem
2238 => Resolve_Arithmetic_Op (N, Ctx_Type);
2240 when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
2242 when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
2244 when N_Op_Plus | N_Op_Minus | N_Op_Abs
2245 => Resolve_Unary_Op (N, Ctx_Type);
2247 when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
2249 when N_Procedure_Call_Statement
2250 => Resolve_Call (N, Ctx_Type);
2252 when N_Operator_Symbol
2253 => Resolve_Operator_Symbol (N, Ctx_Type);
2255 when N_Qualified_Expression
2256 => Resolve_Qualified_Expression (N, Ctx_Type);
2258 when N_Raise_xxx_Error
2259 => Set_Etype (N, Ctx_Type);
2261 when N_Range => Resolve_Range (N, Ctx_Type);
2263 when N_Real_Literal
2264 => Resolve_Real_Literal (N, Ctx_Type);
2266 when N_Reference => Resolve_Reference (N, Ctx_Type);
2268 when N_Selected_Component
2269 => Resolve_Selected_Component (N, Ctx_Type);
2271 when N_Slice => Resolve_Slice (N, Ctx_Type);
2273 when N_String_Literal
2274 => Resolve_String_Literal (N, Ctx_Type);
2276 when N_Subprogram_Info
2277 => Resolve_Subprogram_Info (N, Ctx_Type);
2279 when N_Type_Conversion
2280 => Resolve_Type_Conversion (N, Ctx_Type);
2282 when N_Unchecked_Expression =>
2283 Resolve_Unchecked_Expression (N, Ctx_Type);
2285 when N_Unchecked_Type_Conversion =>
2286 Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
2288 end case;
2290 -- If the subexpression was replaced by a non-subexpression, then
2291 -- all we do is to expand it. The only legitimate case we know of
2292 -- is converting procedure call statement to entry call statements,
2293 -- but there may be others, so we are making this test general.
2295 if Nkind (N) not in N_Subexpr then
2296 Debug_A_Exit ("resolving ", N, " (done)");
2297 Expand (N);
2298 return;
2299 end if;
2301 -- The expression is definitely NOT overloaded at this point, so
2302 -- we reset the Is_Overloaded flag to avoid any confusion when
2303 -- reanalyzing the node.
2305 Set_Is_Overloaded (N, False);
2307 -- Freeze expression type, entity if it is a name, and designated
2308 -- type if it is an allocator (RM 13.14(10,11,13)).
2310 -- Now that the resolution of the type of the node is complete,
2311 -- and we did not detect an error, we can expand this node. We
2312 -- skip the expand call if we are in a default expression, see
2313 -- section "Handling of Default Expressions" in Sem spec.
2315 Debug_A_Exit ("resolving ", N, " (done)");
2317 -- We unconditionally freeze the expression, even if we are in
2318 -- default expression mode (the Freeze_Expression routine tests
2319 -- this flag and only freezes static types if it is set).
2321 Freeze_Expression (N);
2323 -- Now we can do the expansion
2325 Expand (N);
2326 end if;
2327 end Resolve;
2329 -------------
2330 -- Resolve --
2331 -------------
2333 -- Version with check(s) suppressed
2335 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
2336 begin
2337 if Suppress = All_Checks then
2338 declare
2339 Svg : constant Suppress_Array := Scope_Suppress;
2340 begin
2341 Scope_Suppress := (others => True);
2342 Resolve (N, Typ);
2343 Scope_Suppress := Svg;
2344 end;
2346 else
2347 declare
2348 Svg : constant Boolean := Scope_Suppress (Suppress);
2349 begin
2350 Scope_Suppress (Suppress) := True;
2351 Resolve (N, Typ);
2352 Scope_Suppress (Suppress) := Svg;
2353 end;
2354 end if;
2355 end Resolve;
2357 -------------
2358 -- Resolve --
2359 -------------
2361 -- Version with implicit type
2363 procedure Resolve (N : Node_Id) is
2364 begin
2365 Resolve (N, Etype (N));
2366 end Resolve;
2368 ---------------------
2369 -- Resolve_Actuals --
2370 ---------------------
2372 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
2373 Loc : constant Source_Ptr := Sloc (N);
2374 A : Node_Id;
2375 F : Entity_Id;
2376 A_Typ : Entity_Id;
2377 F_Typ : Entity_Id;
2378 Prev : Node_Id := Empty;
2380 procedure Insert_Default;
2381 -- If the actual is missing in a call, insert in the actuals list
2382 -- an instance of the default expression. The insertion is always
2383 -- a named association.
2385 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
2386 -- Check whether T1 and T2, or their full views, are derived from a
2387 -- common type. Used to enforce the restrictions on array conversions
2388 -- of AI95-00246.
2390 --------------------
2391 -- Insert_Default --
2392 --------------------
2394 procedure Insert_Default is
2395 Actval : Node_Id;
2396 Assoc : Node_Id;
2398 begin
2399 -- Missing argument in call, nothing to insert
2401 if No (Default_Value (F)) then
2402 return;
2404 else
2405 -- Note that we do a full New_Copy_Tree, so that any associated
2406 -- Itypes are properly copied. This may not be needed any more,
2407 -- but it does no harm as a safety measure! Defaults of a generic
2408 -- formal may be out of bounds of the corresponding actual (see
2409 -- cc1311b) and an additional check may be required.
2411 Actval := New_Copy_Tree (Default_Value (F),
2412 New_Scope => Current_Scope, New_Sloc => Loc);
2414 if Is_Concurrent_Type (Scope (Nam))
2415 and then Has_Discriminants (Scope (Nam))
2416 then
2417 Replace_Actual_Discriminants (N, Actval);
2418 end if;
2420 if Is_Overloadable (Nam)
2421 and then Present (Alias (Nam))
2422 then
2423 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
2424 and then not Is_Tagged_Type (Etype (F))
2425 then
2426 -- If default is a real literal, do not introduce a
2427 -- conversion whose effect may depend on the run-time
2428 -- size of universal real.
2430 if Nkind (Actval) = N_Real_Literal then
2431 Set_Etype (Actval, Base_Type (Etype (F)));
2432 else
2433 Actval := Unchecked_Convert_To (Etype (F), Actval);
2434 end if;
2435 end if;
2437 if Is_Scalar_Type (Etype (F)) then
2438 Enable_Range_Check (Actval);
2439 end if;
2441 Set_Parent (Actval, N);
2443 -- Resolve aggregates with their base type, to avoid scope
2444 -- anomalies: the subtype was first built in the suprogram
2445 -- declaration, and the current call may be nested.
2447 if Nkind (Actval) = N_Aggregate
2448 and then Has_Discriminants (Etype (Actval))
2449 then
2450 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2451 else
2452 Analyze_And_Resolve (Actval, Etype (Actval));
2453 end if;
2455 else
2456 Set_Parent (Actval, N);
2458 -- See note above concerning aggregates
2460 if Nkind (Actval) = N_Aggregate
2461 and then Has_Discriminants (Etype (Actval))
2462 then
2463 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2465 -- Resolve entities with their own type, which may differ
2466 -- from the type of a reference in a generic context (the
2467 -- view swapping mechanism did not anticipate the re-analysis
2468 -- of default values in calls).
2470 elsif Is_Entity_Name (Actval) then
2471 Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
2473 else
2474 Analyze_And_Resolve (Actval, Etype (Actval));
2475 end if;
2476 end if;
2478 -- If default is a tag indeterminate function call, propagate
2479 -- tag to obtain proper dispatching.
2481 if Is_Controlling_Formal (F)
2482 and then Nkind (Default_Value (F)) = N_Function_Call
2483 then
2484 Set_Is_Controlling_Actual (Actval);
2485 end if;
2487 end if;
2489 -- If the default expression raises constraint error, then just
2490 -- silently replace it with an N_Raise_Constraint_Error node,
2491 -- since we already gave the warning on the subprogram spec.
2493 if Raises_Constraint_Error (Actval) then
2494 Rewrite (Actval,
2495 Make_Raise_Constraint_Error (Loc,
2496 Reason => CE_Range_Check_Failed));
2497 Set_Raises_Constraint_Error (Actval);
2498 Set_Etype (Actval, Etype (F));
2499 end if;
2501 Assoc :=
2502 Make_Parameter_Association (Loc,
2503 Explicit_Actual_Parameter => Actval,
2504 Selector_Name => Make_Identifier (Loc, Chars (F)));
2506 -- Case of insertion is first named actual
2508 if No (Prev) or else
2509 Nkind (Parent (Prev)) /= N_Parameter_Association
2510 then
2511 Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
2512 Set_First_Named_Actual (N, Actval);
2514 if No (Prev) then
2515 if not Present (Parameter_Associations (N)) then
2516 Set_Parameter_Associations (N, New_List (Assoc));
2517 else
2518 Append (Assoc, Parameter_Associations (N));
2519 end if;
2521 else
2522 Insert_After (Prev, Assoc);
2523 end if;
2525 -- Case of insertion is not first named actual
2527 else
2528 Set_Next_Named_Actual
2529 (Assoc, Next_Named_Actual (Parent (Prev)));
2530 Set_Next_Named_Actual (Parent (Prev), Actval);
2531 Append (Assoc, Parameter_Associations (N));
2532 end if;
2534 Mark_Rewrite_Insertion (Assoc);
2535 Mark_Rewrite_Insertion (Actval);
2537 Prev := Actval;
2538 end Insert_Default;
2540 -------------------
2541 -- Same_Ancestor --
2542 -------------------
2544 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
2545 FT1 : Entity_Id := T1;
2546 FT2 : Entity_Id := T2;
2548 begin
2549 if Is_Private_Type (T1)
2550 and then Present (Full_View (T1))
2551 then
2552 FT1 := Full_View (T1);
2553 end if;
2555 if Is_Private_Type (T2)
2556 and then Present (Full_View (T2))
2557 then
2558 FT2 := Full_View (T2);
2559 end if;
2561 return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
2562 end Same_Ancestor;
2564 -- Start of processing for Resolve_Actuals
2566 begin
2567 A := First_Actual (N);
2568 F := First_Formal (Nam);
2569 while Present (F) loop
2570 if No (A) and then Needs_No_Actuals (Nam) then
2571 null;
2573 -- If we have an error in any actual or formal, indicated by
2574 -- a type of Any_Type, then abandon resolution attempt, and
2575 -- set result type to Any_Type.
2577 elsif (Present (A) and then Etype (A) = Any_Type)
2578 or else Etype (F) = Any_Type
2579 then
2580 Set_Etype (N, Any_Type);
2581 return;
2582 end if;
2584 if Present (A)
2585 and then (Nkind (Parent (A)) /= N_Parameter_Association
2586 or else
2587 Chars (Selector_Name (Parent (A))) = Chars (F))
2588 then
2589 -- If the formal is Out or In_Out, do not resolve and expand the
2590 -- conversion, because it is subsequently expanded into explicit
2591 -- temporaries and assignments. However, the object of the
2592 -- conversion can be resolved. An exception is the case of tagged
2593 -- type conversion with a class-wide actual. In that case we want
2594 -- the tag check to occur and no temporary will be needed (no
2595 -- representation change can occur) and the parameter is passed by
2596 -- reference, so we go ahead and resolve the type conversion.
2597 -- Another excpetion is the case of reference to component or
2598 -- subcomponent of a bit-packed array, in which case we want to
2599 -- defer expansion to the point the in and out assignments are
2600 -- performed.
2602 if Ekind (F) /= E_In_Parameter
2603 and then Nkind (A) = N_Type_Conversion
2604 and then not Is_Class_Wide_Type (Etype (Expression (A)))
2605 then
2606 if Ekind (F) = E_In_Out_Parameter
2607 and then Is_Array_Type (Etype (F))
2608 then
2609 if Has_Aliased_Components (Etype (Expression (A)))
2610 /= Has_Aliased_Components (Etype (F))
2611 then
2612 if Ada_Version < Ada_05 then
2613 Error_Msg_N
2614 ("both component types in a view conversion must be"
2615 & " aliased, or neither", A);
2617 -- Ada 2005: rule is relaxed (see AI-363)
2619 elsif Has_Aliased_Components (Etype (F))
2620 and then
2621 not Has_Aliased_Components (Etype (Expression (A)))
2622 then
2623 Error_Msg_N
2624 ("view conversion operand must have aliased " &
2625 "components", N);
2626 Error_Msg_N
2628 end if;
2630 elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
2631 and then
2632 (Is_By_Reference_Type (Etype (F))
2633 or else Is_By_Reference_Type (Etype (Expression (A))))
2634 then
2635 Error_Msg_N
2636 ("view conversion between unrelated by reference " &
2638 end if;
2639 end if;
2641 if (Conversion_OK (A)
2642 or else Valid_Conversion (A, Etype (A), Expression (A)))
2643 and then not Is_Ref_To_Bit_Packed_Array (Expression (A))
2644 then
2645 Resolve (Expression (A));
2646 end if;
2648 else
2649 if Nkind (A) = N_Type_Conversion
2650 and then Is_Array_Type (Etype (F))
2651 and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
2652 and then
2653 (Is_Limited_Type (Etype (F))
2654 or else Is_Limited_Type (Etype (Expression (A))))
2655 then
2656 Error_Msg_N
2660 if Is_Limited_Type (Etype (F)) then
2661 Explain_Limited_Type (Etype (F), A);
2662 end if;
2664 if Is_Limited_Type (Etype (Expression (A))) then
2665 Explain_Limited_Type (Etype (Expression (A)), A);
2666 end if;
2667 end if;
2669 Resolve (A, Etype (F));
2670 end if;
2672 A_Typ := Etype (A);
2673 F_Typ := Etype (F);
2675 -- Perform error checks for IN and IN OUT parameters
2677 if Ekind (F) /= E_Out_Parameter then
2679 -- Check unset reference. For scalar parameters, it is clearly
2680 -- wrong to pass an uninitialized value as either an IN or
2681 -- IN-OUT parameter. For composites, it is also clearly an
2682 -- error to pass a completely uninitialized value as an IN
2683 -- parameter, but the case of IN OUT is trickier. We prefer
2684 -- not to give a warning here. For example, suppose there is
2685 -- a routine that sets some component of a record to False.
2686 -- It is perfectly reasonable to make this IN-OUT and allow
2687 -- either initialized or uninitialized records to be passed
2688 -- in this case.
2690 -- For partially initialized composite values, we also avoid
2691 -- warnings, since it is quite likely that we are passing a
2692 -- partially initialized value and only the initialized fields
2693 -- will in fact be read in the subprogram.
2695 if Is_Scalar_Type (A_Typ)
2696 or else (Ekind (F) = E_In_Parameter
2697 and then not Is_Partially_Initialized_Type (A_Typ))
2698 then
2699 Check_Unset_Reference (A);
2700 end if;
2702 -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
2703 -- actual to a nested call, since this is case of reading an
2704 -- out parameter, which is not allowed.
2706 if Ada_Version = Ada_83
2707 and then Is_Entity_Name (A)
2708 and then Ekind (Entity (A)) = E_Out_Parameter
2709 then
2711 end if;
2712 end if;
2714 if Ekind (F) /= E_In_Parameter
2715 and then not Is_OK_Variable_For_Out_Formal (A)
2716 then
2719 if Is_Entity_Name (A) then
2720 Kill_Checks (Entity (A));
2721 else
2722 Kill_All_Checks;
2723 end if;
2724 end if;
2726 if Etype (A) = Any_Type then
2727 Set_Etype (N, Any_Type);
2728 return;
2729 end if;
2731 -- Apply appropriate range checks for in, out, and in-out
2732 -- parameters. Out and in-out parameters also need a separate
2733 -- check, if there is a type conversion, to make sure the return
2734 -- value meets the constraints of the variable before the
2735 -- conversion.
2737 -- Gigi looks at the check flag and uses the appropriate types.
2738 -- For now since one flag is used there is an optimization which
2739 -- might not be done in the In Out case since Gigi does not do
2740 -- any analysis. More thought required about this ???
2742 if Ekind (F) = E_In_Parameter
2743 or else Ekind (F) = E_In_Out_Parameter
2744 then
2745 if Is_Scalar_Type (Etype (A)) then
2746 Apply_Scalar_Range_Check (A, F_Typ);
2748 elsif Is_Array_Type (Etype (A)) then
2749 Apply_Length_Check (A, F_Typ);
2751 elsif Is_Record_Type (F_Typ)
2752 and then Has_Discriminants (F_Typ)
2753 and then Is_Constrained (F_Typ)
2754 and then (not Is_Derived_Type (F_Typ)
2755 or else Comes_From_Source (Nam))
2756 then
2757 Apply_Discriminant_Check (A, F_Typ);
2759 elsif Is_Access_Type (F_Typ)
2760 and then Is_Array_Type (Designated_Type (F_Typ))
2761 and then Is_Constrained (Designated_Type (F_Typ))
2762 then
2763 Apply_Length_Check (A, F_Typ);
2765 elsif Is_Access_Type (F_Typ)
2766 and then Has_Discriminants (Designated_Type (F_Typ))
2767 and then Is_Constrained (Designated_Type (F_Typ))
2768 then
2769 Apply_Discriminant_Check (A, F_Typ);
2771 else
2772 Apply_Range_Check (A, F_Typ);
2773 end if;
2775 -- Ada 2005 (AI-231)
2777 if Ada_Version >= Ada_05
2778 and then Is_Access_Type (F_Typ)
2779 and then Can_Never_Be_Null (F_Typ)
2780 and then Nkind (A) = N_Null
2781 then
2782 Apply_Compile_Time_Constraint_Error
2783 (N => A,
2786 Reason => CE_Null_Not_Allowed);
2787 end if;
2788 end if;
2790 if Ekind (F) = E_Out_Parameter
2791 or else Ekind (F) = E_In_Out_Parameter
2792 then
2793 if Nkind (A) = N_Type_Conversion then
2794 if Is_Scalar_Type (A_Typ) then
2795 Apply_Scalar_Range_Check
2796 (Expression (A), Etype (Expression (A)), A_Typ);
2797 else
2798 Apply_Range_Check
2799 (Expression (A), Etype (Expression (A)), A_Typ);
2800 end if;
2802 else
2803 if Is_Scalar_Type (F_Typ) then
2804 Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
2806 elsif Is_Array_Type (F_Typ)
2807 and then Ekind (F) = E_Out_Parameter
2808 then
2809 Apply_Length_Check (A, F_Typ);
2811 else
2812 Apply_Range_Check (A, A_Typ, F_Typ);
2813 end if;
2814 end if;
2815 end if;
2817 -- An actual associated with an access parameter is implicitly
2818 -- converted to the anonymous access type of the formal and
2819 -- must satisfy the legality checks for access conversions.
2821 if Ekind (F_Typ) = E_Anonymous_Access_Type then
2822 if not Valid_Conversion (A, F_Typ, A) then
2823 Error_Msg_N
2825 end if;
2826 end if;
2828 -- Check bad case of atomic/volatile argument (RM C.6(12))
2830 if Is_By_Reference_Type (Etype (F))
2831 and then Comes_From_Source (N)
2832 then
2833 if Is_Atomic_Object (A)
2834 and then not Is_Atomic (Etype (F))
2835 then
2836 Error_Msg_N
2838 N);
2840 elsif Is_Volatile_Object (A)
2841 and then not Is_Volatile (Etype (F))
2842 then
2843 Error_Msg_N
2845 N);
2846 end if;
2847 end if;
2849 -- Check that subprograms don't have improper controlling
2850 -- arguments (RM 3.9.2 (9))
2852 if Is_Controlling_Formal (F) then
2853 Set_Is_Controlling_Actual (A);
2854 elsif Nkind (A) = N_Explicit_Dereference then
2855 Validate_Remote_Access_To_Class_Wide_Type (A);
2856 end if;
2858 if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
2859 and then not Is_Class_Wide_Type (F_Typ)
2860 and then not Is_Controlling_Formal (F)
2861 then
2864 if Is_Subprogram (Nam)
2865 and then Comes_From_Source (Nam)
2866 then
2867 Error_Msg_Node_2 := F_Typ;
2868 Error_Msg_NE
2870 end if;
2872 elsif Is_Access_Type (A_Typ)
2873 and then Is_Access_Type (F_Typ)
2874 and then Ekind (F_Typ) /= E_Access_Subprogram_Type
2875 and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
2876 or else (Nkind (A) = N_Attribute_Reference
2877 and then
2878 Is_Class_Wide_Type (Etype (Prefix (A)))))
2879 and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
2880 and then not Is_Controlling_Formal (F)
2881 then
2882 Error_Msg_N
2885 if Is_Subprogram (Nam)
2886 and then Comes_From_Source (Nam)
2887 then
2888 Error_Msg_Node_2 := Designated_Type (F_Typ);
2889 Error_Msg_NE
2891 end if;
2892 end if;
2894 Eval_Actual (A);
2896 -- If it is a named association, treat the selector_name as
2897 -- a proper identifier, and mark the corresponding entity.
2899 if Nkind (Parent (A)) = N_Parameter_Association then
2900 Set_Entity (Selector_Name (Parent (A)), F);
2901 Generate_Reference (F, Selector_Name (Parent (A)));
2902 Set_Etype (Selector_Name (Parent (A)), F_Typ);
2903 Generate_Reference (F_Typ, N, ' ');
2904 end if;
2906 Prev := A;
2908 if Ekind (F) /= E_Out_Parameter then
2909 Check_Unset_Reference (A);
2910 end if;
2912 Next_Actual (A);
2914 -- Case where actual is not present
2916 else
2917 Insert_Default;
2918 end if;
2920 Next_Formal (F);
2921 end loop;
2922 end Resolve_Actuals;
2924 -----------------------
2925 -- Resolve_Allocator --
2926 -----------------------
2928 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
2929 E : constant Node_Id := Expression (N);
2930 Subtyp : Entity_Id;
2931 Discrim : Entity_Id;
2932 Constr : Node_Id;
2933 Disc_Exp : Node_Id;
2935 function In_Dispatching_Context return Boolean;
2936 -- If the allocator is an actual in a call, it is allowed to be
2937 -- class-wide when the context is not because it is a controlling
2938 -- actual.
2940 ----------------------------
2941 -- In_Dispatching_Context --
2942 ----------------------------
2944 function In_Dispatching_Context return Boolean is
2945 Par : constant Node_Id := Parent (N);
2947 begin
2948 return (Nkind (Par) = N_Function_Call
2949 or else Nkind (Par) = N_Procedure_Call_Statement)
2950 and then Is_Entity_Name (Name (Par))
2951 and then Is_Dispatching_Operation (Entity (Name (Par)));
2952 end In_Dispatching_Context;
2954 -- Start of processing for Resolve_Allocator
2956 begin
2957 -- Replace general access with specific type
2959 if Ekind (Etype (N)) = E_Allocator_Type then
2960 Set_Etype (N, Base_Type (Typ));
2961 end if;
2963 if Is_Abstract (Typ) then
2965 end if;
2967 -- For qualified expression, resolve the expression using the
2968 -- given subtype (nothing to do for type mark, subtype indication)
2970 if Nkind (E) = N_Qualified_Expression then
2971 if Is_Class_Wide_Type (Etype (E))
2972 and then not Is_Class_Wide_Type (Designated_Type (Typ))
2973 and then not In_Dispatching_Context
2974 then
2975 Error_Msg_N
2977 end if;
2979 Resolve (Expression (E), Etype (E));
2980 Check_Unset_Reference (Expression (E));
2982 -- A qualified expression requires an exact match of the type,
2983 -- class-wide matching is not allowed.
2985 if (Is_Class_Wide_Type (Etype (Expression (E)))
2986 or else Is_Class_Wide_Type (Etype (E)))
2987 and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
2988 then
2989 Wrong_Type (Expression (E), Etype (E));
2990 end if;
2992 -- For a subtype mark or subtype indication, freeze the subtype
2994 else
2995 Freeze_Expression (E);
2997 if Is_Access_Constant (Typ) and then not No_Initialization (N) then
2998 Error_Msg_N
3000 end if;
3002 -- A special accessibility check is needed for allocators that
3003 -- constrain access discriminants. The level of the type of the
3004 -- expression used to contrain an access discriminant cannot be
3005 -- deeper than the type of the allocator (in constrast to access
3006 -- parameters, where the level of the actual can be arbitrary).
3007 -- We can't use Valid_Conversion to perform this check because
3008 -- in general the type of the allocator is unrelated to the type
3009 -- of the access discriminant. Note that specialized checks are
3010 -- needed for the cases of a constraint expression which is an
3011 -- access attribute or an access discriminant.
3013 if Nkind (Original_Node (E)) = N_Subtype_Indication
3014 and then Ekind (Typ) /= E_Anonymous_Access_Type
3015 then
3016 Subtyp := Entity (Subtype_Mark (Original_Node (E)));
3018 if Has_Discriminants (Subtyp) then
3019 Discrim := First_Discriminant (Base_Type (Subtyp));
3020 Constr := First (Constraints (Constraint (Original_Node (E))));
3021 while Present (Discrim) and then Present (Constr) loop
3022 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
3023 if Nkind (Constr) = N_Discriminant_Association then
3024 Disc_Exp := Original_Node (Expression (Constr));
3025 else
3026 Disc_Exp := Original_Node (Constr);
3027 end if;
3029 if Type_Access_Level (Etype (Disc_Exp))
3030 > Type_Access_Level (Typ)
3031 then
3032 Error_Msg_N
3034 Disc_Exp);
3036 elsif Nkind (Disc_Exp) = N_Attribute_Reference
3037 and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
3038 = Attribute_Access
3039 and then Object_Access_Level (Prefix (Disc_Exp))
3040 > Type_Access_Level (Typ)
3041 then
3042 Error_Msg_N
3046 -- When the operand is an access discriminant the check
3047 -- is against the level of the prefix object.
3049 elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
3050 and then Nkind (Disc_Exp) = N_Selected_Component
3051 and then Object_Access_Level (Prefix (Disc_Exp))
3052 > Type_Access_Level (Typ)
3053 then
3054 Error_Msg_N
3057 end if;
3058 end if;
3059 Next_Discriminant (Discrim);
3060 Next (Constr);
3061 end loop;
3062 end if;
3063 end if;
3064 end if;
3066 -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility
3067 -- check that the level of the type of the created object is not deeper
3068 -- than the level of the allocator's access type, since extensions can
3069 -- now occur at deeper levels than their ancestor types. This is a
3070 -- static accessibility level check; a run-time check is also needed in
3071 -- the case of an initialized allocator with a class-wide argument (see
3072 -- Expand_Allocator_Expression).
3074 if Ada_Version >= Ada_05
3075 and then Is_Class_Wide_Type (Designated_Type (Typ))
3076 then
3077 declare
3078 Exp_Typ : Entity_Id;
3080 begin
3081 if Nkind (E) = N_Qualified_Expression then
3082 Exp_Typ := Etype (E);
3083 elsif Nkind (E) = N_Subtype_Indication then
3084 Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
3085 else
3086 Exp_Typ := Entity (E);
3087 end if;
3089 if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
3090 if In_Instance_Body then
3094 Rewrite (N,
3095 Make_Raise_Program_Error (Sloc (N),
3096 Reason => PE_Accessibility_Check_Failed));
3097 Set_Etype (N, Typ);
3098 else
3101 end if;
3102 end if;
3103 end;
3104 end if;
3106 -- Check for allocation from an empty storage pool
3108 if No_Pool_Assigned (Typ) then
3109 declare
3110 Loc : constant Source_Ptr := Sloc (N);
3111 begin
3114 Insert_Action (N,
3115 Make_Raise_Storage_Error (Loc,
3116 Reason => SE_Empty_Storage_Pool));
3117 end;
3119 -- If the context is an unchecked conversion, as may happen within
3120 -- an inlined subprogram, the allocator is being resolved with its
3121 -- own anonymous type. In that case, if the target type has a specific
3122 -- storage pool, it must be inherited explicitly by the allocator type.
3124 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
3125 and then No (Associated_Storage_Pool (Typ))
3126 then
3127 Set_Associated_Storage_Pool
3128 (Typ, Associated_Storage_Pool (Etype (Parent (N))));
3129 end if;
3130 end Resolve_Allocator;
3132 ---------------------------
3133 -- Resolve_Arithmetic_Op --
3134 ---------------------------
3136 -- Used for resolving all arithmetic operators except exponentiation
3138 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
3139 L : constant Node_Id := Left_Opnd (N);
3140 R : constant Node_Id := Right_Opnd (N);
3141 TL : constant Entity_Id := Base_Type (Etype (L));
3142 TR : constant Entity_Id := Base_Type (Etype (R));
3143 T : Entity_Id;
3144 Rop : Node_Id;
3146 B_Typ : constant Entity_Id := Base_Type (Typ);
3147 -- We do the resolution using the base type, because intermediate values
3148 -- in expressions always are of the base type, not a subtype of it.
3150 function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
3151 -- Return True iff given type is Integer or universal real/integer
3153 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
3154 -- Choose type of integer literal in fixed-point operation to conform
3155 -- to available fixed-point type. T is the type of the other operand,
3156 -- which is needed to determine the expected type of N.
3158 procedure Set_Operand_Type (N : Node_Id);
3159 -- Set operand type to T if universal
3161 -----------------------------
3162 -- Is_Integer_Or_Universal --
3163 -----------------------------
3165 function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
3166 T : Entity_Id;
3167 Index : Interp_Index;
3168 It : Interp;
3170 begin
3171 if not Is_Overloaded (N) then
3172 T := Etype (N);
3173 return Base_Type (T) = Base_Type (Standard_Integer)
3174 or else T = Universal_Integer
3175 or else T = Universal_Real;
3176 else
3177 Get_First_Interp (N, Index, It);
3178 while Present (It.Typ) loop
3179 if Base_Type (It.Typ) = Base_Type (Standard_Integer)
3180 or else It.Typ = Universal_Integer
3181 or else It.Typ = Universal_Real
3182 then
3183 return True;
3184 end if;
3186 Get_Next_Interp (Index, It);
3187 end loop;
3188 end if;
3190 return False;
3191 end Is_Integer_Or_Universal;
3193 ----------------------------
3194 -- Set_Mixed_Mode_Operand --
3195 ----------------------------
3197 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
3198 Index : Interp_Index;
3199 It : Interp;
3201 begin
3202 if Universal_Interpretation (N) = Universal_Integer then
3204 -- A universal integer literal is resolved as standard integer
3205 -- except in the case of a fixed-point result, where we leave it
3206 -- as universal (to be handled by Exp_Fixd later on)
3208 if Is_Fixed_Point_Type (T) then
3209 Resolve (N, Universal_Integer);
3210 else
3211 Resolve (N, Standard_Integer);
3212 end if;
3214 elsif Universal_Interpretation (N) = Universal_Real
3215 and then (T = Base_Type (Standard_Integer)
3216 or else T = Universal_Integer
3217 or else T = Universal_Real)
3218 then
3219 -- A universal real can appear in a fixed-type context. We resolve
3220 -- the literal with that context, even though this might raise an
3221 -- exception prematurely (the other operand may be zero).
3223 Resolve (N, B_Typ);
3225 elsif Etype (N) = Base_Type (Standard_Integer)
3226 and then T = Universal_Real
3227 and then Is_Overloaded (N)
3228 then
3229 -- Integer arg in mixed-mode operation. Resolve with universal
3230 -- type, in case preference rule must be applied.
3232 Resolve (N, Universal_Integer);
3234 elsif Etype (N) = T
3235 and then B_Typ /= Universal_Fixed
3236 then
3237 -- Not a mixed-mode operation, resolve with context
3239 Resolve (N, B_Typ);
3241 elsif Etype (N) = Any_Fixed then
3243 -- N may itself be a mixed-mode operation, so use context type
3245 Resolve (N, B_Typ);
3247 elsif Is_Fixed_Point_Type (T)
3248 and then B_Typ = Universal_Fixed
3249 and then Is_Overloaded (N)
3250 then
3251 -- Must be (fixed * fixed) operation, operand must have one
3252 -- compatible interpretation.
3254 Resolve (N, Any_Fixed);
3256 elsif Is_Fixed_Point_Type (B_Typ)
3257 and then (T = Universal_Real
3258 or else Is_Fixed_Point_Type (T))
3259 and then Is_Overloaded (N)
3260 then
3261 -- C * F(X) in a fixed context, where C is a real literal or a
3262 -- fixed-point expression. F must have either a fixed type
3263 -- interpretation or an integer interpretation, but not both.
3265 Get_First_Interp (N, Index, It);
3266 while Present (It.Typ) loop
3267 if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
3269 if Analyzed (N) then
3271 else
3272 Resolve (N, Standard_Integer);
3273 end if;
3275 elsif Is_Fixed_Point_Type (It.Typ) then
3277 if Analyzed (N) then
3279 else
3280 Resolve (N, It.Typ);
3281 end if;
3282 end if;
3284 Get_Next_Interp (Index, It);
3285 end loop;
3287 -- Reanalyze the literal with the fixed type of the context. If
3288 -- context is Universal_Fixed, we are within a conversion, leave
3289 -- the literal as a universal real because there is no usable
3290 -- fixed type, and the target of the conversion plays no role in
3291 -- the resolution.
3293 declare
3294 Op2 : Node_Id;
3295 T2 : Entity_Id;
3297 begin
3298 if N = L then
3299 Op2 := R;
3300 else
3301 Op2 := L;
3302 end if;
3304 if B_Typ = Universal_Fixed
3305 and then Nkind (Op2) = N_Real_Literal
3306 then
3307 T2 := Universal_Real;
3308 else
3309 T2 := B_Typ;
3310 end if;
3312 Set_Analyzed (Op2, False);
3313 Resolve (Op2, T2);
3314 end;
3316 else
3317 Resolve (N);
3318 end if;
3319 end Set_Mixed_Mode_Operand;
3321 ----------------------
3322 -- Set_Operand_Type --
3323 ----------------------
3325 procedure Set_Operand_Type (N : Node_Id) is
3326 begin
3327 if Etype (N) = Universal_Integer
3328 or else Etype (N) = Universal_Real
3329 then
3330 Set_Etype (N, T);
3331 end if;
3332 end Set_Operand_Type;
3334 -- Start of processing for Resolve_Arithmetic_Op
3336 begin
3337 if Comes_From_Source (N)
3338 and then Ekind (Entity (N)) = E_Function
3339 and then Is_Imported (Entity (N))
3340 and then Is_Intrinsic_Subprogram (Entity (N))
3341 then
3342 Resolve_Intrinsic_Operator (N, Typ);
3343 return;
3345 -- Special-case for mixed-mode universal expressions or fixed point
3346 -- type operation: each argument is resolved separately. The same
3347 -- treatment is required if one of the operands of a fixed point
3348 -- operation is universal real, since in this case we don't do a
3349 -- conversion to a specific fixed-point type (instead the expander
3350 -- takes care of the case).
3352 elsif (B_Typ = Universal_Integer
3353 or else B_Typ = Universal_Real)
3354 and then Present (Universal_Interpretation (L))
3355 and then Present (Universal_Interpretation (R))
3356 then
3357 Resolve (L, Universal_Interpretation (L));
3358 Resolve (R, Universal_Interpretation (R));
3359 Set_Etype (N, B_Typ);
3361 elsif (B_Typ = Universal_Real
3362 or else Etype (N) = Universal_Fixed
3363 or else (Etype (N) = Any_Fixed
3364 and then Is_Fixed_Point_Type (B_Typ))
3365 or else (Is_Fixed_Point_Type (B_Typ)
3366 and then (Is_Integer_Or_Universal (L)
3367 or else
3368 Is_Integer_Or_Universal (R))))
3369 and then (Nkind (N) = N_Op_Multiply or else
3370 Nkind (N) = N_Op_Divide)
3371 then
3372 if TL = Universal_Integer or else TR = Universal_Integer then
3373 Check_For_Visible_Operator (N, B_Typ);
3374 end if;
3376 -- If context is a fixed type and one operand is integer, the
3377 -- other is resolved with the type of the context.
3379 if Is_Fixed_Point_Type (B_Typ)
3380 and then (Base_Type (TL) = Base_Type (Standard_Integer)
3381 or else TL = Universal_Integer)
3382 then
3383 Resolve (R, B_Typ);
3384 Resolve (L, TL);
3386 elsif Is_Fixed_Point_Type (B_Typ)
3387 and then (Base_Type (TR) = Base_Type (Standard_Integer)
3388 or else TR = Universal_Integer)
3389 then
3390 Resolve (L, B_Typ);
3391 Resolve (R, TR);
3393 else
3394 Set_Mixed_Mode_Operand (L, TR);
3395 Set_Mixed_Mode_Operand (R, TL);
3396 end if;
3398 if Etype (N) = Universal_Fixed
3399 or else Etype (N) = Any_Fixed
3400 then
3401 if B_Typ = Universal_Fixed
3402 and then Nkind (Parent (N)) /= N_Type_Conversion
3403 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
3404 then
3405 Error_Msg_N
3407 Error_Msg_N
3410 Set_Etype (L, Any_Type);
3411 Set_Etype (R, Any_Type);
3413 else
3414 if Ada_Version = Ada_83
3415 and then Etype (N) = Universal_Fixed
3416 and then Nkind (Parent (N)) /= N_Type_Conversion
3417 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
3418 then
3419 Error_Msg_N
3422 N);
3423 end if;
3425 Set_Etype (N, B_Typ);
3426 end if;
3428 elsif Is_Fixed_Point_Type (B_Typ)
3429 and then (Is_Integer_Or_Universal (L)
3430 or else Nkind (L) = N_Real_Literal
3431 or else Nkind (R) = N_Real_Literal
3432 or else
3433 Is_Integer_Or_Universal (R))
3434 then
3435 Set_Etype (N, B_Typ);
3437 elsif Etype (N) = Any_Fixed then
3439 -- If no previous errors, this is only possible if one operand
3440 -- is overloaded and the context is universal. Resolve as such.
3442 Set_Etype (N, B_Typ);
3443 end if;
3445 else
3446 if (TL = Universal_Integer or else TL = Universal_Real)
3447 and then (TR = Universal_Integer or else TR = Universal_Real)
3448 then
3449 Check_For_Visible_Operator (N, B_Typ);
3450 end if;
3452 -- If the context is Universal_Fixed and the operands are also
3453 -- universal fixed, this is an error, unless there is only one
3454 -- applicable fixed_point type (usually duration).
3456 if B_Typ = Universal_Fixed
3457 and then Etype (L) = Universal_Fixed
3458 then
3459 T := Unique_Fixed_Point_Type (N);
3461 if T = Any_Type then
3462 Set_Etype (N, T);
3463 return;
3464 else
3465 Resolve (L, T);
3466 Resolve (R, T);
3467 end if;
3469 else
3470 Resolve (L, B_Typ);
3471 Resolve (R, B_Typ);
3472 end if;
3474 -- If one of the arguments was resolved to a non-universal type.
3475 -- label the result of the operation itself with the same type.
3476 -- Do the same for the universal argument, if any.
3478 T := Intersect_Types (L, R);
3479 Set_Etype (N, Base_Type (T));
3480 Set_Operand_Type (L);
3481 Set_Operand_Type (R);
3482 end if;
3484 Generate_Operator_Reference (N, Typ);
3485 Eval_Arithmetic_Op (N);
3487 -- Set overflow and division checking bit. Much cleverer code needed
3488 -- here eventually and perhaps the Resolve routines should be separated
3489 -- for the various arithmetic operations, since they will need
3490 -- different processing. ???
3492 if Nkind (N) in N_Op then
3493 if not Overflow_Checks_Suppressed (Etype (N)) then
3494 Enable_Overflow_Check (N);
3495 end if;
3497 -- Give warning if explicit division by zero
3499 if (Nkind (N) = N_Op_Divide
3500 or else Nkind (N) = N_Op_Rem
3501 or else Nkind (N) = N_Op_Mod)
3502 and then not Division_Checks_Suppressed (Etype (N))
3503 then
3504 Rop := Right_Opnd (N);
3506 if Compile_Time_Known_Value (Rop)
3507 and then ((Is_Integer_Type (Etype (Rop))
3508 and then Expr_Value (Rop) = Uint_0)
3509 or else
3510 (Is_Real_Type (Etype (Rop))
3511 and then Expr_Value_R (Rop) = Ureal_0))
3512 then
3513 Apply_Compile_Time_Constraint_Error
3515 Loc => Sloc (Right_Opnd (N)));
3517 -- Otherwise just set the flag to check at run time
3519 else
3520 Set_Do_Division_Check (N);
3521 end if;
3522 end if;
3523 end if;
3525 Check_Unset_Reference (L);
3526 Check_Unset_Reference (R);
3527 end Resolve_Arithmetic_Op;
3529 ------------------
3530 -- Resolve_Call --
3531 ------------------
3533 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
3534 Loc : constant Source_Ptr := Sloc (N);
3535 Subp : constant Node_Id := Name (N);
3536 Nam : Entity_Id;
3537 I : Interp_Index;
3538 It : Interp;
3539 Norm_OK : Boolean;
3540 Scop : Entity_Id;
3542 begin
3543 -- The context imposes a unique interpretation with type Typ on a
3544 -- procedure or function call. Find the entity of the subprogram that
3545 -- yields the expected type, and propagate the corresponding formal
3546 -- constraints on the actuals. The caller has established that an
3547 -- interpretation exists, and emitted an error if not unique.
3549 -- First deal with the case of a call to an access-to-subprogram,
3550 -- dereference made explicit in Analyze_Call.
3552 if Ekind (Etype (Subp)) = E_Subprogram_Type then
3553 if not Is_Overloaded (Subp) then
3554 Nam := Etype (Subp);
3556 else
3557 -- Find the interpretation whose type (a subprogram type) has a
3558 -- return type that is compatible with the context. Analysis of
3559 -- the node has established that one exists.
3561 Nam := Empty;
3563 Get_First_Interp (Subp, I, It);
3564 while Present (It.Typ) loop
3565 if Covers (Typ, Etype (It.Typ)) then
3566 Nam := It.Typ;
3567 exit;
3568 end if;
3570 Get_Next_Interp (I, It);
3571 end loop;
3573 if No (Nam) then
3574 raise Program_Error;
3575 end if;
3576 end if;
3578 -- If the prefix is not an entity, then resolve it
3580 if not Is_Entity_Name (Subp) then
3581 Resolve (Subp, Nam);
3582 end if;
3584 -- For an indirect call, we always invalidate checks, since we do not
3585 -- know whether the subprogram is local or global. Yes we could do
3586 -- better here, e.g. by knowing that there are no local subprograms,
3587 -- but it does not seem worth the effort. Similarly, we kill al
3588 -- knowledge of current constant values.
3590 Kill_Current_Values;
3592 -- If this is a procedure call which is really an entry call, do the
3593 -- conversion of the procedure call to an entry call. Protected
3594 -- operations use the same circuitry because the name in the call can be
3595 -- an arbitrary expression with special resolution rules.
3597 elsif Nkind (Subp) = N_Selected_Component
3598 or else Nkind (Subp) = N_Indexed_Component
3599 or else (Is_Entity_Name (Subp)
3600 and then Ekind (Entity (Subp)) = E_Entry)
3601 then
3602 Resolve_Entry_Call (N, Typ);
3603 Check_Elab_Call (N);
3605 -- Kill checks and constant values, as above for indirect case
3606 -- Who knows what happens when another task is activated?
3608 Kill_Current_Values;
3609 return;
3611 -- Normal subprogram call with name established in Resolve
3613 elsif not (Is_Type (Entity (Subp))) then
3614 Nam := Entity (Subp);
3615 Set_Entity_With_Style_Check (Subp, Nam);
3616 Generate_Reference (Nam, Subp);
3618 -- Otherwise we must have the case of an overloaded call
3620 else
3621 pragma Assert (Is_Overloaded (Subp));
3622 Nam := Empty; -- We know that it will be assigned in loop below
3624 Get_First_Interp (Subp, I, It);
3625 while Present (It.Typ) loop
3626 if Covers (Typ, It.Typ) then
3627 Nam := It.Nam;
3628 Set_Entity_With_Style_Check (Subp, Nam);
3629 Generate_Reference (Nam, Subp);
3630 exit;
3631 end if;
3633 Get_Next_Interp (I, It);
3634 end loop;
3635 end if;
3637 -- Check that a call to Current_Task does not occur in an entry body
3639 if Is_RTE (Nam, RE_Current_Task) then
3640 declare
3641 P : Node_Id;
3643 begin
3644 P := N;
3645 loop
3646 P := Parent (P);
3647 exit when No (P);
3649 if Nkind (P) = N_Entry_Body then
3650 Error_Msg_NE
3652 N, Nam);
3653 exit;
3654 end if;
3655 end loop;
3656 end;
3657 end if;
3659 -- Cannot call thread body directly
3661 if Is_Thread_Body (Nam) then
3662 Error_Msg_N ("cannot call thread body directly", N);
3663 end if;
3665 -- If the subprogram is not global, then kill all checks. This is a bit
3666 -- conservative, since in many cases we could do better, but it is not
3667 -- worth the effort. Similarly, we kill constant values. However we do
3668 -- not need to do this for internal entities (unless they are inherited
3669 -- user-defined subprograms), since they are not in the business of
3670 -- molesting global values.
3672 if not Is_Library_Level_Entity (Nam)
3673 and then (Comes_From_Source (Nam)
3674 or else (Present (Alias (Nam))
3675 and then Comes_From_Source (Alias (Nam))))
3676 then
3677 Kill_Current_Values;
3678 end if;
3680 -- Check for call to subprogram marked Is_Obsolescent
3682 Check_Obsolescent (Nam, N);
3684 -- Check that a procedure call does not occur in the context of the
3685 -- entry call statement of a conditional or timed entry call. Note that
3686 -- the case of a call to a subprogram renaming of an entry will also be
3687 -- rejected. The test for N not being an N_Entry_Call_Statement is
3688 -- defensive, covering the possibility that the processing of entry
3689 -- calls might reach this point due to later modifications of the code
3690 -- above.
3692 if Nkind (Parent (N)) = N_Entry_Call_Alternative
3693 and then Nkind (N) /= N_Entry_Call_Statement
3694 and then Entry_Call_Statement (Parent (N)) = N
3695 then
3696 if Ada_Version < Ada_05 then
3697 Error_Msg_N ("entry call required in select statement", N);
3699 -- Ada 2005 (AI-345): If a procedure_call_statement is used
3700 -- for a procedure_or_entry_call, the procedure_name or pro-
3701 -- cedure_prefix of the procedure_call_statement shall denote
3702 -- an entry renamed by a procedure, or (a view of) a primitive
3703 -- subprogram of a limited interface whose first parameter is
3704 -- a controlling parameter.
3706 elsif Nkind (N) = N_Procedure_Call_Statement
3707 and then not Is_Renamed_Entry (Nam)
3708 and then not Is_Controlling_Limited_Procedure (Nam)
3709 then
3710 Error_Msg_N
3711 ("entry call, entry renaming or dispatching primitive " &
3712 "of limited or synchronized interface required", N);
3713 end if;
3714 end if;
3716 -- Check that this is not a call to a protected procedure or
3717 -- entry from within a protected function.
3719 if Ekind (Current_Scope) = E_Function
3720 and then Ekind (Scope (Current_Scope)) = E_Protected_Type
3721 and then Ekind (Nam) /= E_Function
3722 and then Scope (Nam) = Scope (Current_Scope)
3723 then
3724 Error_Msg_N ("within protected function, protected " &
3725 "object is constant", N);
3727 end if;
3729 -- Freeze the subprogram name if not in default expression. Note that we
3730 -- freeze procedure calls as well as function calls. Procedure calls are
3731 -- not frozen according to the rules (RM 13.14(14)) because it is
3732 -- impossible to have a procedure call to a non-frozen procedure in pure
3733 -- Ada, but in the code that we generate in the expander, this rule
3734 -- needs extending because we can generate procedure calls that need
3735 -- freezing.
3737 if Is_Entity_Name (Subp) and then not In_Default_Expression then
3738 Freeze_Expression (Subp);
3739 end if;
3741 -- For a predefined operator, the type of the result is the type imposed
3742 -- by context, except for a predefined operation on universal fixed.
3743 -- Otherwise The type of the call is the type returned by the subprogram
3744 -- being called.
3746 if Is_Predefined_Op (Nam) then
3747 if Etype (N) /= Universal_Fixed then
3748 Set_Etype (N, Typ);
3749 end if;
3751 -- If the subprogram returns an array type, and the context requires the
3752 -- component type of that array type, the node is really an indexing of
3753 -- the parameterless call. Resolve as such. A pathological case occurs
3754 -- when the type of the component is an access to the array type. In
3755 -- this case the call is truly ambiguous.
3757 elsif Needs_No_Actuals (Nam)
3758 and then
3759 ((Is_Array_Type (Etype (Nam))
3760 and then Covers (Typ, Component_Type (Etype (Nam))))
3761 or else (Is_Access_Type (Etype (Nam))
3762 and then Is_Array_Type (Designated_Type (Etype (Nam)))
3763 and then
3764 Covers (Typ,
3765 Component_Type (Designated_Type (Etype (Nam))))))
3766 then
3767 declare
3768 Index_Node : Node_Id;
3769 New_Subp : Node_Id;
3770 Ret_Type : constant Entity_Id := Etype (Nam);
3772 begin
3773 if Is_Access_Type (Ret_Type)
3774 and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
3775 then
3776 Error_Msg_N
3777 ("cannot disambiguate function call and indexing", N);
3778 else
3779 New_Subp := Relocate_Node (Subp);
3780 Set_Entity (Subp, Nam);
3782 if Component_Type (Ret_Type) /= Any_Type then
3783 Index_Node :=
3784 Make_Indexed_Component (Loc,
3785 Prefix =>
3786 Make_Function_Call (Loc,
3787 Name => New_Subp),
3788 Expressions => Parameter_Associations (N));
3790 -- Since we are correcting a node classification error made
3791 -- by the parser, we call Replace rather than Rewrite.
3793 Replace (N, Index_Node);
3794 Set_Etype (Prefix (N), Ret_Type);
3795 Set_Etype (N, Typ);
3796 Resolve_Indexed_Component (N, Typ);
3797 Check_Elab_Call (Prefix (N));
3798 end if;
3799 end if;
3801 return;
3802 end;
3804 else
3805 Set_Etype (N, Etype (Nam));
3806 end if;
3808 -- In the case where the call is to an overloaded subprogram, Analyze
3809 -- calls Normalize_Actuals once per overloaded subprogram. Therefore in
3810 -- such a case Normalize_Actuals needs to be called once more to order
3811 -- the actuals correctly. Otherwise the call will have the ordering
3812 -- given by the last overloaded subprogram whether this is the correct
3813 -- one being called or not.
3815 if Is_Overloaded (Subp) then
3816 Normalize_Actuals (N, Nam, False, Norm_OK);
3817 pragma Assert (Norm_OK);
3818 end if;
3820 -- In any case, call is fully resolved now. Reset Overload flag, to
3821 -- prevent subsequent overload resolution if node is analyzed again
3823 Set_Is_Overloaded (Subp, False);
3824 Set_Is_Overloaded (N, False);
3826 -- If we are calling the current subprogram from immediately within its
3827 -- body, then that is the case where we can sometimes detect cases of
3828 -- infinite recursion statically. Do not try this in case restriction
3829 -- No_Recursion is in effect anyway.
3831 Scop := Current_Scope;
3833 if Nam = Scop
3834 and then not Restriction_Active (No_Recursion)
3835 and then Check_Infinite_Recursion (N)
3836 then
3837 -- Here we detected and flagged an infinite recursion, so we do
3838 -- not need to test the case below for further warnings.
3840 null;
3842 -- If call is to immediately containing subprogram, then check for
3843 -- the case of a possible run-time detectable infinite recursion.
3845 else
3846 while Scop /= Standard_Standard loop
3847 if Nam = Scop then
3848 -- Although in general recursion is not statically checkable,
3849 -- the case of calling an immediately containing subprogram
3850 -- is easy to catch.
3852 Check_Restriction (No_Recursion, N);
3854 -- If the recursive call is to a parameterless procedure, then
3855 -- even if we can't statically detect infinite recursion, this
3856 -- is pretty suspicious, and we output a warning. Furthermore,
3857 -- we will try later to detect some cases here at run time by
3858 -- expanding checking code (see Detect_Infinite_Recursion in
3859 -- package Exp_Ch6).
3861 -- If the recursive call is within a handler we do not emit a
3862 -- warning, because this is a common idiom: loop until input
3863 -- is correct, catch illegal input in handler and restart.
3865 if No (First_Formal (Nam))
3866 and then Etype (Nam) = Standard_Void_Type
3867 and then not Error_Posted (N)
3868 and then Nkind (Parent (N)) /= N_Exception_Handler
3869 then
3870 Set_Has_Recursive_Call (Nam);
3871 Error_Msg_N ("possible infinite recursion?", N);
3872 Error_Msg_N ("Storage_Error may be raised at run time?", N);
3873 end if;
3875 exit;
3876 end if;
3878 Scop := Scope (Scop);
3879 end loop;
3880 end if;
3882 -- If subprogram name is a predefined operator, it was given in
3883 -- functional notation. Replace call node with operator node, so
3884 -- that actuals can be resolved appropriately.
3886 if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
3887 Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
3888 return;
3890 elsif Present (Alias (Nam))
3891 and then Is_Predefined_Op (Alias (Nam))
3892 then
3893 Resolve_Actuals (N, Nam);
3894 Make_Call_Into_Operator (N, Typ, Alias (Nam));
3895 return;
3896 end if;
3898 -- Create a transient scope if the resulting type requires it
3900 -- There are 3 notable exceptions: in init procs, the transient scope
3901 -- overhead is not needed and even incorrect due to the actual expansion
3902 -- of adjust calls; the second case is enumeration literal pseudo calls,
3903 -- the other case is intrinsic subprograms (Unchecked_Conversion and
3904 -- source information functions) that do not use the secondary stack
3905 -- even though the return type is unconstrained.
3907 -- If this is an initialization call for a type whose initialization
3908 -- uses the secondary stack, we also need to create a transient scope
3909 -- for it, precisely because we will not do it within the init proc
3910 -- itself.
3912 if Expander_Active
3913 and then Is_Type (Etype (Nam))
3914 and then Requires_Transient_Scope (Etype (Nam))
3915 and then Ekind (Nam) /= E_Enumeration_Literal
3916 and then not Within_Init_Proc
3917 and then not Is_Intrinsic_Subprogram (Nam)
3918 then
3919 Establish_Transient_Scope
3920 (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
3922 -- If the call appears within the bounds of a loop, it will
3923 -- be rewritten and reanalyzed, nothing left to do here.
3925 if Nkind (N) /= N_Function_Call then
3926 return;
3927 end if;
3929 elsif Is_Init_Proc (Nam)
3930 and then not Within_Init_Proc
3931 then
3932 Check_Initialization_Call (N, Nam);
3933 end if;
3935 -- A protected function cannot be called within the definition of the
3936 -- enclosing protected type.
3938 if Is_Protected_Type (Scope (Nam))
3939 and then In_Open_Scopes (Scope (Nam))
3940 and then not Has_Completion (Scope (Nam))
3941 then
3942 Error_Msg_NE
3943 ("& cannot be called before end of protected definition", N, Nam);
3944 end if;
3946 -- Propagate interpretation to actuals, and add default expressions
3947 -- where needed.
3949 if Present (First_Formal (Nam)) then
3950 Resolve_Actuals (N, Nam);
3952 -- Overloaded literals are rewritten as function calls, for
3953 -- purpose of resolution. After resolution, we can replace
3954 -- the call with the literal itself.
3956 elsif Ekind (Nam) = E_Enumeration_Literal then
3957 Copy_Node (Subp, N);
3958 Resolve_Entity_Name (N, Typ);
3960 -- Avoid validation, since it is a static function call
3962 return;
3963 end if;
3965 -- If the subprogram is a primitive operation, check whether or not
3966 -- it is a correct dispatching call.
3968 if Is_Overloadable (Nam)
3969 and then Is_Dispatching_Operation (Nam)
3970 then
3971 Check_Dispatching_Call (N);
3973 elsif Is_Abstract (Nam)
3974 and then not In_Instance
3975 then
3976 Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
3977 end if;
3979 if Is_Intrinsic_Subprogram (Nam) then
3980 Check_Intrinsic_Call (N);
3981 end if;
3983 Eval_Call (N);
3984 Check_Elab_Call (N);
3985 end Resolve_Call;
3987 -------------------------------
3988 -- Resolve_Character_Literal --
3989 -------------------------------
3991 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
3992 B_Typ : constant Entity_Id := Base_Type (Typ);
3993 C : Entity_Id;
3995 begin
3996 -- Verify that the character does belong to the type of the context
3998 Set_Etype (N, B_Typ);
3999 Eval_Character_Literal (N);
4001 -- Wide_Wide_Character literals must always be defined, since the set
4002 -- of wide wide character literals is complete, i.e. if a character
4003 -- literal is accepted by the parser, then it is OK for wide wide
4004 -- character (out of range character literals are rejected).
4006 if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
4007 return;
4009 -- Always accept character literal for type Any_Character, which
4010 -- occurs in error situations and in comparisons of literals, both
4011 -- of which should accept all literals.
4013 elsif B_Typ = Any_Character then
4014 return;
4016 -- For Standard.Character or a type derived from it, check that
4017 -- the literal is in range
4019 elsif Root_Type (B_Typ) = Standard_Character then
4020 if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
4021 return;
4022 end if;
4024 -- For Standard.Wide_Character or a type derived from it, check
4025 -- that the literal is in range
4027 elsif Root_Type (B_Typ) = Standard_Wide_Character then
4028 if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
4029 return;
4030 end if;
4032 -- For Standard.Wide_Wide_Character or a type derived from it, we
4033 -- know the literal is in range, since the parser checked!
4035 elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
4036 return;
4038 -- If the entity is already set, this has already been resolved in
4039 -- a generic context, or comes from expansion. Nothing else to do.
4041 elsif Present (Entity (N)) then
4042 return;
4044 -- Otherwise we have a user defined character type, and we can use
4045 -- the standard visibility mechanisms to locate the referenced entity
4047 else
4048 C := Current_Entity (N);
4049 while Present (C) loop
4050 if Etype (C) = B_Typ then
4051 Set_Entity_With_Style_Check (N, C);
4052 Generate_Reference (C, N);
4053 return;
4054 end if;
4056 C := Homonym (C);
4057 end loop;
4058 end if;
4060 -- If we fall through, then the literal does not match any of the
4061 -- entries of the enumeration type. This isn't just a constraint
4062 -- error situation, it is an illegality (see RM 4.2).
4064 Error_Msg_NE
4065 ("character not defined for }", N, First_Subtype (B_Typ));
4066 end Resolve_Character_Literal;
4068 ---------------------------
4069 -- Resolve_Comparison_Op --
4070 ---------------------------
4072 -- Context requires a boolean type, and plays no role in resolution.
4073 -- Processing identical to that for equality operators. The result
4074 -- type is the base type, which matters when pathological subtypes of
4075 -- booleans with limited ranges are used.
4077 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
4078 L : constant Node_Id := Left_Opnd (N);
4079 R : constant Node_Id := Right_Opnd (N);
4080 T : Entity_Id;
4082 begin
4083 -- If this is an intrinsic operation which is not predefined, use
4084 -- the types of its declared arguments to resolve the possibly
4085 -- overloaded operands. Otherwise the operands are unambiguous and
4086 -- specify the expected type.
4088 if Scope (Entity (N)) /= Standard_Standard then
4089 T := Etype (First_Entity (Entity (N)));
4091 else
4092 T := Find_Unique_Type (L, R);
4094 if T = Any_Fixed then
4095 T := Unique_Fixed_Point_Type (L);
4096 end if;
4097 end if;
4099 Set_Etype (N, Base_Type (Typ));
4102 if T /= Any_Type then
4103 if T = Any_String
4104 or else T = Any_Composite
4105 or else T = Any_Character
4106 then
4107 if T = Any_Character then
4108 Ambiguous_Character (L);
4109 else
4110 Error_Msg_N ("ambiguous operands for comparison", N);
4111 end if;
4113 Set_Etype (N, Any_Type);
4114 return;
4116 else
4117 Resolve (L, T);
4118 Resolve (R, T);
4119 Check_Unset_Reference (L);
4120 Check_Unset_Reference (R);
4121 Generate_Operator_Reference (N, T);
4122 Eval_Relational_Op (N);
4123 Check_Direct_Boolean_Op (N);
4124 end if;
4125 end if;
4126 end Resolve_Comparison_Op;
4128 ------------------------------------
4129 -- Resolve_Conditional_Expression --
4130 ------------------------------------
4132 procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
4133 Condition : constant Node_Id := First (Expressions (N));
4134 Then_Expr : constant Node_Id := Next (Condition);
4135 Else_Expr : constant Node_Id := Next (Then_Expr);
4137 begin
4138 Resolve (Condition, Standard_Boolean);
4139 Resolve (Then_Expr, Typ);
4140 Resolve (Else_Expr, Typ);
4142 Set_Etype (N, Typ);
4143 Eval_Conditional_Expression (N);
4144 end Resolve_Conditional_Expression;
4146 -----------------------------------------
4147 -- Resolve_Discrete_Subtype_Indication --
4148 -----------------------------------------
4150 procedure Resolve_Discrete_Subtype_Indication
4151 (N : Node_Id;
4152 Typ : Entity_Id)
4153 is
4154 R : Node_Id;
4155 S : Entity_Id;
4157 begin
4158 Analyze (Subtype_Mark (N));
4159 S := Entity (Subtype_Mark (N));
4161 if Nkind (Constraint (N)) /= N_Range_Constraint then
4162 Error_Msg_N ("expect range constraint for discrete type", N);
4163 Set_Etype (N, Any_Type);
4165 else
4166 R := Range_Expression (Constraint (N));
4168 if R = Error then
4169 return;
4170 end if;
4172 Analyze (R);
4174 if Base_Type (S) /= Base_Type (Typ) then
4175 Error_Msg_NE
4176 ("expect subtype of }", N, First_Subtype (Typ));
4178 -- Rewrite the constraint as a range of Typ
4179 -- to allow compilation to proceed further.
4181 Set_Etype (N, Typ);
4182 Rewrite (Low_Bound (R),
4183 Make_Attribute_Reference (Sloc (Low_Bound (R)),
4184 Prefix => New_Occurrence_Of (Typ, Sloc (R)),
4185 Attribute_Name => Name_First));
4186 Rewrite (High_Bound (R),
4187 Make_Attribute_Reference (Sloc (High_Bound (R)),
4188 Prefix => New_Occurrence_Of (Typ, Sloc (R)),
4189 Attribute_Name => Name_First));
4191 else
4192 Resolve (R, Typ);
4193 Set_Etype (N, Etype (R));
4195 -- Additionally, we must check that the bounds are compatible
4196 -- with the given subtype, which might be different from the
4197 -- type of the context.
4199 Apply_Range_Check (R, S);
4201 -- ??? If the above check statically detects a Constraint_Error
4202 -- it replaces the offending bound(s) of the range R with a
4203 -- Constraint_Error node. When the itype which uses these bounds
4204 -- is frozen the resulting call to Duplicate_Subexpr generates
4205 -- a new temporary for the bounds.
4207 -- Unfortunately there are other itypes that are also made depend
4208 -- on these bounds, so when Duplicate_Subexpr is called they get
4209 -- a forward reference to the newly created temporaries and Gigi
4210 -- aborts on such forward references. This is probably sign of a
4211 -- more fundamental problem somewhere else in either the order of
4212 -- itype freezing or the way certain itypes are constructed.
4214 -- To get around this problem we call Remove_Side_Effects right
4215 -- away if either bounds of R are a Constraint_Error.
4217 declare
4218 L : constant Node_Id := Low_Bound (R);
4219 H : constant Node_Id := High_Bound (R);
4221 begin
4222 if Nkind (L) = N_Raise_Constraint_Error then
4223 Remove_Side_Effects (L);
4224 end if;
4226 if Nkind (H) = N_Raise_Constraint_Error then
4227 Remove_Side_Effects (H);
4228 end if;
4229 end;
4231 Check_Unset_Reference (Low_Bound (R));
4232 Check_Unset_Reference (High_Bound (R));
4233 end if;
4234 end if;
4235 end Resolve_Discrete_Subtype_Indication;
4237 -------------------------
4238 -- Resolve_Entity_Name --
4239 -------------------------
4241 -- Used to resolve identifiers and expanded names
4243 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
4244 E : constant Entity_Id := Entity (N);
4246 begin
4247 -- If garbage from errors, set to Any_Type and return
4249 if No (E) and then Total_Errors_Detected /= 0 then
4250 Set_Etype (N, Any_Type);
4251 return;
4252 end if;
4254 -- Replace named numbers by corresponding literals. Note that this is
4255 -- the one case where Resolve_Entity_Name must reset the Etype, since
4256 -- it is currently marked as universal.
4258 if Ekind (E) = E_Named_Integer then
4259 Set_Etype (N, Typ);
4260 Eval_Named_Integer (N);
4262 elsif Ekind (E) = E_Named_Real then
4263 Set_Etype (N, Typ);
4264 Eval_Named_Real (N);
4266 -- Allow use of subtype only if it is a concurrent type where we are
4267 -- currently inside the body. This will eventually be expanded
4268 -- into a call to Self (for tasks) or _object (for protected
4269 -- objects). Any other use of a subtype is invalid.
4271 elsif Is_Type (E) then
4272 if Is_Concurrent_Type (E)
4273 and then In_Open_Scopes (E)
4274 then
4275 null;
4276 else
4277 Error_Msg_N
4278 ("invalid use of subtype mark in expression or call", N);
4279 end if;
4281 -- Check discriminant use if entity is discriminant in current scope,
4282 -- i.e. discriminant of record or concurrent type currently being
4283 -- analyzed. Uses in corresponding body are unrestricted.
4285 elsif Ekind (E) = E_Discriminant
4286 and then Scope (E) = Current_Scope
4287 and then not Has_Completion (Current_Scope)
4288 then
4289 Check_Discriminant_Use (N);
4291 -- A parameterless generic function cannot appear in a context that
4292 -- requires resolution.
4294 elsif Ekind (E) = E_Generic_Function then
4295 Error_Msg_N ("illegal use of generic function", N);
4297 elsif Ekind (E) = E_Out_Parameter
4298 and then Ada_Version = Ada_83
4299 and then (Nkind (Parent (N)) in N_Op
4300 or else (Nkind (Parent (N)) = N_Assignment_Statement
4301 and then N = Expression (Parent (N)))
4302 or else Nkind (Parent (N)) = N_Explicit_Dereference)
4303 then
4304 Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
4306 -- In all other cases, just do the possible static evaluation
4308 else
4309 -- A deferred constant that appears in an expression must have
4310 -- a completion, unless it has been removed by in-place expansion
4311 -- of an aggregate.
4313 if Ekind (E) = E_Constant
4314 and then Comes_From_Source (E)
4315 and then No (Constant_Value (E))
4316 and then Is_Frozen (Etype (E))
4317 and then not In_Default_Expression
4318 and then not Is_Imported (E)
4319 then
4321 if No_Initialization (Parent (E))
4322 or else (Present (Full_View (E))
4323 and then No_Initialization (Parent (Full_View (E))))
4324 then
4325 null;
4326 else
4327 Error_Msg_N (
4328 "deferred constant is frozen before completion", N);
4329 end if;
4330 end if;
4332 Eval_Entity_Name (N);
4333 end if;
4334 end Resolve_Entity_Name;
4336 -------------------
4337 -- Resolve_Entry --
4338 -------------------
4340 procedure Resolve_Entry (Entry_Name : Node_Id) is
4341 Loc : constant Source_Ptr := Sloc (Entry_Name);
4342 Nam : Entity_Id;
4343 New_N : Node_Id;
4344 S : Entity_Id;
4345 Tsk : Entity_Id;
4346 E_Name : Node_Id;
4347 Index : Node_Id;
4349 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
4350 -- If the bounds of the entry family being called depend on task
4351 -- discriminants, build a new index subtype where a discriminant is
4352 -- replaced with the value of the discriminant of the target task.
4353 -- The target task is the prefix of the entry name in the call.
4355 -----------------------
4356 -- Actual_Index_Type --
4357 -----------------------
4359 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
4360 Typ : constant Entity_Id := Entry_Index_Type (E);
4361 Tsk : constant Entity_Id := Scope (E);
4362 Lo : constant Node_Id := Type_Low_Bound (Typ);
4363 Hi : constant Node_Id := Type_High_Bound (Typ);
4364 New_T : Entity_Id;
4366 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
4367 -- If the bound is given by a discriminant, replace with a reference
4368 -- to the discriminant of the same name in the target task.
4369 -- If the entry name is the target of a requeue statement and the
4370 -- entry is in the current protected object, the bound to be used
4371 -- is the discriminal of the object (see apply_range_checks for
4372 -- details of the transformation).
4374 -----------------------------
4375 -- Actual_Discriminant_Ref --
4376 -----------------------------
4378 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
4379 Typ : constant Entity_Id := Etype (Bound);
4380 Ref : Node_Id;
4382 begin
4383 Remove_Side_Effects (Bound);
4385 if not Is_Entity_Name (Bound)
4386 or else Ekind (Entity (Bound)) /= E_Discriminant
4387 then
4388 return Bound;
4390 elsif Is_Protected_Type (Tsk)
4391 and then In_Open_Scopes (Tsk)
4392 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
4393 then
4394 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
4396 else
4397 Ref :=
4398 Make_Selected_Component (Loc,
4399 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
4400 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
4401 Analyze (Ref);
4402 Resolve (Ref, Typ);
4403 return Ref;
4404 end if;
4405 end Actual_Discriminant_Ref;
4407 -- Start of processing for Actual_Index_Type
4409 begin
4410 if not Has_Discriminants (Tsk)
4411 or else (not Is_Entity_Name (Lo)
4412 and then not Is_Entity_Name (Hi))
4413 then
4414 return Entry_Index_Type (E);
4416 else
4417 New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
4418 Set_Etype (New_T, Base_Type (Typ));
4419 Set_Size_Info (New_T, Typ);
4420 Set_RM_Size (New_T, RM_Size (Typ));
4421 Set_Scalar_Range (New_T,
4422 Make_Range (Sloc (Entry_Name),
4423 Low_Bound => Actual_Discriminant_Ref (Lo),
4424 High_Bound => Actual_Discriminant_Ref (Hi)));
4426 return New_T;
4427 end if;
4428 end Actual_Index_Type;
4430 -- Start of processing of Resolve_Entry
4432 begin
4433 -- Find name of entry being called, and resolve prefix of name
4434 -- with its own type. The prefix can be overloaded, and the name
4435 -- and signature of the entry must be taken into account.
4437 if Nkind (Entry_Name) = N_Indexed_Component then
4439 -- Case of dealing with entry family within the current tasks
4441 E_Name := Prefix (Entry_Name);
4443 else
4444 E_Name := Entry_Name;
4445 end if;
4447 if Is_Entity_Name (E_Name) then
4448 -- Entry call to an entry (or entry family) in the current task.
4449 -- This is legal even though the task will deadlock. Rewrite as
4450 -- call to current task.
4452 -- This can also be a call to an entry in an enclosing task.
4453 -- If this is a single task, we have to retrieve its name,
4454 -- because the scope of the entry is the task type, not the
4455 -- object. If the enclosing task is a task type, the identity
4456 -- of the task is given by its own self variable.
4458 -- Finally this can be a requeue on an entry of the same task
4459 -- or protected object.
4461 S := Scope (Entity (E_Name));
4463 for J in reverse 0 .. Scope_Stack.Last loop
4465 if Is_Task_Type (Scope_Stack.Table (J).Entity)
4466 and then not Comes_From_Source (S)
4467 then
4468 -- S is an enclosing task or protected object. The concurrent
4469 -- declaration has been converted into a type declaration, and
4470 -- the object itself has an object declaration that follows
4471 -- the type in the same declarative part.
4473 Tsk := Next_Entity (S);
4474 while Etype (Tsk) /= S loop
4475 Next_Entity (Tsk);
4476 end loop;
4478 S := Tsk;
4479 exit;
4481 elsif S = Scope_Stack.Table (J).Entity then
4483 -- Call to current task. Will be transformed into call to Self
4485 exit;
4487 end if;
4488 end loop;
4490 New_N :=
4491 Make_Selected_Component (Loc,
4492 Prefix => New_Occurrence_Of (S, Loc),
4493 Selector_Name =>
4494 New_Occurrence_Of (Entity (E_Name), Loc));
4495 Rewrite (E_Name, New_N);
4496 Analyze (E_Name);
4498 elsif Nkind (Entry_Name) = N_Selected_Component
4499 and then Is_Overloaded (Prefix (Entry_Name))
4500 then
4501 -- Use the entry name (which must be unique at this point) to
4502 -- find the prefix that returns the corresponding task type or
4503 -- protected type.
4505 declare
4506 Pref : constant Node_Id := Prefix (Entry_Name);
4507 Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name));
4508 I : Interp_Index;
4509 It : Interp;
4511 begin
4512 Get_First_Interp (Pref, I, It);
4513 while Present (It.Typ) loop
4514 if Scope (Ent) = It.Typ then
4515 Set_Etype (Pref, It.Typ);
4516 exit;
4517 end if;
4519 Get_Next_Interp (I, It);
4520 end loop;
4521 end;
4522 end if;
4524 if Nkind (Entry_Name) = N_Selected_Component then
4525 Resolve (Prefix (Entry_Name));
4527 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4528 Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4529 Resolve (Prefix (Prefix (Entry_Name)));
4530 Index := First (Expressions (Entry_Name));
4531 Resolve (Index, Entry_Index_Type (Nam));
4533 -- Up to this point the expression could have been the actual
4534 -- in a simple entry call, and be given by a named association.
4536 if Nkind (Index) = N_Parameter_Association then
4537 Error_Msg_N ("expect expression for entry index", Index);
4538 else
4539 Apply_Range_Check (Index, Actual_Index_Type (Nam));
4540 end if;
4541 end if;
4542 end Resolve_Entry;
4544 ------------------------
4545 -- Resolve_Entry_Call --
4546 ------------------------
4548 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
4549 Entry_Name : constant Node_Id := Name (N);
4550 Loc : constant Source_Ptr := Sloc (Entry_Name);
4551 Actuals : List_Id;
4552 First_Named : Node_Id;
4553 Nam : Entity_Id;
4554 Norm_OK : Boolean;
4555 Obj : Node_Id;
4556 Was_Over : Boolean;
4558 begin
4559 -- We kill all checks here, because it does not seem worth the
4560 -- effort to do anything better, an entry call is a big operation.
4562 Kill_All_Checks;
4564 -- Processing of the name is similar for entry calls and protected
4565 -- operation calls. Once the entity is determined, we can complete
4566 -- the resolution of the actuals.
4568 -- The selector may be overloaded, in the case of a protected object
4569 -- with overloaded functions. The type of the context is used for
4570 -- resolution.
4572 if Nkind (Entry_Name) = N_Selected_Component
4573 and then Is_Overloaded (Selector_Name (Entry_Name))
4574 and then Typ /= Standard_Void_Type
4575 then
4576 declare
4577 I : Interp_Index;
4578 It : Interp;
4580 begin
4581 Get_First_Interp (Selector_Name (Entry_Name), I, It);
4582 while Present (It.Typ) loop
4583 if Covers (Typ, It.Typ) then
4584 Set_Entity (Selector_Name (Entry_Name), It.Nam);
4585 Set_Etype (Entry_Name, It.Typ);
4588 end if;
4590 Get_Next_Interp (I, It);
4591 end loop;
4592 end;
4593 end if;
4595 Resolve_Entry (Entry_Name);
4597 if Nkind (Entry_Name) = N_Selected_Component then
4599 -- Simple entry call
4601 Nam := Entity (Selector_Name (Entry_Name));
4602 Obj := Prefix (Entry_Name);
4603 Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
4605 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4607 -- Call to member of entry family
4609 Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4610 Obj := Prefix (Prefix (Entry_Name));
4611 Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
4612 end if;
4614 -- We cannot in general check the maximum depth of protected entry
4615 -- calls at compile time. But we can tell that any protected entry
4616 -- call at all violates a specified nesting depth of zero.
4618 if Is_Protected_Type (Scope (Nam)) then
4619 Check_Restriction (Max_Entry_Queue_Length, N);
4620 end if;
4622 -- Use context type to disambiguate a protected function that can be
4623 -- called without actuals and that returns an array type, and where
4624 -- the argument list may be an indexing of the returned value.
4626 if Ekind (Nam) = E_Function
4627 and then Needs_No_Actuals (Nam)
4628 and then Present (Parameter_Associations (N))
4629 and then
4630 ((Is_Array_Type (Etype (Nam))
4631 and then Covers (Typ, Component_Type (Etype (Nam))))
4633 or else (Is_Access_Type (Etype (Nam))
4634 and then Is_Array_Type (Designated_Type (Etype (Nam)))
4635 and then Covers (Typ,
4636 Component_Type (Designated_Type (Etype (Nam))))))
4637 then
4638 declare
4639 Index_Node : Node_Id;
4641 begin
4642 Index_Node :=
4643 Make_Indexed_Component (Loc,
4644 Prefix =>
4645 Make_Function_Call (Loc,
4646 Name => Relocate_Node (Entry_Name)),
4647 Expressions => Parameter_Associations (N));
4649 -- Since we are correcting a node classification error made by
4650 -- the parser, we call Replace rather than Rewrite.
4652 Replace (N, Index_Node);
4653 Set_Etype (Prefix (N), Etype (Nam));
4654 Set_Etype (N, Typ);
4655 Resolve_Indexed_Component (N, Typ);
4656 return;
4657 end;
4658 end if;
4660 -- The operation name may have been overloaded. Order the actuals
4661 -- according to the formals of the resolved entity, and set the
4662 -- return type to that of the operation.
4664 if Was_Over then
4665 Normalize_Actuals (N, Nam, False, Norm_OK);
4666 pragma Assert (Norm_OK);
4667 Set_Etype (N, Etype (Nam));
4668 end if;
4670 Resolve_Actuals (N, Nam);
4671 Generate_Reference (Nam, Entry_Name);
4673 if Ekind (Nam) = E_Entry
4674 or else Ekind (Nam) = E_Entry_Family
4675 then
4676 Check_Potentially_Blocking_Operation (N);
4677 end if;
4679 -- Verify that a procedure call cannot masquerade as an entry
4680 -- call where an entry call is expected.
4682 if Ekind (Nam) = E_Procedure then
4683 if Nkind (Parent (N)) = N_Entry_Call_Alternative
4684 and then N = Entry_Call_Statement (Parent (N))
4685 then
4686 Error_Msg_N ("entry call required in select statement", N);
4688 elsif Nkind (Parent (N)) = N_Triggering_Alternative
4689 and then N = Triggering_Statement (Parent (N))
4690 then
4691 Error_Msg_N ("triggering statement cannot be procedure call", N);
4693 elsif Ekind (Scope (Nam)) = E_Task_Type
4694 and then not In_Open_Scopes (Scope (Nam))
4695 then
4696 Error_Msg_N ("task has no entry with this name", Entry_Name);
4697 end if;
4698 end if;
4700 -- After resolution, entry calls and protected procedure calls
4701 -- are changed into entry calls, for expansion. The structure
4702 -- of the node does not change, so it can safely be done in place.
4703 -- Protected function calls must keep their structure because they
4704 -- are subexpressions.
4706 if Ekind (Nam) /= E_Function then
4708 -- A protected operation that is not a function may modify the
4709 -- corresponding object, and cannot apply to a constant.
4710 -- If this is an internal call, the prefix is the type itself.
4712 if Is_Protected_Type (Scope (Nam))
4713 and then not Is_Variable (Obj)
4714 and then (not Is_Entity_Name (Obj)
4715 or else not Is_Type (Entity (Obj)))
4716 then
4717 Error_Msg_N
4718 ("prefix of protected procedure or entry call must be variable",
4719 Entry_Name);
4720 end if;
4722 Actuals := Parameter_Associations (N);
4723 First_Named := First_Named_Actual (N);
4725 Rewrite (N,
4726 Make_Entry_Call_Statement (Loc,
4727 Name => Entry_Name,
4728 Parameter_Associations => Actuals));
4730 Set_First_Named_Actual (N, First_Named);
4731 Set_Analyzed (N, True);
4733 -- Protected functions can return on the secondary stack, in which
4734 -- case we must trigger the transient scope mechanism.
4736 elsif Expander_Active
4737 and then Requires_Transient_Scope (Etype (Nam))
4738 then
4739 Establish_Transient_Scope (N,
4740 Sec_Stack => not Functions_Return_By_DSP_On_Target);
4741 end if;
4742 end Resolve_Entry_Call;
4744 -------------------------
4745 -- Resolve_Equality_Op --
4746 -------------------------
4748 -- Both arguments must have the same type, and the boolean context
4749 -- does not participate in the resolution. The first pass verifies
4750 -- that the interpretation is not ambiguous, and the type of the left
4751 -- argument is correctly set, or is Any_Type in case of ambiguity.
4752 -- If both arguments are strings or aggregates, allocators, or Null,
4753 -- they are ambiguous even though they carry a single (universal) type.
4754 -- Diagnose this case here.
4756 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
4757 L : constant Node_Id := Left_Opnd (N);
4758 R : constant Node_Id := Right_Opnd (N);
4759 T : Entity_Id := Find_Unique_Type (L, R);
4761 function Find_Unique_Access_Type return Entity_Id;
4762 -- In the case of allocators, make a last-ditch attempt to find a single
4763 -- access type with the right designated type. This is semantically
4764 -- dubious, and of no interest to any real code, but c48008a makes it
4765 -- all worthwhile.
4767 -----------------------------
4768 -- Find_Unique_Access_Type --
4769 -----------------------------
4771 function Find_Unique_Access_Type return Entity_Id is
4772 Acc : Entity_Id;
4773 E : Entity_Id;
4774 S : Entity_Id;
4776 begin
4777 if Ekind (Etype (R)) = E_Allocator_Type then
4778 Acc := Designated_Type (Etype (R));
4780 elsif Ekind (Etype (L)) = E_Allocator_Type then
4781 Acc := Designated_Type (Etype (L));
4783 else
4784 return Empty;
4785 end if;
4787 S := Current_Scope;
4788 while S /= Standard_Standard loop
4789 E := First_Entity (S);
4790 while Present (E) loop
4791 if Is_Type (E)
4792 and then Is_Access_Type (E)
4793 and then Ekind (E) /= E_Allocator_Type
4794 and then Designated_Type (E) = Base_Type (Acc)
4795 then
4796 return E;
4797 end if;
4799 Next_Entity (E);
4800 end loop;
4802 S := Scope (S);
4803 end loop;
4805 return Empty;
4806 end Find_Unique_Access_Type;
4808 -- Start of processing for Resolve_Equality_Op
4810 begin
4811 Set_Etype (N, Base_Type (Typ));
4814 if T = Any_Fixed then
4815 T := Unique_Fixed_Point_Type (L);
4816 end if;
4818 if T /= Any_Type then
4819 if T = Any_String
4820 or else T = Any_Composite
4821 or else T = Any_Character
4822 then
4823 if T = Any_Character then
4824 Ambiguous_Character (L);
4825 else
4826 Error_Msg_N ("ambiguous operands for equality", N);
4827 end if;
4829 Set_Etype (N, Any_Type);
4830 return;
4832 elsif T = Any_Access
4833 or else Ekind (T) = E_Allocator_Type
4834 then
4835 T := Find_Unique_Access_Type;
4837 if No (T) then
4838 Error_Msg_N ("ambiguous operands for equality", N);
4839 Set_Etype (N, Any_Type);
4840 return;
4841 end if;
4842 end if;
4844 Resolve (L, T);
4845 Resolve (R, T);
4847 if Warn_On_Redundant_Constructs
4848 and then Comes_From_Source (N)
4849 and then Is_Entity_Name (R)
4850 and then Entity (R) = Standard_True
4851 and then Comes_From_Source (R)
4852 then
4853 Error_Msg_N ("comparison with True is redundant?", R);
4854 end if;
4856 Check_Unset_Reference (L);
4857 Check_Unset_Reference (R);
4858 Generate_Operator_Reference (N, T);
4860 -- If this is an inequality, it may be the implicit inequality
4861 -- created for a user-defined operation, in which case the corres-
4862 -- ponding equality operation is not intrinsic, and the operation
4863 -- cannot be constant-folded. Else fold.
4865 if Nkind (N) = N_Op_Eq
4866 or else Comes_From_Source (Entity (N))
4867 or else Ekind (Entity (N)) = E_Operator
4868 or else Is_Intrinsic_Subprogram
4869 (Corresponding_Equality (Entity (N)))
4870 then
4871 Eval_Relational_Op (N);
4872 elsif Nkind (N) = N_Op_Ne
4873 and then Is_Abstract (Entity (N))
4874 then
4875 Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
4876 end if;
4878 Check_Direct_Boolean_Op (N);
4879 end if;
4880 end Resolve_Equality_Op;
4882 ----------------------------------
4883 -- Resolve_Explicit_Dereference --
4884 ----------------------------------
4886 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
4887 Loc : constant Source_Ptr := Sloc (N);
4888 New_N : Node_Id;
4889 P : constant Node_Id := Prefix (N);
4890 I : Interp_Index;
4891 It : Interp;
4893 begin
4894 -- Now that we know the type, check that this is not dereference of an
4895 -- uncompleted type. Note that this is not entirely correct, because
4896 -- dereferences of private types are legal in default expressions. This
4897 -- exception is taken care of in Check_Fully_Declared.
4899 -- This consideration also applies to similar checks for allocators,
4900 -- qualified expressions, and type conversions.
4902 -- An additional exception concerns other per-object expressions that
4903 -- are not directly related to component declarations, in particular
4904 -- representation pragmas for tasks. These will be per-object
4905 -- expressions if they depend on discriminants or some global entity.
4906 -- If the task has access discriminants, the designated type may be
4907 -- incomplete at the point the expression is resolved. This resolution
4908 -- takes place within the body of the initialization procedure, where
4909 -- the discriminant is replaced by its discriminal.
4911 if Is_Entity_Name (Prefix (N))
4912 and then Ekind (Entity (Prefix (N))) = E_In_Parameter
4913 then
4914 null;
4916 -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
4917 -- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_
4918 -- Object_Renaming, and Freeze_Entity.
4920 elsif Ada_Version >= Ada_05
4921 and then Is_Entity_Name (Prefix (N))
4922 and then Ekind (Directly_Designated_Type (Etype (Prefix (N))))
4923 = E_Incomplete_Type
4924 and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
4925 then
4926 null;
4927 else
4928 Check_Fully_Declared (Typ, N);
4929 end if;
4931 if Is_Overloaded (P) then
4933 -- Use the context type to select the prefix that has the correct
4934 -- designated type.
4936 Get_First_Interp (P, I, It);
4937 while Present (It.Typ) loop
4938 exit when Is_Access_Type (It.Typ)
4939 and then Covers (Typ, Designated_Type (It.Typ));
4940 Get_Next_Interp (I, It);
4941 end loop;
4943 if Present (It.Typ) then
4944 Resolve (P, It.Typ);
4945 else
4946 -- If no interpretation covers the designated type of the prefix,
4947 -- this is the pathological case where not all implementations of
4948 -- the prefix allow the interpretation of the node as a call. Now
4949 -- that the expected type is known, Remove other interpretations
4950 -- from prefix, rewrite it as a call, and resolve again, so that
4951 -- the proper call node is generated.
4953 Get_First_Interp (P, I, It);
4954 while Present (It.Typ) loop
4955 if Ekind (It.Typ) /= E_Access_Subprogram_Type then
4956 Remove_Interp (I);
4957 end if;
4959 Get_Next_Interp (I, It);
4960 end loop;
4962 New_N :=
4963 Make_Function_Call (Loc,
4964 Name =>
4965 Make_Explicit_Dereference (Loc,
4966 Prefix => P),
4967 Parameter_Associations => New_List);
4969 Save_Interps (N, New_N);
4970 Rewrite (N, New_N);
4971 Analyze_And_Resolve (N, Typ);
4972 return;
4973 end if;
4975 Set_Etype (N, Designated_Type (It.Typ));
4977 else
4978 Resolve (P);
4979 end if;
4981 if Is_Access_Type (Etype (P)) then
4982 Apply_Access_Check (N);
4983 end if;
4985 -- If the designated type is a packed unconstrained array type, and the
4986 -- explicit dereference is not in the context of an attribute reference,
4987 -- then we must compute and set the actual subtype, since it is needed
4988 -- by Gigi. The reason we exclude the attribute case is that this is
4989 -- handled fine by Gigi, and in fact we use such attributes to build the
4990 -- actual subtype. We also exclude generated code (which builds actual
4991 -- subtypes directly if they are needed).
4993 if Is_Array_Type (Etype (N))
4994 and then Is_Packed (Etype (N))
4995 and then not Is_Constrained (Etype (N))
4996 and then Nkind (Parent (N)) /= N_Attribute_Reference
4997 and then Comes_From_Source (N)
4998 then
4999 Set_Etype (N, Get_Actual_Subtype (N));
5000 end if;
5002 -- Note: there is no Eval processing required for an explicit deference,
5003 -- because the type is known to be an allocators, and allocator
5004 -- expressions can never be static.
5006 end Resolve_Explicit_Dereference;
5008 -------------------------------
5009 -- Resolve_Indexed_Component --
5010 -------------------------------
5012 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
5013 Name : constant Node_Id := Prefix (N);
5014 Expr : Node_Id;
5015 Array_Type : Entity_Id := Empty; -- to prevent junk warning
5016 Index : Node_Id;
5018 begin
5019 if Is_Overloaded (Name) then
5021 -- Use the context type to select the prefix that yields the correct
5022 -- component type.
5024 declare
5025 I : Interp_Index;
5026 It : Interp;
5027 I1 : Interp_Index := 0;
5028 P : constant Node_Id := Prefix (N);
5029 Found : Boolean := False;
5031 begin
5032 Get_First_Interp (P, I, It);
5033 while Present (It.Typ) loop
5034 if (Is_Array_Type (It.Typ)
5035 and then Covers (Typ, Component_Type (It.Typ)))
5036 or else (Is_Access_Type (It.Typ)
5037 and then Is_Array_Type (Designated_Type (It.Typ))
5038 and then Covers
5039 (Typ, Component_Type (Designated_Type (It.Typ))))
5040 then
5041 if Found then
5042 It := Disambiguate (P, I1, I, Any_Type);
5044 if It = No_Interp then
5045 Error_Msg_N ("ambiguous prefix for indexing", N);
5046 Set_Etype (N, Typ);
5047 return;
5049 else
5050 Found := True;
5051 Array_Type := It.Typ;
5052 I1 := I;
5053 end if;
5055 else
5056 Found := True;
5057 Array_Type := It.Typ;
5058 I1 := I;
5059 end if;
5060 end if;
5062 Get_Next_Interp (I, It);
5063 end loop;
5064 end;
5066 else
5067 Array_Type := Etype (Name);
5068 end if;
5070 Resolve (Name, Array_Type);
5071 Array_Type := Get_Actual_Subtype_If_Available (Name);
5073 -- If prefix is access type, dereference to get real array type.
5074 -- Note: we do not apply an access check because the expander always
5075 -- introduces an explicit dereference, and the check will happen there.
5077 if Is_Access_Type (Array_Type) then
5078 Array_Type := Designated_Type (Array_Type);
5079 end if;
5081 -- If name was overloaded, set component type correctly now
5083 Set_Etype (N, Component_Type (Array_Type));
5085 Index := First_Index (Array_Type);
5086 Expr := First (Expressions (N));
5088 -- The prefix may have resolved to a string literal, in which case its
5089 -- etype has a special representation. This is only possible currently
5090 -- if the prefix is a static concatenation, written in functional
5091 -- notation.
5093 if Ekind (Array_Type) = E_String_Literal_Subtype then
5094 Resolve (Expr, Standard_Positive);
5096 else
5097 while Present (Index) and Present (Expr) loop
5098 Resolve (Expr, Etype (Index));
5099 Check_Unset_Reference (Expr);
5101 if Is_Scalar_Type (Etype (Expr)) then
5102 Apply_Scalar_Range_Check (Expr, Etype (Index));
5103 else
5104 Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
5105 end if;
5107 Next_Index (Index);
5108 Next (Expr);
5109 end loop;
5110 end if;
5112 Eval_Indexed_Component (N);
5113 end Resolve_Indexed_Component;
5115 -----------------------------
5116 -- Resolve_Integer_Literal --
5117 -----------------------------
5119 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
5120 begin
5121 Set_Etype (N, Typ);
5122 Eval_Integer_Literal (N);
5123 end Resolve_Integer_Literal;
5125 --------------------------------
5126 -- Resolve_Intrinsic_Operator --
5127 --------------------------------
5129 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
5130 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
5131 Op : Entity_Id;
5132 Arg1 : Node_Id;
5133 Arg2 : Node_Id;
5135 begin
5136 Op := Entity (N);
5137 while Scope (Op) /= Standard_Standard loop
5138 Op := Homonym (Op);
5139 pragma Assert (Present (Op));
5140 end loop;
5142 Set_Entity (N, Op);
5143 Set_Is_Overloaded (N, False);
5145 -- If the operand type is private, rewrite with suitable conversions on
5146 -- the operands and the result, to expose the proper underlying numeric
5147 -- type.
5149 if Is_Private_Type (Typ) then
5150 Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
5152 if Nkind (N) = N_Op_Expon then
5153 Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
5154 else
5155 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
5156 end if;
5158 Save_Interps (Left_Opnd (N), Expression (Arg1));
5159 Save_Interps (Right_Opnd (N), Expression (Arg2));
5161 Set_Left_Opnd (N, Arg1);
5162 Set_Right_Opnd (N, Arg2);
5164 Set_Etype (N, Btyp);
5165 Rewrite (N, Unchecked_Convert_To (Typ, N));
5166 Resolve (N, Typ);
5168 elsif Typ /= Etype (Left_Opnd (N))
5169 or else Typ /= Etype (Right_Opnd (N))
5170 then
5171 -- Add explicit conversion where needed, and save interpretations
5172 -- in case operands are overloaded.
5174 Arg1 := Convert_To (Typ, Left_Opnd (N));
5175 Arg2 := Convert_To (Typ, Right_Opnd (N));
5177 if Nkind (Arg1) = N_Type_Conversion then
5178 Save_Interps (Left_Opnd (N), Expression (Arg1));
5179 else
5180 Save_Interps (Left_Opnd (N), Arg1);
5181 end if;
5183 if Nkind (Arg2) = N_Type_Conversion then
5184 Save_Interps (Right_Opnd (N), Expression (Arg2));
5185 else
5186 Save_Interps (Right_Opnd (N), Arg2);
5187 end if;
5189 Rewrite (Left_Opnd (N), Arg1);
5190 Rewrite (Right_Opnd (N), Arg2);
5191 Analyze (Arg1);
5192 Analyze (Arg2);
5193 Resolve_Arithmetic_Op (N, Typ);
5195 else
5196 Resolve_Arithmetic_Op (N, Typ);
5197 end if;
5198 end Resolve_Intrinsic_Operator;
5200 --------------------------------------
5201 -- Resolve_Intrinsic_Unary_Operator --
5202 --------------------------------------
5204 procedure Resolve_Intrinsic_Unary_Operator
5205 (N : Node_Id;
5206 Typ : Entity_Id)
5207 is
5208 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
5209 Op : Entity_Id;
5210 Arg2 : Node_Id;
5212 begin
5213 Op := Entity (N);
5214 while Scope (Op) /= Standard_Standard loop
5215 Op := Homonym (Op);
5216 pragma Assert (Present (Op));
5217 end loop;
5219 Set_Entity (N, Op);
5221 if Is_Private_Type (Typ) then
5222 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
5223 Save_Interps (Right_Opnd (N), Expression (Arg2));
5225 Set_Right_Opnd (N, Arg2);
5227 Set_Etype (N, Btyp);
5228 Rewrite (N, Unchecked_Convert_To (Typ, N));
5229 Resolve (N, Typ);
5231 else
5232 Resolve_Unary_Op (N, Typ);
5233 end if;
5234 end Resolve_Intrinsic_Unary_Operator;
5236 ------------------------
5237 -- Resolve_Logical_Op --
5238 ------------------------
5240 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
5241 B_Typ : Entity_Id;
5243 begin
5244 -- Predefined operations on scalar types yield the base type. On the
5245 -- other hand, logical operations on arrays yield the type of the
5246 -- arguments (and the context).
5248 if Is_Array_Type (Typ) then
5249 B_Typ := Typ;
5250 else
5251 B_Typ := Base_Type (Typ);
5252 end if;
5254 -- The following test is required because the operands of the operation
5255 -- may be literals, in which case the resulting type appears to be
5256 -- compatible with a signed integer type, when in fact it is compatible
5257 -- only with modular types. If the context itself is universal, the
5258 -- operation is illegal.
5260 if not Valid_Boolean_Arg (Typ) then
5261 Error_Msg_N ("invalid context for logical operation", N);
5262 Set_Etype (N, Any_Type);
5263 return;
5265 elsif Typ = Any_Modular then
5266 Error_Msg_N
5267 ("no modular type available in this context", N);
5268 Set_Etype (N, Any_Type);
5269 return;
5270 elsif Is_Modular_Integer_Type (Typ)
5271 and then Etype (Left_Opnd (N)) = Universal_Integer
5272 and then Etype (Right_Opnd (N)) = Universal_Integer
5273 then
5274 Check_For_Visible_Operator (N, B_Typ);
5275 end if;
5277 Resolve (Left_Opnd (N), B_Typ);
5278 Resolve (Right_Opnd (N), B_Typ);
5280 Check_Unset_Reference (Left_Opnd (N));
5281 Check_Unset_Reference (Right_Opnd (N));
5283 Set_Etype (N, B_Typ);
5284 Generate_Operator_Reference (N, B_Typ);
5285 Eval_Logical_Op (N);
5286 Check_Direct_Boolean_Op (N);
5287 end Resolve_Logical_Op;
5289 ---------------------------
5290 -- Resolve_Membership_Op --
5291 ---------------------------
5293 -- The context can only be a boolean type, and does not determine
5294 -- the arguments. Arguments should be unambiguous, but the preference
5295 -- rule for universal types applies.
5297 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
5298 pragma Warnings (Off, Typ);
5300 L : constant Node_Id := Left_Opnd (N);
5301 R : constant Node_Id := Right_Opnd (N);
5302 T : Entity_Id;
5304 begin
5305 if L = Error or else R = Error then
5306 return;
5307 end if;
5309 if not Is_Overloaded (R)
5310 and then
5311 (Etype (R) = Universal_Integer or else
5312 Etype (R) = Universal_Real)
5313 and then Is_Overloaded (L)
5314 then
5315 T := Etype (R);
5317 -- Ada 2005 (AI-251): Give support to the following case:
5319 -- type I is interface;
5320 -- type T is tagged ...
5322 -- function Test (O : in I'Class) is
5323 -- begin
5324 -- return O in T'Class.
5325 -- end Test;
5327 -- In this case we have nothing else to do; the membership test will be
5328 -- done at run-time.
5330 elsif Ada_Version >= Ada_05
5331 and then Is_Class_Wide_Type (Etype (L))
5332 and then Is_Interface (Etype (L))
5333 and then Is_Class_Wide_Type (Etype (R))
5334 and then not Is_Interface (Etype (R))
5335 then
5336 return;
5338 else
5339 T := Intersect_Types (L, R);
5340 end if;
5342 Resolve (L, T);
5343 Check_Unset_Reference (L);
5345 if Nkind (R) = N_Range
5346 and then not Is_Scalar_Type (T)
5347 then
5348 Error_Msg_N ("scalar type required for range", R);
5349 end if;
5351 if Is_Entity_Name (R) then
5352 Freeze_Expression (R);
5353 else
5354 Resolve (R, T);
5355 Check_Unset_Reference (R);
5356 end if;
5358 Eval_Membership_Op (N);
5359 end Resolve_Membership_Op;
5361 ------------------
5362 -- Resolve_Null --
5363 ------------------
5365 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
5366 begin
5367 -- Handle restriction against anonymous null access values This
5368 -- restriction can be turned off using -gnatdh.
5370 -- Ada 2005 (AI-231): Remove restriction
5372 if Ada_Version < Ada_05
5373 and then not Debug_Flag_J
5374 and then Ekind (Typ) = E_Anonymous_Access_Type
5375 and then Comes_From_Source (N)
5376 then
5377 -- In the common case of a call which uses an explicitly null
5378 -- value for an access parameter, give specialized error msg
5380 if Nkind (Parent (N)) = N_Procedure_Call_Statement
5381 or else
5382 Nkind (Parent (N)) = N_Function_Call
5383 then
5384 Error_Msg_N
5385 ("null is not allowed as argument for an access parameter", N);
5387 -- Standard message for all other cases (are there any?)
5389 else
5390 Error_Msg_N
5391 ("null cannot be of an anonymous access type", N);
5392 end if;
5393 end if;
5395 -- In a distributed context, null for a remote access to subprogram
5396 -- may need to be replaced with a special record aggregate. In this
5397 -- case, return after having done the transformation.
5399 if (Ekind (Typ) = E_Record_Type
5400 or else Is_Remote_Access_To_Subprogram_Type (Typ))
5401 and then Remote_AST_Null_Value (N, Typ)
5402 then
5403 return;
5404 end if;
5406 -- The null literal takes its type from the context
5408 Set_Etype (N, Typ);
5409 end Resolve_Null;
5411 -----------------------
5412 -- Resolve_Op_Concat --
5413 -----------------------
5415 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
5416 Btyp : constant Entity_Id := Base_Type (Typ);
5417 Op1 : constant Node_Id := Left_Opnd (N);
5418 Op2 : constant Node_Id := Right_Opnd (N);
5420 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
5421 -- Internal procedure to resolve one operand of concatenation operator.
5422 -- The operand is either of the array type or of the component type.
5423 -- If the operand is an aggregate, and the component type is composite,
5424 -- this is ambiguous if component type has aggregates.
5426 -------------------------------
5427 -- Resolve_Concatenation_Arg --
5428 -------------------------------
5430 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
5431 begin
5432 if In_Instance then
5433 if Is_Comp
5434 or else (not Is_Overloaded (Arg)
5435 and then Etype (Arg) /= Any_Composite
5436 and then Covers (Component_Type (Typ), Etype (Arg)))
5437 then
5438 Resolve (Arg, Component_Type (Typ));
5439 else
5440 Resolve (Arg, Btyp);
5441 end if;
5443 elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
5445 if Nkind (Arg) = N_Aggregate
5446 and then Is_Composite_Type (Component_Type (Typ))
5447 then
5448 if Is_Private_Type (Component_Type (Typ)) then
5449 Resolve (Arg, Btyp);
5451 else
5452 Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
5453 Set_Etype (Arg, Any_Type);
5454 end if;
5456 else
5457 if Is_Overloaded (Arg)
5458 and then Has_Compatible_Type (Arg, Typ)
5459 and then Etype (Arg) /= Any_Type
5460 then
5462 declare
5463 I : Interp_Index;
5464 It : Interp;
5465 Func : Entity_Id;
5467 begin
5468 Get_First_Interp (Arg, I, It);
5469 Func := It.Nam;
5470 Get_Next_Interp (I, It);
5472 -- Special-case the error message when the overloading
5473 -- is caused by a function that yields and array and
5474 -- can be called without parameters.
5476 if It.Nam = Func then
5477 Error_Msg_Sloc := Sloc (Func);
5479 Error_Msg_NE
5481 Error_Msg_NE
5483 Arg, Component_Type (Typ));
5485 else
5486 Error_Msg_N ("ambiguous operand for concatenation!",
5487 Arg);
5488 Get_First_Interp (Arg, I, It);
5489 while Present (It.Nam) loop
5490 Error_Msg_Sloc := Sloc (It.Nam);
5492 if Base_Type (It.Typ) = Base_Type (Typ)
5493 or else Base_Type (It.Typ) =
5494 Base_Type (Component_Type (Typ))
5495 then
5497 end if;
5499 Get_Next_Interp (I, It);
5500 end loop;
5501 end if;
5502 end;
5503 end if;
5505 Resolve (Arg, Component_Type (Typ));
5507 if Nkind (Arg) = N_String_Literal then
5508 Set_Etype (Arg, Component_Type (Typ));
5509 end if;
5511 if Arg = Left_Opnd (N) then
5512 Set_Is_Component_Left_Opnd (N);
5513 else
5514 Set_Is_Component_Right_Opnd (N);
5515 end if;
5516 end if;
5518 else
5519 Resolve (Arg, Btyp);
5520 end if;
5522 Check_Unset_Reference (Arg);
5523 end Resolve_Concatenation_Arg;
5525 -- Start of processing for Resolve_Op_Concat
5527 begin
5528 Set_Etype (N, Btyp);
5530 if Is_Limited_Composite (Btyp) then
5531 Error_Msg_N ("concatenation not available for limited array", N);
5532 Explain_Limited_Type (Btyp, N);
5533 end if;
5535 -- If the operands are themselves concatenations, resolve them as such
5536 -- directly. This removes several layers of recursion and allows GNAT to
5537 -- handle larger multiple concatenations.
5539 if Nkind (Op1) = N_Op_Concat
5540 and then not Is_Array_Type (Component_Type (Typ))
5541 and then Entity (Op1) = Entity (N)
5542 then
5543 Resolve_Op_Concat (Op1, Typ);
5544 else
5545 Resolve_Concatenation_Arg
5546 (Op1, Is_Component_Left_Opnd (N));
5547 end if;
5549 if Nkind (Op2) = N_Op_Concat
5550 and then not Is_Array_Type (Component_Type (Typ))
5551 and then Entity (Op2) = Entity (N)
5552 then
5553 Resolve_Op_Concat (Op2, Typ);
5554 else
5555 Resolve_Concatenation_Arg
5556 (Op2, Is_Component_Right_Opnd (N));
5557 end if;
5559 Generate_Operator_Reference (N, Typ);
5561 if Is_String_Type (Typ) then
5562 Eval_Concatenation (N);
5563 end if;
5565 -- If this is not a static concatenation, but the result is a
5566 -- string type (and not an array of strings) insure that static
5567 -- string operands have their subtypes properly constructed.
5569 if Nkind (N) /= N_String_Literal
5570 and then Is_Character_Type (Component_Type (Typ))
5571 then
5572 Set_String_Literal_Subtype (Op1, Typ);
5573 Set_String_Literal_Subtype (Op2, Typ);
5574 end if;
5575 end Resolve_Op_Concat;
5577 ----------------------
5578 -- Resolve_Op_Expon --
5579 ----------------------
5581 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
5582 B_Typ : constant Entity_Id := Base_Type (Typ);
5584 begin
5585 -- Catch attempts to do fixed-point exponentation with universal
5586 -- operands, which is a case where the illegality is not caught during
5587 -- normal operator analysis.
5589 if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
5590 Error_Msg_N ("exponentiation not available for fixed point", N);
5591 return;
5592 end if;
5594 if Comes_From_Source (N)
5595 and then Ekind (Entity (N)) = E_Function
5596 and then Is_Imported (Entity (N))
5597 and then Is_Intrinsic_Subprogram (Entity (N))
5598 then
5599 Resolve_Intrinsic_Operator (N, Typ);
5600 return;
5601 end if;
5603 if Etype (Left_Opnd (N)) = Universal_Integer
5604 or else Etype (Left_Opnd (N)) = Universal_Real
5605 then
5606 Check_For_Visible_Operator (N, B_Typ);
5607 end if;
5609 -- We do the resolution using the base type, because intermediate values
5610 -- in expressions always are of the base type, not a subtype of it.
5612 Resolve (Left_Opnd (N), B_Typ);
5613 Resolve (Right_Opnd (N), Standard_Integer);
5615 Check_Unset_Reference (Left_Opnd (N));
5616 Check_Unset_Reference (Right_Opnd (N));
5618 Set_Etype (N, B_Typ);
5619 Generate_Operator_Reference (N, B_Typ);
5620 Eval_Op_Expon (N);
5622 -- Set overflow checking bit. Much cleverer code needed here eventually
5623 -- and perhaps the Resolve routines should be separated for the various
5624 -- arithmetic operations, since they will need different processing. ???
5626 if Nkind (N) in N_Op then
5627 if not Overflow_Checks_Suppressed (Etype (N)) then
5628 Enable_Overflow_Check (N);
5629 end if;
5630 end if;
5631 end Resolve_Op_Expon;
5633 --------------------
5634 -- Resolve_Op_Not --
5635 --------------------
5637 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
5638 B_Typ : Entity_Id;
5640 function Parent_Is_Boolean return Boolean;
5641 -- This function determines if the parent node is a boolean operator
5642 -- or operation (comparison op, membership test, or short circuit form)
5643 -- and the not in question is the left operand of this operation.
5644 -- Note that if the not is in parens, then false is returned.
5646 function Parent_Is_Boolean return Boolean is
5647 begin
5648 if Paren_Count (N) /= 0 then
5649 return False;
5651 else
5652 case Nkind (Parent (N)) is
5653 when N_Op_And |
5654 N_Op_Eq |
5655 N_Op_Ge |
5656 N_Op_Gt |
5657 N_Op_Le |
5658 N_Op_Lt |
5659 N_Op_Ne |
5660 N_Op_Or |
5661 N_Op_Xor |
5662 N_In |
5663 N_Not_In |
5664 N_And_Then |
5665 N_Or_Else =>
5667 return Left_Opnd (Parent (N)) = N;
5669 when others =>
5670 return False;
5671 end case;
5672 end if;
5673 end Parent_Is_Boolean;
5675 -- Start of processing for Resolve_Op_Not
5677 begin
5678 -- Predefined operations on scalar types yield the base type. On the
5679 -- other hand, logical operations on arrays yield the type of the
5680 -- arguments (and the context).
5682 if Is_Array_Type (Typ) then
5683 B_Typ := Typ;
5684 else
5685 B_Typ := Base_Type (Typ);
5686 end if;
5688 if not Valid_Boolean_Arg (Typ) then
5689 Error_Msg_N ("invalid operand type for operator&", N);
5690 Set_Etype (N, Any_Type);
5691 return;
5693 elsif Typ = Universal_Integer or else Typ = Any_Modular then
5694 if Parent_Is_Boolean then
5695 Error_Msg_N
5696 ("operand of not must be enclosed in parentheses",
5697 Right_Opnd (N));
5698 else
5699 Error_Msg_N
5700 ("no modular type available in this context", N);
5701 end if;
5703 Set_Etype (N, Any_Type);
5704 return;
5706 else
5707 if not Is_Boolean_Type (Typ)
5708 and then Parent_Is_Boolean
5709 then
5710 Error_Msg_N ("?not expression should be parenthesized here", N);
5711 end if;
5713 Resolve (Right_Opnd (N), B_Typ);
5714 Check_Unset_Reference (Right_Opnd (N));
5715 Set_Etype (N, B_Typ);
5716 Generate_Operator_Reference (N, B_Typ);
5717 Eval_Op_Not (N);
5718 end if;
5719 end Resolve_Op_Not;
5721 -----------------------------
5722 -- Resolve_Operator_Symbol --
5723 -----------------------------
5725 -- Nothing to be done, all resolved already
5727 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
5728 pragma Warnings (Off, N);
5729 pragma Warnings (Off, Typ);
5731 begin
5732 null;
5733 end Resolve_Operator_Symbol;
5735 ----------------------------------
5736 -- Resolve_Qualified_Expression --
5737 ----------------------------------
5739 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
5740 pragma Warnings (Off, Typ);
5742 Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
5743 Expr : constant Node_Id := Expression (N);
5745 begin
5746 Resolve (Expr, Target_Typ);
5748 -- A qualified expression requires an exact match of the type,
5749 -- class-wide matching is not allowed. However, if the qualifying
5750 -- type is specific and the expression has a class-wide type, it
5751 -- may still be okay, since it can be the result of the expansion
5752 -- of a call to a dispatching function, so we also have to check
5753 -- class-wideness of the type of the expression's original node.
5755 if (Is_Class_Wide_Type (Target_Typ)
5756 or else
5757 (Is_Class_Wide_Type (Etype (Expr))
5758 and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
5759 and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
5760 then
5761 Wrong_Type (Expr, Target_Typ);
5762 end if;
5764 -- If the target type is unconstrained, then we reset the type of
5765 -- the result from the type of the expression. For other cases, the
5766 -- actual subtype of the expression is the target type.
5768 if Is_Composite_Type (Target_Typ)
5769 and then not Is_Constrained (Target_Typ)
5770 then
5771 Set_Etype (N, Etype (Expr));
5772 end if;
5774 Eval_Qualified_Expression (N);
5775 end Resolve_Qualified_Expression;
5777 -------------------
5778 -- Resolve_Range --
5779 -------------------
5781 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
5782 L : constant Node_Id := Low_Bound (N);
5783 H : constant Node_Id := High_Bound (N);
5785 begin
5786 Set_Etype (N, Typ);
5787 Resolve (L, Typ);
5788 Resolve (H, Typ);
5790 Check_Unset_Reference (L);
5791 Check_Unset_Reference (H);
5793 -- We have to check the bounds for being within the base range as
5794 -- required for a non-static context. Normally this is automatic and
5795 -- done as part of evaluating expressions, but the N_Range node is an
5796 -- exception, since in GNAT we consider this node to be a subexpression,
5797 -- even though in Ada it is not. The circuit in Sem_Eval could check for
5798 -- this, but that would put the test on the main evaluation path for
5799 -- expressions.
5801 Check_Non_Static_Context (L);
5802 Check_Non_Static_Context (H);
5804 -- If bounds are static, constant-fold them, so size computations
5805 -- are identical between front-end and back-end. Do not perform this
5806 -- transformation while analyzing generic units, as type information
5807 -- would then be lost when reanalyzing the constant node in the
5808 -- instance.
5810 if Is_Discrete_Type (Typ) and then Expander_Active then
5811 if Is_OK_Static_Expression (L) then
5812 Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
5813 end if;
5815 if Is_OK_Static_Expression (H) then
5816 Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H));
5817 end if;
5818 end if;
5819 end Resolve_Range;
5821 --------------------------
5822 -- Resolve_Real_Literal --
5823 --------------------------
5825 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
5826 Actual_Typ : constant Entity_Id := Etype (N);
5828 begin
5829 -- Special processing for fixed-point literals to make sure that the
5830 -- value is an exact multiple of small where this is required. We
5831 -- skip this for the universal real case, and also for generic types.
5833 if Is_Fixed_Point_Type (Typ)
5834 and then Typ /= Universal_Fixed
5835 and then Typ /= Any_Fixed
5836 and then not Is_Generic_Type (Typ)
5837 then
5838 declare
5839 Val : constant Ureal := Realval (N);
5840 Cintr : constant Ureal := Val / Small_Value (Typ);
5841 Cint : constant Uint := UR_Trunc (Cintr);
5842 Den : constant Uint := Norm_Den (Cintr);
5843 Stat : Boolean;
5845 begin
5846 -- Case of literal is not an exact multiple of the Small
5848 if Den /= 1 then
5850 -- For a source program literal for a decimal fixed-point
5851 -- type, this is statically illegal (RM 4.9(36)).
5853 if Is_Decimal_Fixed_Point_Type (Typ)
5854 and then Actual_Typ = Universal_Real
5855 and then Comes_From_Source (N)
5856 then
5857 Error_Msg_N ("value has extraneous low order digits", N);
5858 end if;
5860 -- Generate a warning if literal from source
5862 if Is_Static_Expression (N)
5863 and then Warn_On_Bad_Fixed_Value
5864 then
5865 Error_Msg_N
5866 ("static fixed-point value is not a multiple of Small?",
5867 N);
5868 end if;
5870 -- Replace literal by a value that is the exact representation
5871 -- of a value of the type, i.e. a multiple of the small value,
5872 -- by truncation, since Machine_Rounds is false for all GNAT
5873 -- fixed-point types (RM 4.9(38)).
5875 Stat := Is_Static_Expression (N);
5876 Rewrite (N,
5877 Make_Real_Literal (Sloc (N),
5878 Realval => Small_Value (Typ) * Cint));
5880 Set_Is_Static_Expression (N, Stat);
5881 end if;
5883 -- In all cases, set the corresponding integer field
5885 Set_Corresponding_Integer_Value (N, Cint);
5886 end;
5887 end if;
5889 -- Now replace the actual type by the expected type as usual
5891 Set_Etype (N, Typ);
5892 Eval_Real_Literal (N);
5893 end Resolve_Real_Literal;
5895 -----------------------
5896 -- Resolve_Reference --
5897 -----------------------
5899 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
5900 P : constant Node_Id := Prefix (N);
5902 begin
5903 -- Replace general access with specific type
5905 if Ekind (Etype (N)) = E_Allocator_Type then
5906 Set_Etype (N, Base_Type (Typ));
5907 end if;
5909 Resolve (P, Designated_Type (Etype (N)));
5911 -- If we are taking the reference of a volatile entity, then treat
5912 -- it as a potential modification of this entity. This is much too
5913 -- conservative, but is necessary because remove side effects can
5914 -- result in transformations of normal assignments into reference
5915 -- sequences that otherwise fail to notice the modification.
5917 if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
5918 Note_Possible_Modification (P);
5919 end if;
5920 end Resolve_Reference;
5922 --------------------------------
5923 -- Resolve_Selected_Component --
5924 --------------------------------
5926 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
5927 Comp : Entity_Id;
5928 Comp1 : Entity_Id := Empty; -- prevent junk warning
5929 P : constant Node_Id := Prefix (N);
5930 S : constant Node_Id := Selector_Name (N);
5931 T : Entity_Id := Etype (P);
5932 I : Interp_Index;
5933 I1 : Interp_Index := 0; -- prevent junk warning
5934 It : Interp;
5935 It1 : Interp;
5936 Found : Boolean;
5938 function Init_Component return Boolean;
5939 -- Check whether this is the initialization of a component within an
5940 -- init proc (by assignment or call to another init proc). If true,
5941 -- there is no need for a discriminant check.
5943 --------------------
5944 -- Init_Component --
5945 --------------------
5947 function Init_Component return Boolean is
5948 begin
5949 return Inside_Init_Proc
5950 and then Nkind (Prefix (N)) = N_Identifier
5951 and then Chars (Prefix (N)) = Name_uInit
5952 and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
5953 end Init_Component;
5955 -- Start of processing for Resolve_Selected_Component
5957 begin
5958 if Is_Overloaded (P) then
5960 -- Use the context type to select the prefix that has a selector
5961 -- of the correct name and type.
5963 Found := False;
5964 Get_First_Interp (P, I, It);
5966 Search : while Present (It.Typ) loop
5967 if Is_Access_Type (It.Typ) then
5968 T := Designated_Type (It.Typ);
5969 else
5970 T := It.Typ;
5971 end if;
5973 if Is_Record_Type (T) then
5974 Comp := First_Entity (T);
5975 while Present (Comp) loop
5976 if Chars (Comp) = Chars (S)
5977 and then Covers (Etype (Comp), Typ)
5978 then
5979 if not Found then
5980 Found := True;
5981 I1 := I;
5982 It1 := It;
5983 Comp1 := Comp;
5985 else
5986 It := Disambiguate (P, I1, I, Any_Type);
5988 if It = No_Interp then
5989 Error_Msg_N
5990 ("ambiguous prefix for selected component", N);
5991 Set_Etype (N, Typ);
5992 return;
5994 else
5995 It1 := It;
5997 if Scope (Comp1) /= It1.Typ then
5999 -- Resolution chooses the new interpretation.
6000 -- Find the component with the right name.
6002 Comp1 := First_Entity (It1.Typ);
6003 while Present (Comp1)
6004 and then Chars (Comp1) /= Chars (S)
6005 loop
6006 Comp1 := Next_Entity (Comp1);
6007 end loop;
6008 end if;
6010 exit Search;
6011 end if;
6012 end if;
6013 end if;
6015 Comp := Next_Entity (Comp);
6016 end loop;
6018 end if;
6020 Get_Next_Interp (I, It);
6021 end loop Search;
6023 Resolve (P, It1.Typ);
6024 Set_Etype (N, Typ);
6025 Set_Entity (S, Comp1);
6027 else
6028 -- Resolve prefix with its type
6030 Resolve (P, T);
6031 end if;
6033 -- If prefix is an access type, the node will be transformed into
6034 -- an explicit dereference during expansion. The type of the node
6035 -- is the designated type of that of the prefix.
6037 if Is_Access_Type (Etype (P)) then
6038 T := Designated_Type (Etype (P));
6039 else
6040 T := Etype (P);
6041 end if;
6043 if Has_Discriminants (T)
6044 and then (Ekind (Entity (S)) = E_Component
6045 or else
6046 Ekind (Entity (S)) = E_Discriminant)
6047 and then Present (Original_Record_Component (Entity (S)))
6048 and then Ekind (Original_Record_Component (Entity (S))) = E_Component
6049 and then Present (Discriminant_Checking_Func
6050 (Original_Record_Component (Entity (S))))
6051 and then not Discriminant_Checks_Suppressed (T)
6052 and then not Init_Component
6053 then
6054 Set_Do_Discriminant_Check (N);
6055 end if;
6057 if Ekind (Entity (S)) = E_Void then
6058 Error_Msg_N ("premature use of component", S);
6059 end if;
6061 -- If the prefix is a record conversion, this may be a renamed
6062 -- discriminant whose bounds differ from those of the original
6063 -- one, so we must ensure that a range check is performed.
6065 if Nkind (P) = N_Type_Conversion
6066 and then Ekind (Entity (S)) = E_Discriminant
6067 and then Is_Discrete_Type (Typ)
6068 then
6069 Set_Etype (N, Base_Type (Typ));
6070 end if;
6072 -- Note: No Eval processing is required, because the prefix is of a
6073 -- record type, or protected type, and neither can possibly be static.
6075 end Resolve_Selected_Component;
6077 -------------------
6078 -- Resolve_Shift --
6079 -------------------
6081 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
6082 B_Typ : constant Entity_Id := Base_Type (Typ);
6083 L : constant Node_Id := Left_Opnd (N);
6084 R : constant Node_Id := Right_Opnd (N);
6086 begin
6087 -- We do the resolution using the base type, because intermediate values
6088 -- in expressions always are of the base type, not a subtype of it.
6090 Resolve (L, B_Typ);
6091 Resolve (R, Standard_Natural);
6093 Check_Unset_Reference (L);
6094 Check_Unset_Reference (R);
6096 Set_Etype (N, B_Typ);
6097 Generate_Operator_Reference (N, B_Typ);
6098 Eval_Shift (N);
6099 end Resolve_Shift;
6101 ---------------------------
6102 -- Resolve_Short_Circuit --
6103 ---------------------------
6105 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
6106 B_Typ : constant Entity_Id := Base_Type (Typ);
6107 L : constant Node_Id := Left_Opnd (N);
6108 R : constant Node_Id := Right_Opnd (N);
6110 begin
6111 Resolve (L, B_Typ);
6112 Resolve (R, B_Typ);
6114 Check_Unset_Reference (L);
6115 Check_Unset_Reference (R);
6117 Set_Etype (N, B_Typ);
6118 Eval_Short_Circuit (N);
6119 end Resolve_Short_Circuit;
6121 -------------------
6122 -- Resolve_Slice --
6123 -------------------
6125 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
6126 Name : constant Node_Id := Prefix (N);
6127 Drange : constant Node_Id := Discrete_Range (N);
6128 Array_Type : Entity_Id := Empty;
6129 Index : Node_Id;
6131 begin
6132 if Is_Overloaded (Name) then
6134 -- Use the context type to select the prefix that yields the
6135 -- correct array type.
6137 declare
6138 I : Interp_Index;
6139 I1 : Interp_Index := 0;
6140 It : Interp;
6141 P : constant Node_Id := Prefix (N);
6142 Found : Boolean := False;
6144 begin
6145 Get_First_Interp (P, I, It);
6146 while Present (It.Typ) loop
6147 if (Is_Array_Type (It.Typ)
6148 and then Covers (Typ, It.Typ))
6149 or else (Is_Access_Type (It.Typ)
6150 and then Is_Array_Type (Designated_Type (It.Typ))
6151 and then Covers (Typ, Designated_Type (It.Typ)))
6152 then
6153 if Found then
6154 It := Disambiguate (P, I1, I, Any_Type);
6156 if It = No_Interp then
6157 Error_Msg_N ("ambiguous prefix for slicing", N);
6158 Set_Etype (N, Typ);
6159 return;
6160 else
6161 Found := True;
6162 Array_Type := It.Typ;
6163 I1 := I;
6164 end if;
6165 else
6166 Found := True;
6167 Array_Type := It.Typ;
6168 I1 := I;
6169 end if;
6170 end if;
6172 Get_Next_Interp (I, It);
6173 end loop;
6174 end;
6176 else
6177 Array_Type := Etype (Name);
6178 end if;
6180 Resolve (Name, Array_Type);
6182 if Is_Access_Type (Array_Type) then
6183 Apply_Access_Check (N);
6184 Array_Type := Designated_Type (Array_Type);
6186 -- If the prefix is an access to an unconstrained array, we must
6187 -- use the actual subtype of the object to perform the index checks.
6188 -- The object denoted by the prefix is implicit in the node, so we
6189 -- build an explicit representation for it in order to compute the
6190 -- actual subtype.
6192 if not Is_Constrained (Array_Type) then
6193 Remove_Side_Effects (Prefix (N));
6195 declare
6196 Obj : constant Node_Id :=
6197 Make_Explicit_Dereference (Sloc (N),
6198 Prefix => New_Copy_Tree (Prefix (N)));
6199 begin
6200 Set_Etype (Obj, Array_Type);
6201 Set_Parent (Obj, Parent (N));
6202 Array_Type := Get_Actual_Subtype (Obj);
6203 end;
6204 end if;
6206 elsif Is_Entity_Name (Name)
6207 or else (Nkind (Name) = N_Function_Call
6208 and then not Is_Constrained (Etype (Name)))
6209 then
6210 Array_Type := Get_Actual_Subtype (Name);
6211 end if;
6213 -- If name was overloaded, set slice type correctly now
6215 Set_Etype (N, Array_Type);
6217 -- If the range is specified by a subtype mark, no resolution
6218 -- is necessary. Else resolve the bounds, and apply needed checks.
6220 if not Is_Entity_Name (Drange) then
6221 Index := First_Index (Array_Type);
6222 Resolve (Drange, Base_Type (Etype (Index)));
6224 if Nkind (Drange) = N_Range then
6225 Apply_Range_Check (Drange, Etype (Index));
6226 end if;
6227 end if;
6229 Set_Slice_Subtype (N);
6230 Eval_Slice (N);
6231 end Resolve_Slice;
6233 ----------------------------
6234 -- Resolve_String_Literal --
6235 ----------------------------
6237 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
6238 C_Typ : constant Entity_Id := Component_Type (Typ);
6239 R_Typ : constant Entity_Id := Root_Type (C_Typ);
6240 Loc : constant Source_Ptr := Sloc (N);
6241 Str : constant String_Id := Strval (N);
6242 Strlen : constant Nat := String_Length (Str);
6243 Subtype_Id : Entity_Id;
6244 Need_Check : Boolean;
6246 begin
6247 -- For a string appearing in a concatenation, defer creation of the
6248 -- string_literal_subtype until the end of the resolution of the
6249 -- concatenation, because the literal may be constant-folded away.
6250 -- This is a useful optimization for long concatenation expressions.
6252 -- If the string is an aggregate built for a single character (which
6253 -- happens in a non-static context) or a is null string to which special
6254 -- checks may apply, we build the subtype. Wide strings must also get
6255 -- a string subtype if they come from a one character aggregate. Strings
6256 -- generated by attributes might be static, but it is often hard to
6257 -- determine whether the enclosing context is static, so we generate
6258 -- subtypes for them as well, thus losing some rarer optimizations ???
6259 -- Same for strings that come from a static conversion.
6261 Need_Check :=
6262 (Strlen = 0 and then Typ /= Standard_String)
6263 or else Nkind (Parent (N)) /= N_Op_Concat
6264 or else (N /= Left_Opnd (Parent (N))
6265 and then N /= Right_Opnd (Parent (N)))
6266 or else ((Typ = Standard_Wide_String
6267 or else Typ = Standard_Wide_Wide_String)
6268 and then Nkind (Original_Node (N)) /= N_String_Literal);
6270 -- If the resolving type is itself a string literal subtype, we
6271 -- can just reuse it, since there is no point in creating another.
6273 if Ekind (Typ) = E_String_Literal_Subtype then
6274 Subtype_Id := Typ;
6276 elsif Nkind (Parent (N)) = N_Op_Concat
6277 and then not Need_Check
6278 and then Nkind (Original_Node (N)) /= N_Character_Literal
6279 and then Nkind (Original_Node (N)) /= N_Attribute_Reference
6280 and then Nkind (Original_Node (N)) /= N_Qualified_Expression
6281 and then Nkind (Original_Node (N)) /= N_Type_Conversion
6282 then
6283 Subtype_Id := Typ;
6285 -- Otherwise we must create a string literal subtype. Note that the
6286 -- whole idea of string literal subtypes is simply to avoid the need
6287 -- for building a full fledged array subtype for each literal.
6288 else
6289 Set_String_Literal_Subtype (N, Typ);
6290 Subtype_Id := Etype (N);
6291 end if;
6293 if Nkind (Parent (N)) /= N_Op_Concat
6294 or else Need_Check
6295 then
6296 Set_Etype (N, Subtype_Id);
6297 Eval_String_Literal (N);
6298 end if;
6300 if Is_Limited_Composite (Typ)
6301 or else Is_Private_Composite (Typ)
6302 then
6303 Error_Msg_N ("string literal not available for private array", N);
6304 Set_Etype (N, Any_Type);
6305 return;
6306 end if;
6308 -- The validity of a null string has been checked in the
6309 -- call to Eval_String_Literal.
6311 if Strlen = 0 then
6312 return;
6314 -- Always accept string literal with component type Any_Character,
6315 -- which occurs in error situations and in comparisons of literals,
6316 -- both of which should accept all literals.
6318 elsif R_Typ = Any_Character then
6319 return;
6321 -- If the type is bit-packed, then we always tranform the string
6322 -- literal into a full fledged aggregate.
6324 elsif Is_Bit_Packed_Array (Typ) then
6325 null;
6327 -- Deal with cases of Wide_Wide_String, Wide_String, and String
6329 else
6330 -- For Standard.Wide_Wide_String, or any other type whose component
6331 -- type is Standard.Wide_Wide_Character, we know that all the
6332 -- characters in the string must be acceptable, since the parser
6333 -- accepted the characters as valid character literals.
6335 if R_Typ = Standard_Wide_Wide_Character then
6336 null;
6338 -- For the case of Standard.String, or any other type whose
6339 -- component type is Standard.Character, we must make sure that
6340 -- there are no wide characters in the string, i.e. that it is
6341 -- entirely composed of characters in range of type Character.
6343 -- If the string literal is the result of a static concatenation,
6344 -- the test has already been performed on the components, and need
6345 -- not be repeated.
6347 elsif R_Typ = Standard_Character
6348 and then Nkind (Original_Node (N)) /= N_Op_Concat
6349 then
6350 for J in 1 .. Strlen loop
6351 if not In_Character_Range (Get_String_Char (Str, J)) then
6353 -- If we are out of range, post error. This is one of the
6354 -- very few places that we place the flag in the middle of
6355 -- a token, right under the offending wide character.
6357 Error_Msg
6358 ("literal out of range of type Standard.Character",
6359 Source_Ptr (Int (Loc) + J));
6360 return;
6361 end if;
6362 end loop;
6364 -- For the case of Standard.Wide_String, or any other type whose
6365 -- component type is Standard.Wide_Character, we must make sure that
6366 -- there are no wide characters in the string, i.e. that it is
6367 -- entirely composed of characters in range of type Wide_Character.
6369 -- If the string literal is the result of a static concatenation,
6370 -- the test has already been performed on the components, and need
6371 -- not be repeated.
6373 elsif R_Typ = Standard_Wide_Character
6374 and then Nkind (Original_Node (N)) /= N_Op_Concat
6375 then
6376 for J in 1 .. Strlen loop
6377 if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
6379 -- If we are out of range, post error. This is one of the
6380 -- very few places that we place the flag in the middle of
6381 -- a token, right under the offending wide character.
6383 -- This is not quite right, because characters in general
6384 -- will take more than one character position ???
6386 Error_Msg
6387 ("literal out of range of type Standard.Wide_Character",
6388 Source_Ptr (Int (Loc) + J));
6389 return;
6390 end if;
6391 end loop;
6393 -- If the root type is not a standard character, then we will convert
6394 -- the string into an aggregate and will let the aggregate code do
6395 -- the checking. Standard Wide_Wide_Character is also OK here.
6397 else
6398 null;
6399 end if;
6401 -- See if the component type of the array corresponding to the
6402 -- string has compile time known bounds. If yes we can directly
6403 -- check whether the evaluation of the string will raise constraint
6404 -- error. Otherwise we need to transform the string literal into
6405 -- the corresponding character aggregate and let the aggregate
6406 -- code do the checking.
6408 if R_Typ = Standard_Character
6409 or else R_Typ = Standard_Wide_Character
6410 or else R_Typ = Standard_Wide_Wide_Character
6411 then
6412 -- Check for the case of full range, where we are definitely OK
6414 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
6415 return;
6416 end if;
6418 -- Here the range is not the complete base type range, so check
6420 declare
6421 Comp_Typ_Lo : constant Node_Id :=
6422 Type_Low_Bound (Component_Type (Typ));
6423 Comp_Typ_Hi : constant Node_Id :=
6424 Type_High_Bound (Component_Type (Typ));
6426 Char_Val : Uint;
6428 begin
6429 if Compile_Time_Known_Value (Comp_Typ_Lo)
6430 and then Compile_Time_Known_Value (Comp_Typ_Hi)
6431 then
6432 for J in 1 .. Strlen loop
6433 Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
6435 if Char_Val < Expr_Value (Comp_Typ_Lo)
6436 or else Char_Val > Expr_Value (Comp_Typ_Hi)
6437 then
6438 Apply_Compile_Time_Constraint_Error
6439 (N, "character out of range?", CE_Range_Check_Failed,
6440 Loc => Source_Ptr (Int (Loc) + J));
6441 end if;
6442 end loop;
6444 return;
6445 end if;
6446 end;
6447 end if;
6448 end if;
6450 -- If we got here we meed to transform the string literal into the
6451 -- equivalent qualified positional array aggregate. This is rather
6452 -- heavy artillery for this situation, but it is hard work to avoid.
6454 declare
6455 Lits : constant List_Id := New_List;
6456 P : Source_Ptr := Loc + 1;
6457 C : Char_Code;
6459 begin
6460 -- Build the character literals, we give them source locations
6461 -- that correspond to the string positions, which is a bit tricky
6462 -- given the possible presence of wide character escape sequences.
6464 for J in 1 .. Strlen loop
6465 C := Get_String_Char (Str, J);
6466 Set_Character_Literal_Name (C);
6468 Append_To (Lits,
6469 Make_Character_Literal (P,
6470 Chars => Name_Find,
6471 Char_Literal_Value => UI_From_CC (C)));
6473 if In_Character_Range (C) then
6474 P := P + 1;
6476 -- Should we have a call to Skip_Wide here ???
6477 -- ??? else
6478 -- Skip_Wide (P);
6480 end if;
6481 end loop;
6483 Rewrite (N,
6484 Make_Qualified_Expression (Loc,
6485 Subtype_Mark => New_Reference_To (Typ, Loc),
6486 Expression =>
6487 Make_Aggregate (Loc, Expressions => Lits)));
6489 Analyze_And_Resolve (N, Typ);
6490 end;
6491 end Resolve_String_Literal;
6493 -----------------------------
6494 -- Resolve_Subprogram_Info --
6495 -----------------------------
6497 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
6498 begin
6499 Set_Etype (N, Typ);
6500 end Resolve_Subprogram_Info;
6502 -----------------------------
6503 -- Resolve_Type_Conversion --
6504 -----------------------------
6506 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
6507 Conv_OK : constant Boolean := Conversion_OK (N);
6508 Target_Type : Entity_Id := Etype (N);
6509 Operand : Node_Id;
6510 Opnd_Type : Entity_Id;
6511 Rop : Node_Id;
6512 Orig_N : Node_Id;
6513 Orig_T : Node_Id;
6515 begin
6516 Operand := Expression (N);
6518 if not Conv_OK
6519 and then not Valid_Conversion (N, Target_Type, Operand)
6520 then
6521 return;
6522 end if;
6524 if Etype (Operand) = Any_Fixed then
6526 -- Mixed-mode operation involving a literal. Context must be a fixed
6527 -- type which is applied to the literal subsequently.
6529 if Is_Fixed_Point_Type (Typ) then
6530 Set_Etype (Operand, Universal_Real);
6532 elsif Is_Numeric_Type (Typ)
6533 and then (Nkind (Operand) = N_Op_Multiply
6534 or else Nkind (Operand) = N_Op_Divide)
6535 and then (Etype (Right_Opnd (Operand)) = Universal_Real
6536 or else Etype (Left_Opnd (Operand)) = Universal_Real)
6537 then
6538 -- Return if expression is ambiguous
6540 if Unique_Fixed_Point_Type (N) = Any_Type then
6541 return;
6543 -- If nothing else, the available fixed type is Duration
6545 else
6546 Set_Etype (Operand, Standard_Duration);
6547 end if;
6549 -- Resolve the real operand with largest available precision
6551 if Etype (Right_Opnd (Operand)) = Universal_Real then
6552 Rop := New_Copy_Tree (Right_Opnd (Operand));
6553 else
6554 Rop := New_Copy_Tree (Left_Opnd (Operand));
6555 end if;
6557 Resolve (Rop, Universal_Real);
6559 -- If the operand is a literal (it could be a non-static and
6560 -- illegal exponentiation) check whether the use of Duration
6561 -- is potentially inaccurate.
6563 if Nkind (Rop) = N_Real_Literal
6564 and then Realval (Rop) /= Ureal_0
6565 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
6566 then
6567 Error_Msg_N ("universal real operand can only be interpreted?",
6568 Rop);
6570 end if;
6572 elsif Is_Numeric_Type (Typ)
6573 and then Nkind (Operand) in N_Op
6574 and then Unique_Fixed_Point_Type (N) /= Any_Type
6575 then
6576 Set_Etype (Operand, Standard_Duration);
6578 else
6579 Error_Msg_N ("invalid context for mixed mode operation", N);
6580 Set_Etype (Operand, Any_Type);
6581 return;
6582 end if;
6583 end if;
6585 Opnd_Type := Etype (Operand);
6586 Resolve (Operand);
6588 -- Note: we do the Eval_Type_Conversion call before applying the
6589 -- required checks for a subtype conversion. This is important,
6590 -- since both are prepared under certain circumstances to change
6591 -- the type conversion to a constraint error node, but in the case
6592 -- of Eval_Type_Conversion this may reflect an illegality in the
6593 -- static case, and we would miss the illegality (getting only a
6594 -- warning message), if we applied the type conversion checks first.
6596 Eval_Type_Conversion (N);
6598 -- If after evaluation, we still have a type conversion, then we
6599 -- may need to apply checks required for a subtype conversion.
6601 -- Skip these type conversion checks if universal fixed operands
6602 -- operands involved, since range checks are handled separately for
6603 -- these cases (in the appropriate Expand routines in unit Exp_Fixd).
6605 if Nkind (N) = N_Type_Conversion
6606 and then not Is_Generic_Type (Root_Type (Target_Type))
6607 and then Target_Type /= Universal_Fixed
6608 and then Opnd_Type /= Universal_Fixed
6609 then
6610 Apply_Type_Conversion_Checks (N);
6611 end if;
6613 -- Issue warning for conversion of simple object to its own type
6614 -- We have to test the original nodes, since they may have been
6615 -- rewritten by various optimizations.
6617 Orig_N := Original_Node (N);
6619 if Warn_On_Redundant_Constructs
6620 and then Comes_From_Source (Orig_N)
6621 and then Nkind (Orig_N) = N_Type_Conversion
6622 and then not In_Instance
6623 then
6624 Orig_N := Original_Node (Expression (Orig_N));
6625 Orig_T := Target_Type;
6627 -- If the node is part of a larger expression, the Target_Type
6628 -- may not be the original type of the node if the context is a
6629 -- condition. Recover original type to see if conversion is needed.
6631 if Is_Boolean_Type (Orig_T)
6632 and then Nkind (Parent (N)) in N_Op
6633 then
6634 Orig_T := Etype (Parent (N));
6635 end if;
6637 if Is_Entity_Name (Orig_N)
6638 and then Etype (Entity (Orig_N)) = Orig_T
6639 then
6640 Error_Msg_NE
6641 ("?useless conversion, & has this type", N, Entity (Orig_N));
6642 end if;
6643 end if;
6645 -- Ada 2005 (AI-251): Handle conversions to abstract interface types
6647 if Ada_Version >= Ada_05 then
6648 if Is_Access_Type (Target_Type) then
6649 Target_Type := Directly_Designated_Type (Target_Type);
6650 end if;
6652 if Is_Class_Wide_Type (Target_Type) then
6653 Target_Type := Etype (Target_Type);
6654 end if;
6656 if Is_Interface (Target_Type) then
6657 if Is_Access_Type (Opnd_Type) then
6658 Opnd_Type := Directly_Designated_Type (Opnd_Type);
6659 end if;
6661 declare
6662 Save_Typ : constant Entity_Id := Opnd_Type;
6664 begin
6665 if Is_Class_Wide_Type (Opnd_Type) then
6666 Opnd_Type := Etype (Opnd_Type);
6667 end if;
6669 if not Interface_Present_In_Ancestor
6670 (Typ => Opnd_Type,
6671 Iface => Target_Type)
6672 then
6673 -- The static analysis is not enough to know if the
6674 -- interface is implemented or not. Hence we must pass the
6675 -- work to the expander to generate the required code to
6676 -- evaluate the conversion at run-time.
6678 if Is_Class_Wide_Type (Save_Typ)
6679 and then Is_Interface (Save_Typ)
6680 then
6681 Expand_Interface_Conversion (N, Is_Static => False);
6682 else
6683 Error_Msg_NE
6684 ("(Ada 2005) does not implement interface }",
6685 Operand, Target_Type);
6686 end if;
6688 else
6689 -- If a conversion to an interface type appears as an actual
6690 -- in a source call, it will be expanded when the enclosing
6691 -- call itself is examined in Expand_Interface_Formals.
6692 -- Otherwise, generate the proper conversion code now, using
6693 -- the tag of the interface.
6695 if (Nkind (Parent (N)) = N_Procedure_Call_Statement
6696 or else Nkind (Parent (N)) = N_Function_Call)
6697 and then Comes_From_Source (N)
6698 then
6699 null;
6700 else
6701 Expand_Interface_Conversion (N);
6702 end if;
6703 end if;
6704 end;
6705 end if;
6706 end if;
6707 end Resolve_Type_Conversion;
6709 ----------------------
6710 -- Resolve_Unary_Op --
6711 ----------------------
6713 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
6714 B_Typ : constant Entity_Id := Base_Type (Typ);
6715 R : constant Node_Id := Right_Opnd (N);
6716 OK : Boolean;
6717 Lo : Uint;
6718 Hi : Uint;
6720 begin
6721 -- Generate warning for expressions like -5 mod 3
6723 if Paren_Count (N) = 0
6724 and then Nkind (N) = N_Op_Minus
6725 and then Paren_Count (Right_Opnd (N)) = 0
6726 and then Nkind (Right_Opnd (N)) = N_Op_Mod
6727 and then Comes_From_Source (N)
6728 then
6729 Error_Msg_N
6730 ("?unary minus expression should be parenthesized here", N);
6731 end if;
6733 if Comes_From_Source (N)
6734 and then Ekind (Entity (N)) = E_Function
6735 and then Is_Imported (Entity (N))
6736 and then Is_Intrinsic_Subprogram (Entity (N))
6737 then
6738 Resolve_Intrinsic_Unary_Operator (N, Typ);
6739 return;
6740 end if;
6742 if Etype (R) = Universal_Integer
6743 or else Etype (R) = Universal_Real
6744 then
6745 Check_For_Visible_Operator (N, B_Typ);
6746 end if;
6748 Set_Etype (N, B_Typ);
6749 Resolve (R, B_Typ);
6751 -- Generate warning for expressions like abs (x mod 2)
6753 if Warn_On_Redundant_Constructs
6754 and then Nkind (N) = N_Op_Abs
6755 then
6756 Determine_Range (Right_Opnd (N), OK, Lo, Hi);
6758 if OK and then Hi >= Lo and then Lo >= 0 then
6759 Error_Msg_N
6760 ("?abs applied to known non-negative value has no effect", N);
6761 end if;
6762 end if;
6764 Check_Unset_Reference (R);
6765 Generate_Operator_Reference (N, B_Typ);
6766 Eval_Unary_Op (N);
6768 -- Set overflow checking bit. Much cleverer code needed here eventually
6769 -- and perhaps the Resolve routines should be separated for the various
6770 -- arithmetic operations, since they will need different processing ???
6772 if Nkind (N) in N_Op then
6773 if not Overflow_Checks_Suppressed (Etype (N)) then
6774 Enable_Overflow_Check (N);
6775 end if;
6776 end if;
6777 end Resolve_Unary_Op;
6779 ----------------------------------
6780 -- Resolve_Unchecked_Expression --
6781 ----------------------------------
6783 procedure Resolve_Unchecked_Expression
6784 (N : Node_Id;
6785 Typ : Entity_Id)
6786 is
6787 begin
6788 Resolve (Expression (N), Typ, Suppress => All_Checks);
6789 Set_Etype (N, Typ);
6790 end Resolve_Unchecked_Expression;
6792 ---------------------------------------
6793 -- Resolve_Unchecked_Type_Conversion --
6794 ---------------------------------------
6796 procedure Resolve_Unchecked_Type_Conversion
6797 (N : Node_Id;
6798 Typ : Entity_Id)
6799 is
6800 pragma Warnings (Off, Typ);
6802 Operand : constant Node_Id := Expression (N);
6803 Opnd_Type : constant Entity_Id := Etype (Operand);
6805 begin
6806 -- Resolve operand using its own type
6808 Resolve (Operand, Opnd_Type);
6809 Eval_Unchecked_Conversion (N);
6811 end Resolve_Unchecked_Type_Conversion;
6813 ------------------------------
6814 -- Rewrite_Operator_As_Call --
6815 ------------------------------
6817 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
6818 Loc : constant Source_Ptr := Sloc (N);
6819 Actuals : constant List_Id := New_List;
6820 New_N : Node_Id;
6822 begin
6823 if Nkind (N) in N_Binary_Op then
6824 Append (Left_Opnd (N), Actuals);
6825 end if;
6827 Append (Right_Opnd (N), Actuals);
6829 New_N :=
6830 Make_Function_Call (Sloc => Loc,
6831 Name => New_Occurrence_Of (Nam, Loc),
6832 Parameter_Associations => Actuals);
6834 Preserve_Comes_From_Source (New_N, N);
6835 Preserve_Comes_From_Source (Name (New_N), N);
6836 Rewrite (N, New_N);
6837 Set_Etype (N, Etype (Nam));
6838 end Rewrite_Operator_As_Call;
6840 ------------------------------
6841 -- Rewrite_Renamed_Operator --
6842 ------------------------------
6844 procedure Rewrite_Renamed_Operator
6845 (N : Node_Id;
6846 Op : Entity_Id;
6847 Typ : Entity_Id)
6848 is
6849 Nam : constant Name_Id := Chars (Op);
6850 Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
6851 Op_Node : Node_Id;
6853 begin
6854 -- Rewrite the operator node using the real operator, not its
6855 -- renaming. Exclude user-defined intrinsic operations of the same
6856 -- name, which are treated separately and rewritten as calls.
6858 if Ekind (Op) /= E_Function
6859 or else Chars (N) /= Nam
6860 then
6861 Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
6862 Set_Chars (Op_Node, Nam);
6863 Set_Etype (Op_Node, Etype (N));
6864 Set_Entity (Op_Node, Op);
6865 Set_Right_Opnd (Op_Node, Right_Opnd (N));
6867 -- Indicate that both the original entity and its renaming
6868 -- are referenced at this point.
6870 Generate_Reference (Entity (N), N);
6871 Generate_Reference (Op, N);
6873 if Is_Binary then
6874 Set_Left_Opnd (Op_Node, Left_Opnd (N));
6875 end if;
6877 Rewrite (N, Op_Node);
6879 -- If the context type is private, add the appropriate conversions
6880 -- so that the operator is applied to the full view. This is done
6881 -- in the routines that resolve intrinsic operators,
6883 if Is_Intrinsic_Subprogram (Op)
6884 and then Is_Private_Type (Typ)
6885 then
6886 case Nkind (N) is
6887 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
6888 N_Op_Expon | N_Op_Mod | N_Op_Rem =>
6889 Resolve_Intrinsic_Operator (N, Typ);
6891 when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
6892 Resolve_Intrinsic_Unary_Operator (N, Typ);
6894 when others =>
6895 Resolve (N, Typ);
6896 end case;
6897 end if;
6899 elsif Ekind (Op) = E_Function
6900 and then Is_Intrinsic_Subprogram (Op)
6901 then
6902 -- Operator renames a user-defined operator of the same name. Use
6903 -- the original operator in the node, which is the one that gigi
6904 -- knows about.
6906 Set_Entity (N, Op);
6907 Set_Is_Overloaded (N, False);
6908 end if;
6909 end Rewrite_Renamed_Operator;
6911 -----------------------
6912 -- Set_Slice_Subtype --
6913 -----------------------
6915 -- Build an implicit subtype declaration to represent the type delivered
6916 -- by the slice. This is an abbreviated version of an array subtype. We
6917 -- define an index subtype for the slice, using either the subtype name
6918 -- or the discrete range of the slice. To be consistent with index usage
6919 -- elsewhere, we create a list header to hold the single index. This list
6920 -- is not otherwise attached to the syntax tree.
6922 procedure Set_Slice_Subtype (N : Node_Id) is
6923 Loc : constant Source_Ptr := Sloc (N);
6924 Index_List : constant List_Id := New_List;
6925 Index : Node_Id;
6926 Index_Subtype : Entity_Id;
6927 Index_Type : Entity_Id;
6928 Slice_Subtype : Entity_Id;
6929 Drange : constant Node_Id := Discrete_Range (N);
6931 begin
6932 if Is_Entity_Name (Drange) then
6933 Index_Subtype := Entity (Drange);
6935 else
6936 -- We force the evaluation of a range. This is definitely needed in
6937 -- the renamed case, and seems safer to do unconditionally. Note in
6938 -- any case that since we will create and insert an Itype referring
6939 -- to this range, we must make sure any side effect removal actions
6940 -- are inserted before the Itype definition.
6942 if Nkind (Drange) = N_Range then
6943 Force_Evaluation (Low_Bound (Drange));
6944 Force_Evaluation (High_Bound (Drange));
6945 end if;
6947 Index_Type := Base_Type (Etype (Drange));
6949 Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
6951 Set_Scalar_Range (Index_Subtype, Drange);
6952 Set_Etype (Index_Subtype, Index_Type);
6953 Set_Size_Info (Index_Subtype, Index_Type);
6954 Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
6955 end if;
6957 Slice_Subtype := Create_Itype (E_Array_Subtype, N);
6959 Index := New_Occurrence_Of (Index_Subtype, Loc);
6960 Set_Etype (Index, Index_Subtype);
6961 Append (Index, Index_List);
6963 Set_First_Index (Slice_Subtype, Index);
6964 Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
6965 Set_Is_Constrained (Slice_Subtype, True);
6966 Init_Size_Align (Slice_Subtype);
6968 Check_Compile_Time_Size (Slice_Subtype);
6970 -- The Etype of the existing Slice node is reset to this slice
6971 -- subtype. Its bounds are obtained from its first index.
6973 Set_Etype (N, Slice_Subtype);
6975 -- In the packed case, this must be immediately frozen
6977 -- Couldn't we always freeze here??? and if we did, then the above
6978 -- call to Check_Compile_Time_Size could be eliminated, which would
6979 -- be nice, because then that routine could be made private to Freeze.
6981 if Is_Packed (Slice_Subtype) and not In_Default_Expression then
6982 Freeze_Itype (Slice_Subtype, N);
6983 end if;
6985 end Set_Slice_Subtype;
6987 --------------------------------
6988 -- Set_String_Literal_Subtype --
6989 --------------------------------
6991 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
6992 Subtype_Id : Entity_Id;
6994 begin
6995 if Nkind (N) /= N_String_Literal then
6996 return;
6997 else
6998 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
6999 end if;
7001 Set_String_Literal_Length (Subtype_Id, UI_From_Int
7002 (String_Length (Strval (N))));
7003 Set_Etype (Subtype_Id, Base_Type (Typ));
7004 Set_Is_Constrained (Subtype_Id);
7006 -- The low bound is set from the low bound of the corresponding
7007 -- index type. Note that we do not store the high bound in the
7008 -- string literal subtype, but it can be deduced if necssary
7009 -- from the length and the low bound.
7011 Set_String_Literal_Low_Bound
7012 (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
7014 Set_Etype (N, Subtype_Id);
7015 end Set_String_Literal_Subtype;
7017 -----------------------------
7018 -- Unique_Fixed_Point_Type --
7019 -----------------------------
7021 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
7022 T1 : Entity_Id := Empty;
7023 T2 : Entity_Id;
7024 Item : Node_Id;
7025 Scop : Entity_Id;
7027 procedure Fixed_Point_Error;
7028 -- If true ambiguity, give details
7030 -----------------------
7031 -- Fixed_Point_Error --
7032 -----------------------
7034 procedure Fixed_Point_Error is
7035 begin
7036 Error_Msg_N ("ambiguous universal_fixed_expression", N);
7039 end Fixed_Point_Error;
7041 -- Start of processing for Unique_Fixed_Point_Type
7043 begin
7044 -- The operations on Duration are visible, so Duration is always a
7045 -- possible interpretation.
7047 T1 := Standard_Duration;
7049 -- Look for fixed-point types in enclosing scopes
7051 Scop := Current_Scope;
7052 while Scop /= Standard_Standard loop
7053 T2 := First_Entity (Scop);
7054 while Present (T2) loop
7055 if Is_Fixed_Point_Type (T2)
7056 and then Current_Entity (T2) = T2
7057 and then Scope (Base_Type (T2)) = Scop
7058 then
7059 if Present (T1) then
7060 Fixed_Point_Error;
7061 return Any_Type;
7062 else
7063 T1 := T2;
7064 end if;
7065 end if;
7067 Next_Entity (T2);
7068 end loop;
7070 Scop := Scope (Scop);
7071 end loop;
7073 -- Look for visible fixed type declarations in the context
7075 Item := First (Context_Items (Cunit (Current_Sem_Unit)));
7076 while Present (Item) loop
7077 if Nkind (Item) = N_With_Clause then
7078 Scop := Entity (Name (Item));
7079 T2 := First_Entity (Scop);
7080 while Present (T2) loop
7081 if Is_Fixed_Point_Type (T2)
7082 and then Scope (Base_Type (T2)) = Scop
7083 and then (Is_Potentially_Use_Visible (T2)
7084 or else In_Use (T2))
7085 then
7086 if Present (T1) then
7087 Fixed_Point_Error;
7088 return Any_Type;
7089 else
7090 T1 := T2;
7091 end if;
7092 end if;
7094 Next_Entity (T2);
7095 end loop;
7096 end if;
7098 Next (Item);
7099 end loop;
7101 if Nkind (N) = N_Real_Literal then
7102 Error_Msg_NE ("real literal interpreted as }?", N, T1);
7104 else
7105 Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
7106 end if;
7108 return T1;
7109 end Unique_Fixed_Point_Type;
7111 ----------------------
7112 -- Valid_Conversion --
7113 ----------------------
7115 function Valid_Conversion
7116 (N : Node_Id;
7117 Target : Entity_Id;
7118 Operand : Node_Id) return Boolean
7119 is
7120 Target_Type : constant Entity_Id := Base_Type (Target);
7121 Opnd_Type : Entity_Id := Etype (Operand);
7123 function Conversion_Check
7124 (Valid : Boolean;
7125 Msg : String) return Boolean;
7126 -- Little routine to post Msg if Valid is False, returns Valid value
7128 function Valid_Tagged_Conversion
7129 (Target_Type : Entity_Id;
7130 Opnd_Type : Entity_Id) return Boolean;
7131 -- Specifically test for validity of tagged conversions
7133 ----------------------
7134 -- Conversion_Check --
7135 ----------------------
7137 function Conversion_Check
7138 (Valid : Boolean;
7139 Msg : String) return Boolean
7140 is
7141 begin
7142 if not Valid then
7143 Error_Msg_N (Msg, Operand);
7144 end if;
7146 return Valid;
7147 end Conversion_Check;
7149 -----------------------------
7150 -- Valid_Tagged_Conversion --
7151 -----------------------------
7153 function Valid_Tagged_Conversion
7154 (Target_Type : Entity_Id;
7155 Opnd_Type : Entity_Id) return Boolean
7156 is
7157 begin
7158 -- Upward conversions are allowed (RM 4.6(22))
7160 if Covers (Target_Type, Opnd_Type)
7161 or else Is_Ancestor (Target_Type, Opnd_Type)
7162 then
7163 return True;
7165 -- Downward conversion are allowed if the operand is class-wide
7166 -- (RM 4.6(23)).
7168 elsif Is_Class_Wide_Type (Opnd_Type)
7169 and then Covers (Opnd_Type, Target_Type)
7170 then
7171 return True;
7173 elsif Covers (Opnd_Type, Target_Type)
7174 or else Is_Ancestor (Opnd_Type, Target_Type)
7175 then
7176 return
7177 Conversion_Check (False,
7178 "downward conversion of tagged objects not allowed");
7180 -- Ada 2005 (AI-251): The conversion of a tagged type to an
7181 -- abstract interface type is always valid
7183 elsif Is_Interface (Target_Type) then
7184 return True;
7186 else
7187 Error_Msg_NE
7188 ("invalid tagged conversion, not compatible with}",
7189 N, First_Subtype (Opnd_Type));
7190 return False;
7191 end if;
7192 end Valid_Tagged_Conversion;
7194 -- Start of processing for Valid_Conversion
7196 begin
7197 Check_Parameterless_Call (Operand);
7199 if Is_Overloaded (Operand) then
7200 declare
7201 I : Interp_Index;
7202 I1 : Interp_Index;
7203 It : Interp;
7204 It1 : Interp;
7205 N1 : Entity_Id;
7207 begin
7208 -- Remove procedure calls, which syntactically cannot appear
7209 -- in this context, but which cannot be removed by type checking,
7210 -- because the context does not impose a type.
7212 -- When compiling for VMS, spurious ambiguities can be produced
7213 -- when arithmetic operations have a literal operand and return
7214 -- System.Address or a descendant of it. These ambiguities are
7215 -- otherwise resolved by the context, but for conversions there
7216 -- is no context type and the removal of the spurious operations
7217 -- must be done explicitly here.
7219 -- The node may be labelled overloaded, but still contain only
7220 -- one interpretation because others were discarded in previous
7221 -- filters. If this is the case, retain the single interpretation
7222 -- if legal.
7224 Get_First_Interp (Operand, I, It);
7225 Opnd_Type := It.Typ;
7226 Get_Next_Interp (I, It);
7228 if Present (It.Typ)
7229 and then Opnd_Type /= Standard_Void_Type
7230 then
7231 -- More than one candidate interpretation is available
7233 Get_First_Interp (Operand, I, It);
7234 while Present (It.Typ) loop
7235 if It.Typ = Standard_Void_Type then
7236 Remove_Interp (I);
7237 end if;
7239 if Present (System_Aux_Id)
7240 and then Is_Descendent_Of_Address (It.Typ)
7241 then
7242 Remove_Interp (I);
7243 end if;
7245 Get_Next_Interp (I, It);
7246 end loop;
7247 end if;
7249 Get_First_Interp (Operand, I, It);
7250 I1 := I;
7251 It1 := It;
7253 if No (It.Typ) then
7254 Error_Msg_N ("illegal operand in conversion", Operand);
7255 return False;
7256 end if;
7258 Get_Next_Interp (I, It);
7260 if Present (It.Typ) then
7261 N1 := It1.Nam;
7262 It1 := Disambiguate (Operand, I1, I, Any_Type);
7264 if It1 = No_Interp then
7265 Error_Msg_N ("ambiguous operand in conversion", Operand);
7267 Error_Msg_Sloc := Sloc (It.Nam);
7268 Error_Msg_N ("possible interpretation#!", Operand);
7270 Error_Msg_Sloc := Sloc (N1);
7271 Error_Msg_N ("possible interpretation#!", Operand);
7273 return False;
7274 end if;
7275 end if;
7277 Set_Etype (Operand, It1.Typ);
7278 Opnd_Type := It1.Typ;
7279 end;
7280 end if;
7282 if Chars (Current_Scope) = Name_Unchecked_Conversion then
7284 -- This check is dubious, what if there were a user defined
7285 -- scope whose name was Unchecked_Conversion ???
7287 return True;
7289 elsif Is_Numeric_Type (Target_Type) then
7290 if Opnd_Type = Universal_Fixed then
7291 return True;
7293 elsif (In_Instance or else In_Inlined_Body)
7294 and then not Comes_From_Source (N)
7295 then
7296 return True;
7298 else
7299 return Conversion_Check (Is_Numeric_Type (Opnd_Type),
7300 "illegal operand for numeric conversion");
7301 end if;
7303 elsif Is_Array_Type (Target_Type) then
7304 if not Is_Array_Type (Opnd_Type)
7305 or else Opnd_Type = Any_Composite
7306 or else Opnd_Type = Any_String
7307 then
7308 Error_Msg_N
7309 ("illegal operand for array conversion", Operand);
7310 return False;
7312 elsif Number_Dimensions (Target_Type) /=
7313 Number_Dimensions (Opnd_Type)
7314 then
7315 Error_Msg_N
7316 ("incompatible number of dimensions for conversion", Operand);
7317 return False;
7319 else
7320 declare
7321 Target_Index : Node_Id := First_Index (Target_Type);
7322 Opnd_Index : Node_Id := First_Index (Opnd_Type);
7324 Target_Index_Type : Entity_Id;
7325 Opnd_Index_Type : Entity_Id;
7327 Target_Comp_Type : constant Entity_Id :=
7328 Component_Type (Target_Type);
7329 Opnd_Comp_Type : constant Entity_Id :=
7330 Component_Type (Opnd_Type);
7332 begin
7333 while Present (Target_Index) and then Present (Opnd_Index) loop
7334 Target_Index_Type := Etype (Target_Index);
7335 Opnd_Index_Type := Etype (Opnd_Index);
7337 if not (Is_Integer_Type (Target_Index_Type)
7338 and then Is_Integer_Type (Opnd_Index_Type))
7339 and then (Root_Type (Target_Index_Type)
7340 /= Root_Type (Opnd_Index_Type))
7341 then
7342 Error_Msg_N
7343 ("incompatible index types for array conversion",
7344 Operand);
7345 return False;
7346 end if;
7348 Next_Index (Target_Index);
7349 Next_Index (Opnd_Index);
7350 end loop;
7352 if Base_Type (Target_Comp_Type) /=
7353 Base_Type (Opnd_Comp_Type)
7354 then
7355 Error_Msg_N
7356 ("incompatible component types for array conversion",
7357 Operand);
7358 return False;
7360 elsif
7361 Is_Constrained (Target_Comp_Type)
7362 /= Is_Constrained (Opnd_Comp_Type)
7363 or else not Subtypes_Statically_Match
7364 (Target_Comp_Type, Opnd_Comp_Type)
7365 then
7366 Error_Msg_N
7367 ("component subtypes must statically match", Operand);
7368 return False;
7370 end if;
7371 end;
7372 end if;
7374 return True;
7376 -- Ada 2005 (AI-251)
7378 elsif (Ekind (Target_Type) = E_General_Access_Type
7379 or else Ekind (Target_Type) = E_Anonymous_Access_Type)
7380 and then Is_Interface (Directly_Designated_Type (Target_Type))
7381 then
7382 -- Check the static accessibility rule of 4.6(17). Note that the
7383 -- check is not enforced when within an instance body, since the RM
7384 -- requires such cases to be caught at run time.
7386 if Ekind (Target_Type) /= E_Anonymous_Access_Type then
7387 if Type_Access_Level (Opnd_Type) >
7388 Type_Access_Level (Target_Type)
7389 then
7390 -- In an instance, this is a run-time check, but one we know
7391 -- will fail, so generate an appropriate warning. The raise
7392 -- will be generated by Expand_N_Type_Conversion.
7394 if In_Instance_Body then
7395 Error_Msg_N
7396 ("?cannot convert local pointer to non-local access type",
7397 Operand);
7398 Error_Msg_N
7399 ("?Program_Error will be raised at run time", Operand);
7401 else
7402 Error_Msg_N
7403 ("cannot convert local pointer to non-local access type",
7404 Operand);
7405 return False;
7406 end if;
7408 -- Special accessibility checks are needed in the case of access
7409 -- discriminants declared for a limited type.
7411 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
7412 and then not Is_Local_Anonymous_Access (Opnd_Type)
7413 then
7414 -- When the operand is a selected access discriminant the check
7415 -- needs to be made against the level of the object denoted by
7416 -- the prefix of the selected name. (Object_Access_Level
7417 -- handles checking the prefix of the operand for this case.)
7419 if Nkind (Operand) = N_Selected_Component
7420 and then Object_Access_Level (Operand)
7421 > Type_Access_Level (Target_Type)
7422 then
7423 -- In an instance, this is a run-time check, but one we
7424 -- know will fail, so generate an appropriate warning.
7425 -- The raise will be generated by Expand_N_Type_Conversion.
7427 if In_Instance_Body then
7428 Error_Msg_N
7429 ("?cannot convert access discriminant to non-local" &
7430 " access type", Operand);
7431 Error_Msg_N
7432 ("?Program_Error will be raised at run time", Operand);
7434 else
7435 Error_Msg_N
7436 ("cannot convert access discriminant to non-local" &
7437 " access type", Operand);
7438 return False;
7439 end if;
7440 end if;
7442 -- The case of a reference to an access discriminant from
7443 -- within a limited type declaration (which will appear as
7444 -- a discriminal) is always illegal because the level of the
7445 -- discriminant is considered to be deeper than any (namable)
7446 -- access type.
7448 if Is_Entity_Name (Operand)
7449 and then not Is_Local_Anonymous_Access (Opnd_Type)
7450 and then (Ekind (Entity (Operand)) = E_In_Parameter
7451 or else Ekind (Entity (Operand)) = E_Constant)
7452 and then Present (Discriminal_Link (Entity (Operand)))
7453 then
7454 Error_Msg_N
7455 ("discriminant has deeper accessibility level than target",
7456 Operand);
7457 return False;
7458 end if;
7459 end if;
7460 end if;
7462 return True;
7464 elsif (Ekind (Target_Type) = E_General_Access_Type
7465 or else Ekind (Target_Type) = E_Anonymous_Access_Type)
7466 and then
7467 Conversion_Check
7468 (Is_Access_Type (Opnd_Type)
7469 and then Ekind (Opnd_Type) /=
7470 E_Access_Subprogram_Type
7471 and then Ekind (Opnd_Type) /=
7472 E_Access_Protected_Subprogram_Type,
7473 "must be an access-to-object type")
7474 then
7475 if Is_Access_Constant (Opnd_Type)
7476 and then not Is_Access_Constant (Target_Type)
7477 then
7478 Error_Msg_N
7479 ("access-to-constant operand type not allowed", Operand);
7480 return False;
7481 end if;
7483 -- Check the static accessibility rule of 4.6(17). Note that the
7484 -- check is not enforced when within an instance body, since the RM
7485 -- requires such cases to be caught at run time.
7487 if Ekind (Target_Type) /= E_Anonymous_Access_Type
7488 or else Is_Local_Anonymous_Access (Target_Type)
7489 then
7490 if Type_Access_Level (Opnd_Type)
7491 > Type_Access_Level (Target_Type)
7492 then
7493 -- In an instance, this is a run-time check, but one we
7494 -- know will fail, so generate an appropriate warning.
7495 -- The raise will be generated by Expand_N_Type_Conversion.
7497 if In_Instance_Body then
7498 Error_Msg_N
7499 ("?cannot convert local pointer to non-local access type",
7500 Operand);
7501 Error_Msg_N
7502 ("?Program_Error will be raised at run time", Operand);
7504 else
7505 Error_Msg_N
7506 ("cannot convert local pointer to non-local access type",
7507 Operand);
7508 return False;
7509 end if;
7511 -- Special accessibility checks are needed in the case of access
7512 -- discriminants declared for a limited type.
7514 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
7515 and then not Is_Local_Anonymous_Access (Opnd_Type)
7516 then
7518 -- When the operand is a selected access discriminant the check
7519 -- needs to be made against the level of the object denoted by
7520 -- the prefix of the selected name. (Object_Access_Level
7521 -- handles checking the prefix of the operand for this case.)
7523 if Nkind (Operand) = N_Selected_Component
7524 and then Object_Access_Level (Operand)
7525 > Type_Access_Level (Target_Type)
7526 then
7527 -- In an instance, this is a run-time check, but one we
7528 -- know will fail, so generate an appropriate warning.
7529 -- The raise will be generated by Expand_N_Type_Conversion.
7531 if In_Instance_Body then
7532 Error_Msg_N
7533 ("?cannot convert access discriminant to non-local" &
7534 " access type", Operand);
7535 Error_Msg_N
7536 ("?Program_Error will be raised at run time", Operand);
7538 else
7539 Error_Msg_N
7540 ("cannot convert access discriminant to non-local" &
7541 " access type", Operand);
7542 return False;
7543 end if;
7544 end if;
7546 -- The case of a reference to an access discriminant from
7547 -- within a limited type declaration (which will appear as
7548 -- a discriminal) is always illegal because the level of the
7549 -- discriminant is considered to be deeper than any (namable)
7550 -- access type.
7552 if Is_Entity_Name (Operand)
7553 and then (Ekind (Entity (Operand)) = E_In_Parameter
7554 or else Ekind (Entity (Operand)) = E_Constant)
7555 and then Present (Discriminal_Link (Entity (Operand)))
7556 then
7557 Error_Msg_N
7558 ("discriminant has deeper accessibility level than target",
7559 Operand);
7560 return False;
7561 end if;
7562 end if;
7563 end if;
7565 declare
7566 Target : constant Entity_Id := Designated_Type (Target_Type);
7567 Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
7569 begin
7570 if Is_Tagged_Type (Target) then
7571 return Valid_Tagged_Conversion (Target, Opnd);
7573 else
7574 if Base_Type (Target) /= Base_Type (Opnd) then
7575 Error_Msg_NE
7576 ("target designated type not compatible with }",
7577 N, Base_Type (Opnd));
7578 return False;
7580 -- Ada 2005 AI-384: legality rule is symmetric in both
7581 -- designated types. The conversion is legal (with possible
7582 -- constraint check) if either designated type is
7583 -- unconstrained.
7585 elsif Subtypes_Statically_Match (Target, Opnd)
7586 or else
7587 (Has_Discriminants (Target)
7588 and then
7589 (not Is_Constrained (Opnd)
7590 or else not Is_Constrained (Target)))
7591 then
7592 return True;
7594 else
7595 Error_Msg_NE
7596 ("target designated subtype not compatible with }",
7597 N, Opnd);
7598 return False;
7599 end if;
7600 end if;
7601 end;
7603 elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
7604 or else
7605 Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
7606 and then No (Corresponding_Remote_Type (Opnd_Type))
7607 and then Conversion_Check
7608 (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
7609 "illegal operand for access subprogram conversion")
7610 then
7611 -- Check that the designated types are subtype conformant
7613 Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
7614 Old_Id => Designated_Type (Opnd_Type),
7615 Err_Loc => N);
7617 -- Check the static accessibility rule of 4.6(20)
7619 if Type_Access_Level (Opnd_Type) >
7620 Type_Access_Level (Target_Type)
7621 then
7622 Error_Msg_N
7623 ("operand type has deeper accessibility level than target",
7624 Operand);
7626 -- Check that if the operand type is declared in a generic body,
7627 -- then the target type must be declared within that same body
7628 -- (enforces last sentence of 4.6(20)).
7630 elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
7631 declare
7632 O_Gen : constant Node_Id :=
7633 Enclosing_Generic_Body (Opnd_Type);
7635 T_Gen : Node_Id;
7637 begin
7638 T_Gen := Enclosing_Generic_Body (Target_Type);
7639 while Present (T_Gen) and then T_Gen /= O_Gen loop
7640 T_Gen := Enclosing_Generic_Body (T_Gen);
7641 end loop;
7643 if T_Gen /= O_Gen then
7644 Error_Msg_N
7645 ("target type must be declared in same generic body"
7646 & " as operand type", N);
7647 end if;
7648 end;
7649 end if;
7651 return True;
7653 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
7654 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
7655 then
7656 -- It is valid to convert from one RAS type to another provided
7657 -- that their specification statically match.
7659 Check_Subtype_Conformant
7660 (New_Id =>
7661 Designated_Type (Corresponding_Remote_Type (Target_Type)),
7662 Old_Id =>
7663 Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
7664 Err_Loc =>
7665 N);
7666 return True;
7668 elsif Is_Tagged_Type (Target_Type) then
7669 return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
7671 -- Types derived from the same root type are convertible
7673 elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
7674 return True;
7676 -- In an instance, there may be inconsistent views of the same
7677 -- type, or types derived from the same type.
7679 elsif In_Instance
7680 and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
7681 then
7682 return True;
7684 -- Special check for common access type error case
7686 elsif Ekind (Target_Type) = E_Access_Type
7687 and then Is_Access_Type (Opnd_Type)
7688 then
7689 Error_Msg_N ("target type must be general access type!", N);
7690 Error_Msg_NE ("add ALL to }!", N, Target_Type);
7692 return False;
7694 else
7695 Error_Msg_NE ("invalid conversion, not compatible with }",
7696 N, Opnd_Type);
7698 return False;
7699 end if;
7700 end Valid_Conversion;
7702 end Sem_Res;