| blob | 6df80d2257091ac6e651946616fdb5b1067a1410 |
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-2002, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 -- Second pass (top-down) type checking and overload resolution procedures
77 -- Typ is the type required by context. These procedures propagate the
78 -- type information recursively to the descendants of N. If the node
79 -- is not overloaded, its Etype is established in the first pass. If
80 -- overloaded, the Resolve routines set the correct type. For arith.
81 -- operators, the Etype is the base type of the context.
83 -- Note that Resolve_Attribute is separated off in Sem_Attr
86 -- Give list of candidate interpretations when a character literal cannot
87 -- be resolved.
90 -- Enforce the restrictions on the use of discriminants when constraining
91 -- a component of a discriminated type (record or concurrent type).
94 -- Given a node for an operator associated with type T, check that
95 -- the operator is visible. Operators all of whose operands are
96 -- universal must be checked for visibility during resolution
97 -- because their type is not determinable based on their operands.
100 -- Given a call node, N, which is known to occur immediately within the
101 -- subprogram being called, determines whether it is a detectable case of
102 -- an infinite recursion, and if so, outputs appropriate messages. Returns
103 -- True if an infinite recursion is detected, and False otherwise.
106 -- If the type of the object being initialized uses the secondary stack
107 -- directly or indirectly, create a transient scope for the call to the
108 -- Init_Proc. This is because we do not create transient scopes for the
109 -- initialization of individual components within the init_proc itself.
110 -- Could be optimized away perhaps?
113 -- Utility to check whether the name in the call is a predefined
114 -- operator, in which case the call is made into an operator node.
115 -- An instance of an intrinsic conversion operation may be given
116 -- an operator name, but is not treated like an operator.
119 -- If a default expression in entry call N depends on the discriminants
120 -- of the task, it must be replaced with a reference to the discriminant
121 -- of the task being called.
156 function Operator_Kind
160 -- Utility to map the name of an operator into the corresponding Node. Used
161 -- by other node rewriting procedures.
164 -- Resolve actuals of call, and add default expressions for missing ones.
167 -- Called from Resolve_Call, when the prefix denotes an entry or element
168 -- of entry family. Actuals are resolved as for subprograms, and the node
169 -- is rebuilt as an entry call. Also called for protected operations. Typ
170 -- is the context type, which is used when the operation is a protected
171 -- function with no arguments, and the return value is indexed.
174 -- A call to a user-defined intrinsic operator is rewritten as a call
175 -- to the corresponding predefined operator, with suitable conversions.
178 -- If an operator node resolves to a call to a user-defined operator,
179 -- rewrite the node as a function call.
181 procedure Make_Call_Into_Operator
185 -- Inverse transformation: if an operator is given in functional notation,
186 -- then after resolving the node, transform into an operator node, so
187 -- that operands are resolved properly. Recall that predefined operators
188 -- do not have a full signature and special resolution rules apply.
191 -- An operator can rename another, e.g. in an instantiation. In that
192 -- case, the proper operator node must be constructed.
195 -- The String_Literal_Subtype is built for all strings that are not
196 -- operands of a static concatenation operation. If the argument is
197 -- not a N_String_Literal node, then the call has no effect.
200 -- Build subtype of array type, with the range specified by the slice.
203 -- A universal_fixed expression in an universal context is unambiguous
204 -- if there is only one applicable fixed point type. Determining whether
205 -- there is only one requires a search over all visible entities, and
206 -- happens only in very pathological cases (see 6115-006).
208 function Valid_Conversion
213 -- Verify legality rules given in 4.6 (8-23). Target is the target
214 -- type of the conversion, which may be an implicit conversion of
215 -- an actual parameter to an anonymous access type (in which case
216 -- N denotes the actual parameter and N = Operand).
218 -------------------------
219 -- Ambiguous_Character --
220 -------------------------
225 begin
228 Error_Msg_N
243 -------------------------
244 -- Analyze_And_Resolve --
245 -------------------------
248 begin
254 begin
259 -- Version withs check(s) suppressed
261 procedure Analyze_And_Resolve
265 is
268 begin
270 declare
273 begin
279 else
280 declare
283 begin
291 and then Scope_Is_Transient
292 then
293 -- This can only happen if a transient scope was created
294 -- for an inner expression, which will be removed upon
295 -- completion of the analysis of an enclosing construct.
296 -- The transient scope must have the suppress status of
297 -- the enclosing environment, not of this Analyze call.
300 Scope_Suppress;
304 procedure Analyze_And_Resolve
307 is
310 begin
312 declare
315 begin
321 else
322 declare
325 begin
333 and then Scope_Is_Transient
334 then
336 Scope_Suppress;
340 ----------------------------
341 -- Check_Discriminant_Use --
342 ----------------------------
350 begin
351 -- Any use in a default expression is legal.
358 -- Discriminant cannot be used to constrain a scalar type.
365 then
370 -- The following check catches the unusual case where
371 -- a discriminant appears within an index constraint
372 -- that is part of a larger expression within a constraint
373 -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
374 -- For now we only check case of record components, and
375 -- note that a similar check should also apply in the
376 -- case of discriminant constraints below. ???
378 -- Note that the check for N_Subtype_Declaration below is to
379 -- detect the valid use of discriminants in the constraints of a
380 -- subtype declaration when this subtype declaration appears
381 -- inside the scope of a record type (which is syntactically
382 -- illegal, but which may be created as part of derived type
383 -- processing for records). See Sem_Ch3.Build_Derived_Record_Type
384 -- for more info.
388 and then not
390 and then
394 then
395 Error_Msg_N
400 -- Detect a common beginner error:
401 -- type R (D : Positive := 100) is record
402 -- Name: String (1 .. D);
403 -- end record;
405 -- The default value causes an object of type R to be
406 -- allocated with room for Positive'Last characters.
408 declare
415 -- Return True if type T has a large enough range that
416 -- any array whose index type covered the whole range of
417 -- the type would likely raise Storage_Error.
420 begin
421 return
422 T = Standard_Integer
423 or else
424 T = Standard_Positive
425 or else
429 begin
430 -- Check that the Disc has a large range
436 -- If the enclosing type is limited, we allocate only the
437 -- default value, not the maximum, and there is no need for
438 -- a warning.
444 -- Check that it is the high bound
448 then
452 -- Check the array allows a large range at this bound.
453 -- First find the array
467 -- Next, find the dimension
475 loop
484 -- Now, check the dimension has a large range
490 -- Warn about the danger
492 Error_Msg_N
494 N);
502 -- Legal case is in index or discriminant constraint
506 then
508 Error_Msg_N
514 -- Otherwise, context is an expression. It should not be within
515 -- (i.e. a subexpression of) a constraint for a component.
517 else
524 loop
530 -- If the discriminant is used in an expression that is a bound
531 -- of a scalar type, an Itype is created and the bounds are attached
532 -- to its range, not to the original subtype indication. Such use
533 -- is of course a double fault.
536 and then
541 -- The constraint itself may be given by a subtype indication,
542 -- rather than by a more common discrete range.
549 then
550 Error_Msg_N
556 --------------------------------
557 -- Check_For_Visible_Operator --
558 --------------------------------
563 begin
574 and then not In_Instance
575 then
576 Error_Msg_NE
582 ------------------------------
583 -- Check_Infinite_Recursion --
584 ------------------------------
591 -- Check whether list of actuals is identical to list of formals
592 -- of called function (which is also the enclosing scope).
594 ------------------------
595 -- Same_Argument_List --
596 ------------------------
603 begin
606 else
616 then
627 -- Start of processing for Check_Infinite_Recursion
629 begin
630 -- Loop moving up tree, quitting if something tells us we are
631 -- definitely not in an infinite recursion situation.
634 loop
642 then
647 then
648 -- If the call is the expression of a return statement and
649 -- the actuals are identical to the formals, it's worth a
650 -- warning. However, we skip this if there is an immediately
651 -- preceding raise statement, since the call is never executed.
653 -- Furthermore, this corresponds to a common idiom:
655 -- function F (L : Thing) return Boolean is
656 -- begin
657 -- raise Program_Error;
658 -- return F (L);
659 -- end F;
661 -- for generating a stub function
664 and then Same_Argument_List
665 then
668 and then
670 or else
676 else
689 -------------------------------
690 -- Check_Initialization_Call --
691 -------------------------------
697 -- Check whether the creation of an object of the type will involve
698 -- use of the secondary stack. If T is a record type, this is true
699 -- if the expression for some component uses the secondary stack, eg.
700 -- through a call to a function that returns an unconstrained value.
701 -- False if T is controlled, because cleanups occur elsewhere.
703 -------------
704 -- Uses_SS --
705 -------------
711 begin
725 then
730 then
743 else
748 -- Start of processing for Check_Initialization_Call
750 begin
751 -- Nothing to do if functions do not use the secondary stack for
752 -- returns (i.e. they use a depressed stack pointer instead).
757 -- Otherwise establish a transient scope if the type needs it
764 ------------------------------
765 -- Check_Parameterless_Call --
766 ------------------------------
771 begin
772 -- Defend against junk stuff if errors already detected
779 then
784 -- Rewrite as call if overloadable entity that is (or could be, in
785 -- the overloaded case) a function call. If we know for sure that
786 -- the entity is an enumeration literal, we do not rewrite it.
793 -- Rewrite as call if it is an explicit deference of an expression of
794 -- a subprogram access type, and the suprogram type is not that of a
795 -- procedure or entry.
797 or else
802 -- Rewrite as call if it is a selected component which is a function,
803 -- this is the case of a call to a protected function (which may be
804 -- overloaded with other protected operations).
806 or else
810 or else
814 -- If one of the above three conditions is met, rewrite as call.
815 -- Apply the rewriting only once.
817 then
820 then
823 -- If overloaded, overload set belongs to new copy.
827 -- Change node to parameterless function call (note that the
828 -- Parameter_Associations associations field is left set to Empty,
829 -- its normal default value since there are no parameters)
842 ----------------------
843 -- Is_Predefined_Op --
844 ----------------------
847 begin
855 -----------------------------
856 -- Make_Call_Into_Operator --
857 -----------------------------
859 procedure Make_Call_Into_Operator
863 is
877 -- Determine whether E is an access type declared by an access decla-
878 -- ration, and not an (anonymous) allocator type.
881 -- If the operand is not universal, and the operator is given by a
882 -- expanded name, verify that the operand has an interpretation with
883 -- a type defined in the given scope of the operator.
886 -- Find a type of the given class in the package Pack that contains
887 -- the operator.
889 -----------------------------
890 -- Is_Definite_Access_Type --
891 -----------------------------
895 begin
901 ---------------------------
902 -- Operand_Type_In_Scope --
903 ---------------------------
910 begin
914 else
930 ---------------
931 -- Type_In_P --
932 ---------------
938 -- Verify that node is not part of the type declaration for the
939 -- candidate type, which would otherwise be invisible.
941 -------------
942 -- In_Decl --
943 -------------
949 begin
958 else
961 loop
964 else
973 -- Start of processing for Type_In_P
975 begin
976 -- If the context type is declared in the prefix package, this
977 -- is the desired base type.
981 then
984 else
990 and then not In_Decl
991 then
1002 ---------------------------
1003 -- Operand_Type_In_Scope --
1004 ---------------------------
1006 -- Start of processing for Make_Call_Into_Operator
1008 begin
1011 -- Binary operator
1021 -- Unary operator
1023 else
1029 -- If the operator is denoted by an expanded name, and the prefix is
1030 -- not Standard, but the operator is a predefined one whose scope is
1031 -- Standard, then this is an implicit_operator, inserted as an
1032 -- interpretation by the procedure of the same name. This procedure
1033 -- overestimates the presence of implicit operators, because it does
1034 -- not examine the type of the operands. Verify now that the operand
1035 -- type appears in the given scope. If right operand is universal,
1036 -- check the other operand. In the case of concatenation, either
1037 -- argument can be the component type, so check the type of the result.
1038 -- If both arguments are literals, look for a type of the right kind
1039 -- defined in the given scope. This elaborate nonsense is brought to
1040 -- you courtesy of b33302a. The type itself must be frozen, so we must
1041 -- find the type of the proper class in the given scope.
1043 -- A final wrinkle is the multiplication operator for fixed point
1044 -- types, which is defined in Standard only, and not in the scope of
1045 -- the fixed_point type itself.
1050 -- If the entity being called is defined in the given package,
1051 -- it is a renaming of a predefined operator, and known to be
1052 -- legal.
1056 then
1063 then
1068 else
1077 and then Is_Binary
1079 then
1085 -- Verify that the scope contains a type that corresponds to
1086 -- the given literal. Optimize the case where Pack is Standard.
1108 else
1117 else
1126 then
1129 -- If the type is defined elsewhere, and the operator is not
1130 -- defined in the given scope (by a renaming declaration, e.g.)
1131 -- then this is an error as well. If an extension of System is
1132 -- present, and the type may be defined there, Pack must be
1133 -- System itself.
1140 then
1145 then
1152 Error_Msg_NE
1166 -- For predefined operators on literals, the operation freezes
1167 -- their type.
1175 -------------------
1176 -- Operator_Kind --
1177 -------------------
1179 function Operator_Kind
1182 return Node_Kind
1183 is
1186 begin
1205 else
1209 -- Unary operators
1211 else
1216 else
1224 -----------------------------
1225 -- Pre_Analyze_And_Resolve --
1226 -----------------------------
1231 begin
1235 -- We suppress all checks for this analysis, since the checks will
1236 -- be applied properly, and in the right location, when the default
1237 -- expression is reanalyzed and reexpanded later on.
1241 Expander_Mode_Restore;
1245 -- Version without context type.
1250 begin
1257 Expander_Mode_Restore;
1261 ----------------------------------
1262 -- Replace_Actual_Discriminants --
1263 ----------------------------------
1271 -------------------
1272 -- Process_Discr --
1273 -------------------
1278 begin
1284 then
1300 -- Start of processing for Replace_Actual_Discriminants
1302 begin
1316 else
1321 -------------
1322 -- Resolve --
1323 -------------
1337 -- Try and fix up a literal so that it matches its expected type. New
1338 -- literals are manufactured if necessary to avoid cascaded errors.
1341 -- Called when attempt at resolving current expression fails
1343 --------------------
1344 -- Patch_Up_Value --
1345 --------------------
1348 begin
1351 then
1360 then
1368 then
1379 then
1390 -----------------------
1391 -- Resolution_Failed --
1392 -----------------------
1395 begin
1401 -- The caller will return without calling the expander, so we need
1402 -- to set the analyzed flag. Note that it is fine to set Analyzed
1403 -- to True even if we are in the middle of a shallow analysis,
1404 -- (see the spec of sem for more details) since this is an error
1405 -- situation anyway, and there is no point in repeating the
1406 -- analysis later (indeed it won't work to repeat it later, since
1407 -- we haven't got a clear resolution of which entity is being
1408 -- referenced.)
1414 -- Start of processing for Resolve
1416 begin
1421 -- Access attribute on remote subprogram cannot be used for
1422 -- a non-remote access-to-subprogram type.
1433 then
1434 Error_Msg_N
1438 -- If the context is a Remote_Access_To_Subprogram, access attributes
1439 -- must be resolved with the corresponding fat pointer. There is no need
1440 -- to check for the attribute name since the return type of an
1441 -- attribute is never a remote type.
1447 then
1448 declare
1456 begin
1457 -- Check that Typ is a fat pointer with a reference to a RAS as
1458 -- original access type.
1460 if
1463 or else
1467 then
1468 -- Prefix (N) must statically denote a remote subprogram
1469 -- declared in a package specification.
1486 or else
1488 then
1490 Error_Msg_N
1492 N);
1499 then
1500 Check_Subtype_Conformant
1502 Old_Id => Designated_Type
1522 then
1527 -- Return if already analyzed
1533 -- Return if type = Any_Type (previous error encountered)
1542 -- If not overloaded, then we know the type, and all that needs doing
1543 -- is to check that this type is compatible with the context.
1549 -- In the overloaded case, we must select the interpretation that
1550 -- is compatible with the context (i.e. the type passed to Resolve)
1552 else
1555 -- Loop through possible interpretations
1559 -- We are only interested in interpretations that are compatible
1560 -- with the expected type, any other interpretations are ignored
1564 -- First matching interpretation
1572 -- Matching intepretation that is not the first, maybe an
1573 -- error, but there are some cases where preference rules are
1574 -- used to choose between the two possibilities. These and
1575 -- some more obscure cases are handled in Disambiguate.
1577 else
1583 -- Before we issue an ambiguity complaint, check for
1584 -- the case of a subprogram call where at least one
1585 -- of the arguments is Any_Type, and if so, suppress
1586 -- the message, since it is a cascaded error.
1590 then
1591 declare
1595 begin
1606 Write_Eol;
1619 then
1624 then
1628 -- Not that special case, so issue message using the
1629 -- flag Ambiguous to control printing of the header
1630 -- message only at the start of an ambiguous set.
1633 Error_Msg_NE
1636 Error_Msg_N
1644 -- Disambiguation has succeeded. Skip the remaining
1645 -- interpretations.
1646 else
1656 -- We have a matching interpretation, Expr_Type is the
1657 -- type from this interpretation, and Seen is the entity.
1659 -- For an operator, just set the entity name. The type will
1660 -- be set by the specific operator resolution routine.
1669 -- For an explicit dereference, attribute reference, range,
1670 -- short-circuit form (which is not an operator node),
1671 -- or a call with a name that is an explicit dereference,
1672 -- there is nothing to be done at this point.
1683 then
1686 -- For procedure or function calls, set the type of the
1687 -- name, and also the entity pointer for the prefix
1693 then
1700 then
1705 -- For all other cases, just set the type of the Name
1707 else
1711 -- Here if interpetation is incompatible with context type
1713 else
1716 Write_Eol;
1720 -- Move to next interpretation
1728 -- At this stage Found indicates whether or not an acceptable
1729 -- interpretation exists. If not, then we have an error, except
1730 -- that if the context is Any_Type as a result of some other error,
1731 -- then we suppress the error report.
1736 -- If type we are looking for is Void, then this is the
1737 -- procedure call case, and the error is simply that what
1738 -- we gave is not a procedure name (we think of procedure
1739 -- calls as expressions with types internally, but the user
1740 -- doesn't think of them this way!)
1746 -- Otherwise we do have a subexpression with the wrong type
1748 -- Check for the case of an allocator which uses an access
1749 -- type instead of the designated type. This is a common
1750 -- error and we specialize the message, posting an error
1751 -- on the operand of the allocator, complaining that we
1752 -- expected the designated type of the allocator.
1758 then
1762 -- Check for view mismatch on Null in instances, for
1763 -- which the view-swapping mechanism has no identifier.
1769 then
1774 -- Check for an aggregate. Sometimes we can get bogus
1775 -- aggregates from misuse of parentheses, and we are
1776 -- about to complain about the aggregate without even
1777 -- looking inside it.
1779 -- Instead, if we have an aggregate of type Any_Composite,
1780 -- then analyze and resolve the component fields, and then
1781 -- only issue another message if we get no errors doing
1782 -- this (otherwise assume that the errors in the aggregate
1783 -- caused the problem).
1787 then
1789 -- Disable expansion in any case. If there is a type mismatch
1790 -- it may be fatal to try to expand the aggregate. The flag
1791 -- would otherwise be set to false when the error is posted.
1795 declare
1797 -- Check one aggregate, and set Found to True if we
1798 -- have a definite error in any of its elements
1801 -- Check one element of aggregate and set Found to
1802 -- True if we definitely have an error in the element.
1807 begin
1826 begin
1827 -- If we have a nested aggregate, go inside it (to
1828 -- attempt a naked analyze-resolve of the aggregate
1829 -- can cause undesirable cascaded errors). Do not
1830 -- resolve expression if it needs a type from context,
1831 -- as for integer * fixed expression.
1836 else
1841 then
1851 begin
1856 -- If an error message was issued already, Found got reset
1857 -- to True, so if it is still False, issue the standard
1858 -- Wrong_Type message.
1863 then
1869 declare
1873 begin
1887 else
1890 else
1896 Resolution_Failed;
1899 -- Test if we have more than one interpretation for the context
1902 Resolution_Failed;
1905 -- Here we have an acceptable interpretation for the context
1907 else
1908 -- A user-defined operator is tranformed into a function call at
1909 -- this point, so that further processing knows that operators are
1910 -- really operators (i.e. are predefined operators). User-defined
1911 -- operators that are intrinsic are just renamings of the predefined
1912 -- ones, and need not be turned into calls either, but if they rename
1913 -- a different operator, we must transform the node accordingly.
1914 -- Instantiations of Unchecked_Conversion are intrinsic but are
1915 -- treated as functions, even if given an operator designator.
1920 then
1930 -- Propagate type information and normalize tree for various
1931 -- predefined operations. If the context only imposes a class of
1932 -- types, rather than a specific type, propagate the actual type
1933 -- downward.
1940 then
1943 -- Any_Fixed is legal in a real context only if a specific
1944 -- fixed point type is imposed. If Norman Cohen can be
1945 -- confused by this, it deserves a separate message.
1949 then
1958 when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
1960 when N_Allocator => Resolve_Allocator (N, Ctx_Type);
1962 when N_And_Then | N_Or_Else
1963 => Resolve_Short_Circuit (N, Ctx_Type);
1965 when N_Attribute_Reference
1966 => Resolve_Attribute (N, Ctx_Type);
1968 when N_Character_Literal
1969 => Resolve_Character_Literal (N, Ctx_Type);
1971 when N_Conditional_Expression
1972 => Resolve_Conditional_Expression (N, Ctx_Type);
1974 when N_Expanded_Name
1975 => Resolve_Entity_Name (N, Ctx_Type);
1977 when N_Extension_Aggregate
1978 => Resolve_Extension_Aggregate (N, Ctx_Type);
1980 when N_Explicit_Dereference
1981 => Resolve_Explicit_Dereference (N, Ctx_Type);
1983 when N_Function_Call
1984 => Resolve_Call (N, Ctx_Type);
1986 when N_Identifier
1987 => Resolve_Entity_Name (N, Ctx_Type);
1989 when N_In | N_Not_In
1990 => Resolve_Membership_Op (N, Ctx_Type);
1992 when N_Indexed_Component
1993 => Resolve_Indexed_Component (N, Ctx_Type);
1995 when N_Integer_Literal
1996 => Resolve_Integer_Literal (N, Ctx_Type);
1998 when N_Null => Resolve_Null (N, Ctx_Type);
2000 when N_Op_And | N_Op_Or | N_Op_Xor
2001 => Resolve_Logical_Op (N, Ctx_Type);
2003 when N_Op_Eq | N_Op_Ne
2004 => Resolve_Equality_Op (N, Ctx_Type);
2006 when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
2007 => Resolve_Comparison_Op (N, Ctx_Type);
2009 when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
2011 when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
2012 N_Op_Divide | N_Op_Mod | N_Op_Rem
2014 => Resolve_Arithmetic_Op (N, Ctx_Type);
2016 when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
2018 when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
2020 when N_Op_Plus | N_Op_Minus | N_Op_Abs
2021 => Resolve_Unary_Op (N, Ctx_Type);
2023 when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
2025 when N_Procedure_Call_Statement
2026 => Resolve_Call (N, Ctx_Type);
2028 when N_Operator_Symbol
2029 => Resolve_Operator_Symbol (N, Ctx_Type);
2031 when N_Qualified_Expression
2032 => Resolve_Qualified_Expression (N, Ctx_Type);
2034 when N_Raise_xxx_Error
2035 => Set_Etype (N, Ctx_Type);
2037 when N_Range => Resolve_Range (N, Ctx_Type);
2039 when N_Real_Literal
2040 => Resolve_Real_Literal (N, Ctx_Type);
2042 when N_Reference => Resolve_Reference (N, Ctx_Type);
2044 when N_Selected_Component
2045 => Resolve_Selected_Component (N, Ctx_Type);
2047 when N_Slice => Resolve_Slice (N, Ctx_Type);
2049 when N_String_Literal
2050 => Resolve_String_Literal (N, Ctx_Type);
2052 when N_Subprogram_Info
2053 => Resolve_Subprogram_Info (N, Ctx_Type);
2055 when N_Type_Conversion
2056 => Resolve_Type_Conversion (N, Ctx_Type);
2058 when N_Unchecked_Expression =>
2059 Resolve_Unchecked_Expression (N, Ctx_Type);
2061 when N_Unchecked_Type_Conversion =>
2062 Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
2064 end case;
2066 -- If the subexpression was replaced by a non-subexpression, then
2067 -- all we do is to expand it. The only legitimate case we know of
2068 -- is converting procedure call statement to entry call statements,
2069 -- but there may be others, so we are making this test general.
2071 if Nkind (N) not in N_Subexpr then
2072 Debug_A_Exit ("resolving ", N, " (done)");
2073 Expand (N);
2074 return;
2075 end if;
2077 -- The expression is definitely NOT overloaded at this point, so
2078 -- we reset the Is_Overloaded flag to avoid any confusion when
2079 -- reanalyzing the node.
2081 Set_Is_Overloaded (N, False);
2083 -- Freeze expression type, entity if it is a name, and designated
2084 -- type if it is an allocator (RM 13.14(9,10)).
2086 -- Now that the resolution of the type of the node is complete,
2087 -- and we did not detect an error, we can expand this node. We
2088 -- skip the expand call if we are in a default expression, see
2089 -- section "Handling of Default Expressions" in Sem spec.
2091 Debug_A_Exit ("resolving ", N, " (done)");
2093 -- We unconditionally freeze the expression, even if we are in
2094 -- default expression mode (the Freeze_Expression routine tests
2095 -- this flag and only freezes static types if it is set).
2097 Freeze_Expression (N);
2099 -- Now we can do the expansion
2101 Expand (N);
2102 end if;
2104 end Resolve;
2106 -- Version with check(s) suppressed
2108 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
2109 begin
2110 if Suppress = All_Checks then
2111 declare
2112 Svg : constant Suppress_Record := Scope_Suppress;
2114 begin
2115 Scope_Suppress := (others => True);
2116 Resolve (N, Typ);
2117 Scope_Suppress := Svg;
2118 end;
2120 else
2121 declare
2122 Svg : constant Boolean := Get_Scope_Suppress (Suppress);
2124 begin
2125 Set_Scope_Suppress (Suppress, True);
2126 Resolve (N, Typ);
2127 Set_Scope_Suppress (Suppress, Svg);
2128 end;
2129 end if;
2130 end Resolve;
2132 ---------------------
2133 -- Resolve_Actuals --
2134 ---------------------
2136 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
2137 Loc : constant Source_Ptr := Sloc (N);
2138 A : Node_Id;
2139 F : Entity_Id;
2140 A_Typ : Entity_Id;
2141 F_Typ : Entity_Id;
2142 Prev : Node_Id := Empty;
2144 procedure Insert_Default;
2145 -- If the actual is missing in a call, insert in the actuals list
2146 -- an instance of the default expression. The insertion is always
2147 -- a named association.
2149 --------------------
2150 -- Insert_Default --
2151 --------------------
2153 procedure Insert_Default is
2154 Actval : Node_Id;
2155 Assoc : Node_Id;
2157 begin
2158 -- Note that we do a full New_Copy_Tree, so that any associated
2159 -- Itypes are properly copied. This may not be needed any more,
2160 -- but it does no harm as a safety measure! Defaults of a generic
2161 -- formal may be out of bounds of the corresponding actual (see
2162 -- cc1311b) and an additional check may be required.
2164 if Present (Default_Value (F)) then
2166 Actval := New_Copy_Tree (Default_Value (F),
2167 New_Scope => Current_Scope, New_Sloc => Loc);
2169 if Is_Concurrent_Type (Scope (Nam))
2170 and then Has_Discriminants (Scope (Nam))
2171 then
2172 Replace_Actual_Discriminants (N, Actval);
2173 end if;
2175 if Is_Overloadable (Nam)
2176 and then Present (Alias (Nam))
2177 then
2178 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
2179 and then not Is_Tagged_Type (Etype (F))
2180 then
2181 -- If default is a real literal, do not introduce a
2182 -- conversion whose effect may depend on the run-time
2183 -- size of universal real.
2185 if Nkind (Actval) = N_Real_Literal then
2186 Set_Etype (Actval, Base_Type (Etype (F)));
2187 else
2188 Actval := Unchecked_Convert_To (Etype (F), Actval);
2189 end if;
2190 end if;
2192 if Is_Scalar_Type (Etype (F)) then
2193 Enable_Range_Check (Actval);
2194 end if;
2196 Set_Parent (Actval, N);
2197 Analyze_And_Resolve (Actval, Etype (Actval));
2198 else
2199 Set_Parent (Actval, N);
2201 -- Resolve aggregates with their base type, to avoid scope
2202 -- anomalies: the subtype was first built in the suprogram
2203 -- declaration, and the current call may be nested.
2205 if Nkind (Actval) = N_Aggregate
2206 and then Has_Discriminants (Etype (Actval))
2207 then
2208 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2209 else
2210 Analyze_And_Resolve (Actval, Etype (Actval));
2211 end if;
2212 end if;
2214 -- If default is a tag indeterminate function call, propagate
2215 -- tag to obtain proper dispatching.
2217 if Is_Controlling_Formal (F)
2218 and then Nkind (Default_Value (F)) = N_Function_Call
2219 then
2220 Set_Is_Controlling_Actual (Actval);
2221 end if;
2223 else
2224 -- Missing argument in call, nothing to insert.
2225 return;
2226 end if;
2228 -- If the default expression raises constraint error, then just
2229 -- silently replace it with an N_Raise_Constraint_Error node,
2230 -- since we already gave the warning on the subprogram spec.
2232 if Raises_Constraint_Error (Actval) then
2233 Rewrite (Actval,
2234 Make_Raise_Constraint_Error (Loc,
2235 Reason => CE_Range_Check_Failed));
2236 Set_Raises_Constraint_Error (Actval);
2237 Set_Etype (Actval, Etype (F));
2238 end if;
2240 Assoc :=
2241 Make_Parameter_Association (Loc,
2242 Explicit_Actual_Parameter => Actval,
2243 Selector_Name => Make_Identifier (Loc, Chars (F)));
2245 -- Case of insertion is first named actual
2247 if No (Prev) or else
2248 Nkind (Parent (Prev)) /= N_Parameter_Association
2249 then
2250 Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
2251 Set_First_Named_Actual (N, Actval);
2253 if No (Prev) then
2254 if not Present (Parameter_Associations (N)) then
2255 Set_Parameter_Associations (N, New_List (Assoc));
2256 else
2257 Append (Assoc, Parameter_Associations (N));
2258 end if;
2260 else
2261 Insert_After (Prev, Assoc);
2262 end if;
2264 -- Case of insertion is not first named actual
2266 else
2267 Set_Next_Named_Actual
2268 (Assoc, Next_Named_Actual (Parent (Prev)));
2269 Set_Next_Named_Actual (Parent (Prev), Actval);
2270 Append (Assoc, Parameter_Associations (N));
2271 end if;
2273 Mark_Rewrite_Insertion (Assoc);
2274 Mark_Rewrite_Insertion (Actval);
2276 Prev := Actval;
2277 end Insert_Default;
2279 -- Start of processing for Resolve_Actuals
2281 begin
2282 A := First_Actual (N);
2283 F := First_Formal (Nam);
2285 while Present (F) loop
2287 -- If we have an error in any actual or formal, indicated by
2288 -- a type of Any_Type, then abandon resolution attempt, and
2289 -- set result type to Any_Type.
2291 if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type)
2292 and then Total_Errors_Detected /= 0
2293 then
2294 Set_Etype (N, Any_Type);
2295 return;
2296 end if;
2298 if Present (A)
2299 and then (Nkind (Parent (A)) /= N_Parameter_Association
2300 or else
2301 Chars (Selector_Name (Parent (A))) = Chars (F))
2302 then
2303 -- If the formal is Out or In_Out, do not resolve and expand the
2304 -- conversion, because it is subsequently expanded into explicit
2305 -- temporaries and assignments. However, the object of the
2306 -- conversion can be resolved. An exception is the case of
2307 -- a tagged type conversion with a class-wide actual. In that
2308 -- case we want the tag check to occur and no temporary will
2309 -- will be needed (no representation change can occur) and
2310 -- the parameter is passed by reference, so we go ahead and
2311 -- resolve the type conversion.
2313 if Ekind (F) /= E_In_Parameter
2314 and then Nkind (A) = N_Type_Conversion
2315 and then not Is_Class_Wide_Type (Etype (Expression (A)))
2316 then
2317 if Ekind (F) = E_In_Out_Parameter
2318 and then Is_Array_Type (Etype (F))
2319 and then Has_Aliased_Components (Etype (Expression (A)))
2320 /= Has_Aliased_Components (Etype (F))
2321 then
2322 Error_Msg_N
2323 ("both component types in a view conversion must be"
2324 & " aliased, or neither", A);
2325 end if;
2327 if Conversion_OK (A)
2328 or else Valid_Conversion (A, Etype (A), Expression (A))
2329 then
2330 Resolve (Expression (A), Etype (Expression (A)));
2331 end if;
2333 else
2334 Resolve (A, Etype (F));
2335 end if;
2337 A_Typ := Etype (A);
2338 F_Typ := Etype (F);
2340 if Ekind (F) /= E_In_Parameter
2341 and then not Is_OK_Variable_For_Out_Formal (A)
2342 then
2343 -- Specialize error message for protected procedure call
2344 -- within function call of the same protected object.
2346 if Is_Entity_Name (A)
2347 and then Chars (Entity (A)) = Name_uObject
2348 and then Ekind (Current_Scope) = E_Function
2349 and then Convention (Current_Scope) = Convention_Protected
2350 and then Ekind (Nam) /= E_Function
2351 then
2352 Error_Msg_N ("within protected function, protected " &
2353 "object is constant", A);
2355 else
2356 Error_Msg_NE ("actual for& must be a variable", A, F);
2357 end if;
2358 end if;
2360 if Etype (A) = Any_Type then
2361 Set_Etype (N, Any_Type);
2362 return;
2363 end if;
2365 if Ekind (F) /= E_Out_Parameter then
2366 Check_Unset_Reference (A);
2368 if Ada_83
2369 and then Is_Entity_Name (A)
2370 and then Ekind (Entity (A)) = E_Out_Parameter
2371 then
2372 Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
2373 end if;
2374 end if;
2376 -- Apply appropriate range checks for in, out, and in-out
2377 -- parameters. Out and in-out parameters also need a separate
2378 -- check, if there is a type conversion, to make sure the return
2379 -- value meets the constraints of the variable before the
2380 -- conversion.
2382 -- Gigi looks at the check flag and uses the appropriate types.
2383 -- For now since one flag is used there is an optimization which
2384 -- might not be done in the In Out case since Gigi does not do
2385 -- any analysis. More thought required about this ???
2387 if Ekind (F) = E_In_Parameter
2388 or else Ekind (F) = E_In_Out_Parameter
2389 then
2390 if Is_Scalar_Type (Etype (A)) then
2391 Apply_Scalar_Range_Check (A, F_Typ);
2393 elsif Is_Array_Type (Etype (A)) then
2394 Apply_Length_Check (A, F_Typ);
2396 elsif Is_Record_Type (F_Typ)
2397 and then Has_Discriminants (F_Typ)
2398 and then Is_Constrained (F_Typ)
2399 and then (not Is_Derived_Type (F_Typ)
2400 or else Comes_From_Source (Nam))
2401 then
2402 Apply_Discriminant_Check (A, F_Typ);
2404 elsif Is_Access_Type (F_Typ)
2405 and then Is_Array_Type (Designated_Type (F_Typ))
2406 and then Is_Constrained (Designated_Type (F_Typ))
2407 then
2408 Apply_Length_Check (A, F_Typ);
2410 elsif Is_Access_Type (F_Typ)
2411 and then Has_Discriminants (Designated_Type (F_Typ))
2412 and then Is_Constrained (Designated_Type (F_Typ))
2413 then
2414 Apply_Discriminant_Check (A, F_Typ);
2416 else
2417 Apply_Range_Check (A, F_Typ);
2418 end if;
2419 end if;
2421 if Ekind (F) = E_Out_Parameter
2422 or else Ekind (F) = E_In_Out_Parameter
2423 then
2425 if Nkind (A) = N_Type_Conversion then
2426 if Is_Scalar_Type (A_Typ) then
2427 Apply_Scalar_Range_Check
2428 (Expression (A), Etype (Expression (A)), A_Typ);
2429 else
2430 Apply_Range_Check
2431 (Expression (A), Etype (Expression (A)), A_Typ);
2432 end if;
2434 else
2435 if Is_Scalar_Type (F_Typ) then
2436 Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
2438 elsif Is_Array_Type (F_Typ)
2439 and then Ekind (F) = E_Out_Parameter
2440 then
2441 Apply_Length_Check (A, F_Typ);
2443 else
2444 Apply_Range_Check (A, A_Typ, F_Typ);
2445 end if;
2446 end if;
2447 end if;
2449 -- An actual associated with an access parameter is implicitly
2450 -- converted to the anonymous access type of the formal and
2451 -- must satisfy the legality checks for access conversions.
2453 if Ekind (F_Typ) = E_Anonymous_Access_Type then
2454 if not Valid_Conversion (A, F_Typ, A) then
2455 Error_Msg_N
2456 ("invalid implicit conversion for access parameter", A);
2457 end if;
2458 end if;
2460 -- Check bad case of atomic/volatile argument (RM C.6(12))
2462 if Is_By_Reference_Type (Etype (F))
2463 and then Comes_From_Source (N)
2464 then
2465 if Is_Atomic_Object (A)
2466 and then not Is_Atomic (Etype (F))
2467 then
2468 Error_Msg_N
2469 ("cannot pass atomic argument to non-atomic formal",
2470 N);
2472 elsif Is_Volatile_Object (A)
2473 and then not Is_Volatile (Etype (F))
2474 then
2475 Error_Msg_N
2476 ("cannot pass volatile argument to non-volatile formal",
2477 N);
2478 end if;
2479 end if;
2481 -- Check that subprograms don't have improper controlling
2482 -- arguments (RM 3.9.2 (9))
2484 if Is_Controlling_Formal (F) then
2485 Set_Is_Controlling_Actual (A);
2486 elsif Nkind (A) = N_Explicit_Dereference then
2487 Validate_Remote_Access_To_Class_Wide_Type (A);
2488 end if;
2490 if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
2491 and then not Is_Class_Wide_Type (F_Typ)
2492 and then not Is_Controlling_Formal (F)
2493 then
2494 Error_Msg_N ("class-wide argument not allowed here!", A);
2496 if Is_Subprogram (Nam)
2497 and then Comes_From_Source (Nam)
2498 then
2499 Error_Msg_Node_2 := F_Typ;
2500 Error_Msg_NE
2501 ("& is not a primitive operation of &!", A, Nam);
2502 end if;
2504 elsif Is_Access_Type (A_Typ)
2505 and then Is_Access_Type (F_Typ)
2506 and then Ekind (F_Typ) /= E_Access_Subprogram_Type
2507 and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
2508 or else (Nkind (A) = N_Attribute_Reference
2509 and then
2510 Is_Class_Wide_Type (Etype (Prefix (A)))))
2511 and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
2512 and then not Is_Controlling_Formal (F)
2513 then
2514 Error_Msg_N
2515 ("access to class-wide argument not allowed here!", A);
2517 if Is_Subprogram (Nam)
2518 and then Comes_From_Source (Nam)
2519 then
2520 Error_Msg_Node_2 := Designated_Type (F_Typ);
2521 Error_Msg_NE
2522 ("& is not a primitive operation of &!", A, Nam);
2523 end if;
2524 end if;
2526 Eval_Actual (A);
2528 -- If it is a named association, treat the selector_name as
2529 -- a proper identifier, and mark the corresponding entity.
2531 if Nkind (Parent (A)) = N_Parameter_Association then
2532 Set_Entity (Selector_Name (Parent (A)), F);
2533 Generate_Reference (F, Selector_Name (Parent (A)));
2534 Set_Etype (Selector_Name (Parent (A)), F_Typ);
2536 end if;
2538 Prev := A;
2539 Next_Actual (A);
2541 else
2542 Insert_Default;
2543 end if;
2545 Next_Formal (F);
2546 end loop;
2548 end Resolve_Actuals;
2550 -----------------------
2551 -- Resolve_Allocator --
2552 -----------------------
2554 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
2555 E : constant Node_Id := Expression (N);
2556 Subtyp : Entity_Id;
2557 Discrim : Entity_Id;
2558 Constr : Node_Id;
2559 Disc_Exp : Node_Id;
2561 function In_Dispatching_Context return Boolean;
2562 -- If the allocator is an actual in a call, it is allowed to be
2563 -- class-wide when the context is not because it is a controlling
2564 -- actual.
2566 ----------------------------
2567 -- In_Dispatching_Context --
2568 ----------------------------
2570 function In_Dispatching_Context return Boolean is
2571 Par : constant Node_Id := Parent (N);
2573 begin
2574 return (Nkind (Par) = N_Function_Call
2575 or else Nkind (Par) = N_Procedure_Call_Statement)
2576 and then Is_Entity_Name (Name (Par))
2577 and then Is_Dispatching_Operation (Entity (Name (Par)));
2578 end In_Dispatching_Context;
2580 -- Start of processing for Resolve_Allocator
2582 begin
2583 -- Replace general access with specific type
2585 if Ekind (Etype (N)) = E_Allocator_Type then
2586 Set_Etype (N, Base_Type (Typ));
2587 end if;
2589 if Is_Abstract (Typ) then
2590 Error_Msg_N ("type of allocator cannot be abstract", N);
2591 end if;
2593 -- For qualified expression, resolve the expression using the
2594 -- given subtype (nothing to do for type mark, subtype indication)
2596 if Nkind (E) = N_Qualified_Expression then
2597 if Is_Class_Wide_Type (Etype (E))
2598 and then not Is_Class_Wide_Type (Designated_Type (Typ))
2599 and then not In_Dispatching_Context
2600 then
2601 Error_Msg_N
2602 ("class-wide allocator not allowed for this access type", N);
2603 end if;
2605 Resolve (Expression (E), Etype (E));
2606 Check_Unset_Reference (Expression (E));
2608 -- For a subtype mark or subtype indication, freeze the subtype
2610 else
2611 Freeze_Expression (E);
2613 if Is_Access_Constant (Typ) and then not No_Initialization (N) then
2614 Error_Msg_N
2615 ("initialization required for access-to-constant allocator", N);
2616 end if;
2618 -- A special accessibility check is needed for allocators that
2619 -- constrain access discriminants. The level of the type of the
2620 -- expression used to contrain an access discriminant cannot be
2621 -- deeper than the type of the allocator (in constrast to access
2622 -- parameters, where the level of the actual can be arbitrary).
2623 -- We can't use Valid_Conversion to perform this check because
2624 -- in general the type of the allocator is unrelated to the type
2625 -- of the access discriminant. Note that specialized checks are
2626 -- needed for the cases of a constraint expression which is an
2627 -- access attribute or an access discriminant.
2629 if Nkind (Original_Node (E)) = N_Subtype_Indication
2630 and then Ekind (Typ) /= E_Anonymous_Access_Type
2631 then
2632 Subtyp := Entity (Subtype_Mark (Original_Node (E)));
2634 if Has_Discriminants (Subtyp) then
2635 Discrim := First_Discriminant (Base_Type (Subtyp));
2636 Constr := First (Constraints (Constraint (Original_Node (E))));
2638 while Present (Discrim) and then Present (Constr) loop
2639 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
2640 if Nkind (Constr) = N_Discriminant_Association then
2641 Disc_Exp := Original_Node (Expression (Constr));
2642 else
2643 Disc_Exp := Original_Node (Constr);
2644 end if;
2646 if Type_Access_Level (Etype (Disc_Exp))
2647 > Type_Access_Level (Typ)
2648 then
2649 Error_Msg_N
2650 ("operand type has deeper level than allocator type",
2651 Disc_Exp);
2653 elsif Nkind (Disc_Exp) = N_Attribute_Reference
2654 and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
2655 = Attribute_Access
2656 and then Object_Access_Level (Prefix (Disc_Exp))
2657 > Type_Access_Level (Typ)
2658 then
2659 Error_Msg_N
2660 ("prefix of attribute has deeper level than"
2661 & " allocator type", Disc_Exp);
2663 -- When the operand is an access discriminant the check
2664 -- is against the level of the prefix object.
2666 elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
2667 and then Nkind (Disc_Exp) = N_Selected_Component
2668 and then Object_Access_Level (Prefix (Disc_Exp))
2669 > Type_Access_Level (Typ)
2670 then
2671 Error_Msg_N
2672 ("access discriminant has deeper level than"
2673 & " allocator type", Disc_Exp);
2674 end if;
2675 end if;
2676 Next_Discriminant (Discrim);
2677 Next (Constr);
2678 end loop;
2679 end if;
2680 end if;
2681 end if;
2683 -- Check for allocation from an empty storage pool
2685 if No_Pool_Assigned (Typ) then
2686 declare
2687 Loc : constant Source_Ptr := Sloc (N);
2689 begin
2690 Error_Msg_N ("?allocation from empty storage pool!", N);
2691 Error_Msg_N ("?Storage_Error will be raised at run time!", N);
2692 Insert_Action (N,
2693 Make_Raise_Storage_Error (Loc,
2694 Reason => SE_Empty_Storage_Pool));
2695 end;
2696 end if;
2697 end Resolve_Allocator;
2699 ---------------------------
2700 -- Resolve_Arithmetic_Op --
2701 ---------------------------
2703 -- Used for resolving all arithmetic operators except exponentiation
2705 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
2706 L : constant Node_Id := Left_Opnd (N);
2707 R : constant Node_Id := Right_Opnd (N);
2708 T : Entity_Id;
2709 TL : Entity_Id := Base_Type (Etype (L));
2710 TR : Entity_Id := Base_Type (Etype (R));
2712 B_Typ : constant Entity_Id := Base_Type (Typ);
2713 -- We do the resolution using the base type, because intermediate values
2714 -- in expressions always are of the base type, not a subtype of it.
2716 function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
2717 -- Return True iff given type is Integer or universal real/integer
2719 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
2720 -- Choose type of integer literal in fixed-point operation to conform
2721 -- to available fixed-point type. T is the type of the other operand,
2722 -- which is needed to determine the expected type of N.
2724 procedure Set_Operand_Type (N : Node_Id);
2725 -- Set operand type to T if universal
2727 function Universal_Interpretation (N : Node_Id) return Entity_Id;
2728 -- Find universal type of operand, if any.
2730 -----------------------------
2731 -- Is_Integer_Or_Universal --
2732 -----------------------------
2734 function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
2735 T : Entity_Id;
2736 Index : Interp_Index;
2737 It : Interp;
2739 begin
2740 if not Is_Overloaded (N) then
2741 T := Etype (N);
2742 return Base_Type (T) = Base_Type (Standard_Integer)
2743 or else T = Universal_Integer
2744 or else T = Universal_Real;
2745 else
2746 Get_First_Interp (N, Index, It);
2748 while Present (It.Typ) loop
2750 if Base_Type (It.Typ) = Base_Type (Standard_Integer)
2751 or else It.Typ = Universal_Integer
2752 or else It.Typ = Universal_Real
2753 then
2754 return True;
2755 end if;
2757 Get_Next_Interp (Index, It);
2758 end loop;
2759 end if;
2761 return False;
2762 end Is_Integer_Or_Universal;
2764 ----------------------------
2765 -- Set_Mixed_Mode_Operand --
2766 ----------------------------
2768 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
2769 Index : Interp_Index;
2770 It : Interp;
2772 begin
2773 if Universal_Interpretation (N) = Universal_Integer then
2775 -- A universal integer literal is resolved as standard integer
2776 -- except in the case of a fixed-point result, where we leave
2777 -- it as universal (to be handled by Exp_Fixd later on)
2779 if Is_Fixed_Point_Type (T) then
2780 Resolve (N, Universal_Integer);
2781 else
2782 Resolve (N, Standard_Integer);
2783 end if;
2785 elsif Universal_Interpretation (N) = Universal_Real
2786 and then (T = Base_Type (Standard_Integer)
2787 or else T = Universal_Integer
2788 or else T = Universal_Real)
2789 then
2790 -- A universal real can appear in a fixed-type context. We resolve
2791 -- the literal with that context, even though this might raise an
2792 -- exception prematurely (the other operand may be zero).
2794 Resolve (N, B_Typ);
2796 elsif Etype (N) = Base_Type (Standard_Integer)
2797 and then T = Universal_Real
2798 and then Is_Overloaded (N)
2799 then
2800 -- Integer arg in mixed-mode operation. Resolve with universal
2801 -- type, in case preference rule must be applied.
2803 Resolve (N, Universal_Integer);
2805 elsif Etype (N) = T
2806 and then B_Typ /= Universal_Fixed
2807 then
2808 -- Not a mixed-mode operation. Resolve with context.
2810 Resolve (N, B_Typ);
2812 elsif Etype (N) = Any_Fixed then
2814 -- N may itself be a mixed-mode operation, so use context type.
2816 Resolve (N, B_Typ);
2818 elsif Is_Fixed_Point_Type (T)
2819 and then B_Typ = Universal_Fixed
2820 and then Is_Overloaded (N)
2821 then
2822 -- Must be (fixed * fixed) operation, operand must have one
2823 -- compatible interpretation.
2825 Resolve (N, Any_Fixed);
2827 elsif Is_Fixed_Point_Type (B_Typ)
2828 and then (T = Universal_Real
2829 or else Is_Fixed_Point_Type (T))
2830 and then Is_Overloaded (N)
2831 then
2832 -- C * F(X) in a fixed context, where C is a real literal or a
2833 -- fixed-point expression. F must have either a fixed type
2834 -- interpretation or an integer interpretation, but not both.
2836 Get_First_Interp (N, Index, It);
2838 while Present (It.Typ) loop
2840 if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
2842 if Analyzed (N) then
2843 Error_Msg_N ("ambiguous operand in fixed operation", N);
2844 else
2845 Resolve (N, Standard_Integer);
2846 end if;
2848 elsif Is_Fixed_Point_Type (It.Typ) then
2850 if Analyzed (N) then
2851 Error_Msg_N ("ambiguous operand in fixed operation", N);
2852 else
2853 Resolve (N, It.Typ);
2854 end if;
2855 end if;
2857 Get_Next_Interp (Index, It);
2858 end loop;
2860 -- Reanalyze the literal with the fixed type of the context.
2862 if N = L then
2863 Set_Analyzed (R, False);
2864 Resolve (R, B_Typ);
2865 else
2866 Set_Analyzed (L, False);
2867 Resolve (L, B_Typ);
2868 end if;
2870 else
2871 Resolve (N, Etype (N));
2872 end if;
2873 end Set_Mixed_Mode_Operand;
2875 ----------------------
2876 -- Set_Operand_Type --
2877 ----------------------
2879 procedure Set_Operand_Type (N : Node_Id) is
2880 begin
2881 if Etype (N) = Universal_Integer
2882 or else Etype (N) = Universal_Real
2883 then
2884 Set_Etype (N, T);
2885 end if;
2886 end Set_Operand_Type;
2888 ------------------------------
2889 -- Universal_Interpretation --
2890 ------------------------------
2892 function Universal_Interpretation (N : Node_Id) return Entity_Id is
2893 Index : Interp_Index;
2894 It : Interp;
2896 begin
2897 if not Is_Overloaded (N) then
2899 if Etype (N) = Universal_Integer
2900 or else Etype (N) = Universal_Real
2901 then
2902 return Etype (N);
2903 else
2904 return Empty;
2905 end if;
2907 else
2908 Get_First_Interp (N, Index, It);
2910 while Present (It.Typ) loop
2912 if It.Typ = Universal_Integer
2913 or else It.Typ = Universal_Real
2914 then
2915 return It.Typ;
2916 end if;
2918 Get_Next_Interp (Index, It);
2919 end loop;
2921 return Empty;
2922 end if;
2923 end Universal_Interpretation;
2925 -- Start of processing for Resolve_Arithmetic_Op
2927 begin
2928 if Comes_From_Source (N)
2929 and then Ekind (Entity (N)) = E_Function
2930 and then Is_Imported (Entity (N))
2931 and then Present (First_Rep_Item (Entity (N)))
2932 then
2933 Resolve_Intrinsic_Operator (N, Typ);
2934 return;
2936 -- Special-case for mixed-mode universal expressions or fixed point
2937 -- type operation: each argument is resolved separately. The same
2938 -- treatment is required if one of the operands of a fixed point
2939 -- operation is universal real, since in this case we don't do a
2940 -- conversion to a specific fixed-point type (instead the expander
2941 -- takes care of the case).
2943 elsif (B_Typ = Universal_Integer
2944 or else B_Typ = Universal_Real)
2945 and then Present (Universal_Interpretation (L))
2946 and then Present (Universal_Interpretation (R))
2947 then
2948 Resolve (L, Universal_Interpretation (L));
2949 Resolve (R, Universal_Interpretation (R));
2950 Set_Etype (N, B_Typ);
2952 elsif (B_Typ = Universal_Real
2953 or else Etype (N) = Universal_Fixed
2954 or else (Etype (N) = Any_Fixed
2955 and then Is_Fixed_Point_Type (B_Typ))
2956 or else (Is_Fixed_Point_Type (B_Typ)
2957 and then (Is_Integer_Or_Universal (L)
2958 or else
2959 Is_Integer_Or_Universal (R))))
2960 and then (Nkind (N) = N_Op_Multiply or else
2961 Nkind (N) = N_Op_Divide)
2962 then
2963 if TL = Universal_Integer or else TR = Universal_Integer then
2964 Check_For_Visible_Operator (N, B_Typ);
2965 end if;
2967 -- If context is a fixed type and one operand is integer, the
2968 -- other is resolved with the type of the context.
2970 if Is_Fixed_Point_Type (B_Typ)
2971 and then (Base_Type (TL) = Base_Type (Standard_Integer)
2972 or else TL = Universal_Integer)
2973 then
2974 Resolve (R, B_Typ);
2975 Resolve (L, TL);
2977 elsif Is_Fixed_Point_Type (B_Typ)
2978 and then (Base_Type (TR) = Base_Type (Standard_Integer)
2979 or else TR = Universal_Integer)
2980 then
2981 Resolve (L, B_Typ);
2982 Resolve (R, TR);
2984 else
2985 Set_Mixed_Mode_Operand (L, TR);
2986 Set_Mixed_Mode_Operand (R, TL);
2987 end if;
2989 if Etype (N) = Universal_Fixed
2990 or else Etype (N) = Any_Fixed
2991 then
2992 if B_Typ = Universal_Fixed
2993 and then Nkind (Parent (N)) /= N_Type_Conversion
2994 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
2995 then
2996 Error_Msg_N
2997 ("type cannot be determined from context!", N);
2998 Error_Msg_N
3001 Set_Etype (L, Any_Type);
3002 Set_Etype (R, Any_Type);
3004 else
3005 if Ada_83
3006 and then Etype (N) = Universal_Fixed
3007 and then Nkind (Parent (N)) /= N_Type_Conversion
3008 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
3009 then
3010 Error_Msg_N
3011 ("(Ada 83) fixed-point operation " &
3012 "needs explicit conversion",
3013 N);
3014 end if;
3016 Set_Etype (N, B_Typ);
3017 end if;
3019 elsif Is_Fixed_Point_Type (B_Typ)
3020 and then (Is_Integer_Or_Universal (L)
3021 or else Nkind (L) = N_Real_Literal
3022 or else Nkind (R) = N_Real_Literal
3023 or else
3024 Is_Integer_Or_Universal (R))
3025 then
3026 Set_Etype (N, B_Typ);
3028 elsif Etype (N) = Any_Fixed then
3030 -- If no previous errors, this is only possible if one operand
3031 -- is overloaded and the context is universal. Resolve as such.
3033 Set_Etype (N, B_Typ);
3034 end if;
3036 else
3037 if (TL = Universal_Integer or else TL = Universal_Real)
3038 and then (TR = Universal_Integer or else TR = Universal_Real)
3039 then
3040 Check_For_Visible_Operator (N, B_Typ);
3041 end if;
3043 -- If the context is Universal_Fixed and the operands are also
3044 -- universal fixed, this is an error, unless there is only one
3045 -- applicable fixed_point type (usually duration).
3047 if B_Typ = Universal_Fixed
3048 and then Etype (L) = Universal_Fixed
3049 then
3050 T := Unique_Fixed_Point_Type (N);
3052 if T = Any_Type then
3053 Set_Etype (N, T);
3054 return;
3055 else
3056 Resolve (L, T);
3057 Resolve (R, T);
3058 end if;
3060 else
3061 Resolve (L, B_Typ);
3062 Resolve (R, B_Typ);
3063 end if;
3065 -- If one of the arguments was resolved to a non-universal type.
3066 -- label the result of the operation itself with the same type.
3067 -- Do the same for the universal argument, if any.
3069 T := Intersect_Types (L, R);
3070 Set_Etype (N, Base_Type (T));
3071 Set_Operand_Type (L);
3072 Set_Operand_Type (R);
3073 end if;
3075 Generate_Operator_Reference (N);
3076 Eval_Arithmetic_Op (N);
3078 -- Set overflow and division checking bit. Much cleverer code needed
3079 -- here eventually and perhaps the Resolve routines should be separated
3080 -- for the various arithmetic operations, since they will need
3081 -- different processing. ???
3083 if Nkind (N) in N_Op then
3084 if not Overflow_Checks_Suppressed (Etype (N)) then
3085 Set_Do_Overflow_Check (N);
3086 end if;
3088 if (Nkind (N) = N_Op_Divide
3089 or else Nkind (N) = N_Op_Rem
3090 or else Nkind (N) = N_Op_Mod)
3091 and then not Division_Checks_Suppressed (Etype (N))
3092 then
3093 Set_Do_Division_Check (N);
3094 end if;
3095 end if;
3097 Check_Unset_Reference (L);
3098 Check_Unset_Reference (R);
3100 end Resolve_Arithmetic_Op;
3102 ------------------
3103 -- Resolve_Call --
3104 ------------------
3106 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
3107 Loc : constant Source_Ptr := Sloc (N);
3108 Subp : constant Node_Id := Name (N);
3109 Nam : Entity_Id;
3110 I : Interp_Index;
3111 It : Interp;
3112 Norm_OK : Boolean;
3113 Scop : Entity_Id;
3115 begin
3116 -- The context imposes a unique interpretation with type Typ on
3117 -- a procedure or function call. Find the entity of the subprogram
3118 -- that yields the expected type, and propagate the corresponding
3119 -- formal constraints on the actuals. The caller has established
3120 -- that an interpretation exists, and emitted an error if not unique.
3122 -- First deal with the case of a call to an access-to-subprogram,
3123 -- dereference made explicit in Analyze_Call.
3125 if Ekind (Etype (Subp)) = E_Subprogram_Type then
3127 if not Is_Overloaded (Subp) then
3128 Nam := Etype (Subp);
3130 else
3131 -- Find the interpretation whose type (a subprogram type)
3132 -- has a return type that is compatible with the context.
3133 -- Analysis of the node has established that one exists.
3135 Get_First_Interp (Subp, I, It);
3136 Nam := Empty;
3138 while Present (It.Typ) loop
3140 if Covers (Typ, Etype (It.Typ)) then
3141 Nam := It.Typ;
3142 exit;
3143 end if;
3145 Get_Next_Interp (I, It);
3146 end loop;
3148 if No (Nam) then
3149 raise Program_Error;
3150 end if;
3151 end if;
3153 -- If the prefix is not an entity, then resolve it
3155 if not Is_Entity_Name (Subp) then
3156 Resolve (Subp, Nam);
3157 end if;
3159 -- If this is a procedure call which is really an entry call, do
3160 -- the conversion of the procedure call to an entry call. Protected
3161 -- operations use the same circuitry because the name in the call
3162 -- can be an arbitrary expression with special resolution rules.
3164 elsif Nkind (Subp) = N_Selected_Component
3165 or else Nkind (Subp) = N_Indexed_Component
3166 or else (Is_Entity_Name (Subp)
3167 and then Ekind (Entity (Subp)) = E_Entry)
3168 then
3169 Resolve_Entry_Call (N, Typ);
3170 Check_Elab_Call (N);
3171 return;
3173 -- Normal subprogram call with name established in Resolve
3175 elsif not (Is_Type (Entity (Subp))) then
3176 Nam := Entity (Subp);
3177 Set_Entity_With_Style_Check (Subp, Nam);
3178 Generate_Reference (Nam, Subp);
3180 -- Otherwise we must have the case of an overloaded call
3182 else
3183 pragma Assert (Is_Overloaded (Subp));
3184 Nam := Empty; -- We know that it will be assigned in loop below.
3186 Get_First_Interp (Subp, I, It);
3188 while Present (It.Typ) loop
3189 if Covers (Typ, It.Typ) then
3190 Nam := It.Nam;
3191 Set_Entity_With_Style_Check (Subp, Nam);
3192 Generate_Reference (Nam, Subp);
3193 exit;
3194 end if;
3196 Get_Next_Interp (I, It);
3197 end loop;
3198 end if;
3200 -- Check that a call to Current_Task does not occur in an entry body
3202 if Is_RTE (Nam, RE_Current_Task) then
3203 declare
3204 P : Node_Id;
3206 begin
3207 P := N;
3208 loop
3209 P := Parent (P);
3210 exit when No (P);
3212 if Nkind (P) = N_Entry_Body then
3213 Error_Msg_NE
3215 N, Nam);
3216 exit;
3217 end if;
3218 end loop;
3219 end;
3220 end if;
3222 -- Check that a procedure call does not occur in the context
3223 -- of the entry call statement of a conditional or timed
3224 -- entry call. Note that the case of a call to a subprogram
3225 -- renaming of an entry will also be rejected. The test
3226 -- for N not being an N_Entry_Call_Statement is defensive,
3227 -- covering the possibility that the processing of entry
3228 -- calls might reach this point due to later modifications
3229 -- of the code above.
3231 if Nkind (Parent (N)) = N_Entry_Call_Alternative
3232 and then Nkind (N) /= N_Entry_Call_Statement
3233 and then Entry_Call_Statement (Parent (N)) = N
3234 then
3236 end if;
3238 -- Freeze the subprogram name if not in default expression. Note
3239 -- that we freeze procedure calls as well as function calls.
3240 -- Procedure calls are not frozen according to the rules (RM
3241 -- 13.14(14)) because it is impossible to have a procedure call to
3242 -- a non-frozen procedure in pure Ada, but in the code that we
3243 -- generate in the expander, this rule needs extending because we
3244 -- can generate procedure calls that need freezing.
3246 if Is_Entity_Name (Subp) and then not In_Default_Expression then
3247 Freeze_Expression (Subp);
3248 end if;
3250 -- For a predefined operator, the type of the result is the type
3251 -- imposed by context, except for a predefined operation on universal
3252 -- fixed. Otherwise The type of the call is the type returned by the
3253 -- subprogram being called.
3255 if Is_Predefined_Op (Nam) then
3257 if Etype (N) /= Universal_Fixed then
3258 Set_Etype (N, Typ);
3259 end if;
3261 -- If the subprogram returns an array type, and the context
3262 -- requires the component type of that array type, the node is
3263 -- really an indexing of the parameterless call. Resolve as such.
3265 elsif Needs_No_Actuals (Nam)
3266 and then
3267 ((Is_Array_Type (Etype (Nam))
3268 and then Covers (Typ, Component_Type (Etype (Nam))))
3269 or else (Is_Access_Type (Etype (Nam))
3270 and then Is_Array_Type (Designated_Type (Etype (Nam)))
3271 and then
3272 Covers (Typ,
3273 Component_Type (Designated_Type (Etype (Nam))))))
3274 then
3275 declare
3276 Index_Node : Node_Id;
3278 begin
3280 if Component_Type (Etype (Nam)) /= Any_Type then
3281 Index_Node :=
3282 Make_Indexed_Component (Loc,
3283 Prefix =>
3284 Make_Function_Call (Loc,
3285 Name => New_Occurrence_Of (Nam, Loc)),
3286 Expressions => Parameter_Associations (N));
3288 -- Since we are correcting a node classification error made by
3289 -- the parser, we call Replace rather than Rewrite.
3291 Replace (N, Index_Node);
3292 Set_Etype (Prefix (N), Etype (Nam));
3293 Set_Etype (N, Typ);
3294 Resolve_Indexed_Component (N, Typ);
3295 Check_Elab_Call (Prefix (N));
3296 end if;
3298 return;
3299 end;
3301 else
3302 Set_Etype (N, Etype (Nam));
3303 end if;
3305 -- In the case where the call is to an overloaded subprogram, Analyze
3306 -- calls Normalize_Actuals once per overloaded subprogram. Therefore in
3307 -- such a case Normalize_Actuals needs to be called once more to order
3308 -- the actuals correctly. Otherwise the call will have the ordering
3309 -- given by the last overloaded subprogram whether this is the correct
3310 -- one being called or not.
3312 if Is_Overloaded (Subp) then
3313 Normalize_Actuals (N, Nam, False, Norm_OK);
3314 pragma Assert (Norm_OK);
3315 end if;
3317 -- In any case, call is fully resolved now. Reset Overload flag, to
3318 -- prevent subsequent overload resolution if node is analyzed again
3320 Set_Is_Overloaded (Subp, False);
3321 Set_Is_Overloaded (N, False);
3323 -- If we are calling the current subprogram from immediately within
3324 -- its body, then that is the case where we can sometimes detect
3325 -- cases of infinite recursion statically. Do not try this in case
3326 -- restriction No_Recursion is in effect anyway.
3328 Scop := Current_Scope;
3330 if Nam = Scop
3331 and then not Restrictions (No_Recursion)
3332 and then Check_Infinite_Recursion (N)
3333 then
3334 -- Here we detected and flagged an infinite recursion, so we do
3335 -- not need to test the case below for further warnings.
3337 null;
3339 -- If call is to immediately containing subprogram, then check for
3340 -- the case of a possible run-time detectable infinite recursion.
3342 else
3343 while Scop /= Standard_Standard loop
3344 if Nam = Scop then
3345 -- Although in general recursion is not statically checkable,
3346 -- the case of calling an immediately containing subprogram
3347 -- is easy to catch.
3349 Check_Restriction (No_Recursion, N);
3351 -- If the recursive call is to a parameterless procedure, then
3352 -- even if we can't statically detect infinite recursion, this
3353 -- is pretty suspicious, and we output a warning. Furthermore,
3354 -- we will try later to detect some cases here at run time by
3355 -- expanding checking code (see Detect_Infinite_Recursion in
3356 -- package Exp_Ch6).
3357 -- If the recursive call is within a handler we do not emit a
3358 -- warning, because this is a common idiom: loop until input
3359 -- is correct, catch illegal input in handler and restart.
3361 if No (First_Formal (Nam))
3362 and then Etype (Nam) = Standard_Void_Type
3363 and then not Error_Posted (N)
3364 and then Nkind (Parent (N)) /= N_Exception_Handler
3365 then
3366 Set_Has_Recursive_Call (Nam);
3369 end if;
3371 exit;
3372 end if;
3374 Scop := Scope (Scop);
3375 end loop;
3376 end if;
3378 -- If subprogram name is a predefined operator, it was given in
3379 -- functional notation. Replace call node with operator node, so
3380 -- that actuals can be resolved appropriately.
3382 if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
3383 Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
3384 return;
3386 elsif Present (Alias (Nam))
3387 and then Is_Predefined_Op (Alias (Nam))
3388 then
3389 Resolve_Actuals (N, Nam);
3390 Make_Call_Into_Operator (N, Typ, Alias (Nam));
3391 return;
3392 end if;
3394 -- Create a transient scope if the resulting type requires it.
3395 -- There are 3 notable exceptions: in init_procs, the transient scope
3396 -- overhead is not needed and even incorrect due to the actual expansion
3397 -- of adjust calls; the second case is enumeration literal pseudo calls,
3398 -- the other case is intrinsic subprograms (Unchecked_Conversion and
3399 -- source information functions) that do not use the secondary stack
3400 -- even though the return type is unconstrained.
3402 -- If this is an initialization call for a type whose initialization
3403 -- uses the secondary stack, we also need to create a transient scope
3404 -- for it, precisely because we will not do it within the init_proc
3405 -- itself.
3407 if Expander_Active
3408 and then Is_Type (Etype (Nam))
3409 and then Requires_Transient_Scope (Etype (Nam))
3410 and then Ekind (Nam) /= E_Enumeration_Literal
3411 and then not Within_Init_Proc
3412 and then not Is_Intrinsic_Subprogram (Nam)
3413 then
3414 Establish_Transient_Scope
3415 (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
3417 elsif Chars (Nam) = Name_uInit_Proc
3418 and then not Within_Init_Proc
3419 then
3420 Check_Initialization_Call (N, Nam);
3421 end if;
3423 -- A protected function cannot be called within the definition of the
3424 -- enclosing protected type.
3426 if Is_Protected_Type (Scope (Nam))
3427 and then In_Open_Scopes (Scope (Nam))
3428 and then not Has_Completion (Scope (Nam))
3429 then
3430 Error_Msg_NE
3432 end if;
3434 -- Propagate interpretation to actuals, and add default expressions
3435 -- where needed.
3437 if Present (First_Formal (Nam)) then
3438 Resolve_Actuals (N, Nam);
3440 -- Overloaded literals are rewritten as function calls, for
3441 -- purpose of resolution. After resolution, we can replace
3442 -- the call with the literal itself.
3444 elsif Ekind (Nam) = E_Enumeration_Literal then
3445 Copy_Node (Subp, N);
3446 Resolve_Entity_Name (N, Typ);
3448 -- Avoid validation, since it is a static function call.
3450 return;
3451 end if;
3453 -- If the subprogram is a primitive operation, check whether or not
3454 -- it is a correct dispatching call.
3456 if Is_Overloadable (Nam)
3457 and then Is_Dispatching_Operation (Nam)
3458 then
3459 Check_Dispatching_Call (N);
3461 elsif Is_Abstract (Nam)
3462 and then not In_Instance
3463 then
3465 end if;
3467 if Is_Intrinsic_Subprogram (Nam) then
3468 Check_Intrinsic_Call (N);
3469 end if;
3471 -- If we fall through we definitely have a non-static call
3473 Check_Elab_Call (N);
3475 end Resolve_Call;
3477 -------------------------------
3478 -- Resolve_Character_Literal --
3479 -------------------------------
3481 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
3482 B_Typ : constant Entity_Id := Base_Type (Typ);
3483 C : Entity_Id;
3485 begin
3486 -- Verify that the character does belong to the type of the context
3488 Set_Etype (N, B_Typ);
3489 Eval_Character_Literal (N);
3491 -- Wide_Character literals must always be defined, since the set of
3492 -- wide character literals is complete, i.e. if a character literal
3493 -- is accepted by the parser, then it is OK for wide character.
3495 if Root_Type (B_Typ) = Standard_Wide_Character then
3496 return;
3498 -- Always accept character literal for type Any_Character, which
3499 -- occurs in error situations and in comparisons of literals, both
3500 -- of which should accept all literals.
3502 elsif B_Typ = Any_Character then
3503 return;
3505 -- For Standard.Character or a type derived from it, check that
3506 -- the literal is in range
3508 elsif Root_Type (B_Typ) = Standard_Character then
3509 if In_Character_Range (Char_Literal_Value (N)) then
3510 return;
3511 end if;
3513 -- If the entity is already set, this has already been resolved in
3514 -- a generic context, or comes from expansion. Nothing else to do.
3516 elsif Present (Entity (N)) then
3517 return;
3519 -- Otherwise we have a user defined character type, and we can use
3520 -- the standard visibility mechanisms to locate the referenced entity
3522 else
3523 C := Current_Entity (N);
3525 while Present (C) loop
3526 if Etype (C) = B_Typ then
3527 Set_Entity_With_Style_Check (N, C);
3528 Generate_Reference (C, N);
3529 return;
3530 end if;
3532 C := Homonym (C);
3533 end loop;
3534 end if;
3536 -- If we fall through, then the literal does not match any of the
3537 -- entries of the enumeration type. This isn't just a constraint
3538 -- error situation, it is an illegality (see RM 4.2).
3540 Error_Msg_NE
3543 end Resolve_Character_Literal;
3545 ---------------------------
3546 -- Resolve_Comparison_Op --
3547 ---------------------------
3549 -- Context requires a boolean type, and plays no role in resolution.
3550 -- Processing identical to that for equality operators.
3552 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
3553 L : constant Node_Id := Left_Opnd (N);
3554 R : constant Node_Id := Right_Opnd (N);
3555 T : Entity_Id;
3557 begin
3558 -- If this is an intrinsic operation which is not predefined, use
3559 -- the types of its declared arguments to resolve the possibly
3560 -- overloaded operands. Otherwise the operands are unambiguous and
3561 -- specify the expected type.
3563 if Scope (Entity (N)) /= Standard_Standard then
3564 T := Etype (First_Entity (Entity (N)));
3565 else
3566 T := Find_Unique_Type (L, R);
3568 if T = Any_Fixed then
3569 T := Unique_Fixed_Point_Type (L);
3570 end if;
3571 end if;
3573 Set_Etype (N, Typ);
3574 Generate_Reference (T, N, ' ');
3576 if T /= Any_Type then
3578 if T = Any_String
3579 or else T = Any_Composite
3580 or else T = Any_Character
3581 then
3582 if T = Any_Character then
3583 Ambiguous_Character (L);
3584 else
3586 end if;
3588 Set_Etype (N, Any_Type);
3589 return;
3591 else
3592 if Comes_From_Source (N)
3593 and then Has_Unchecked_Union (T)
3594 then
3595 Error_Msg_N
3597 end if;
3599 Resolve (L, T);
3600 Resolve (R, T);
3601 Check_Unset_Reference (L);
3602 Check_Unset_Reference (R);
3603 Generate_Operator_Reference (N);
3604 Eval_Relational_Op (N);
3605 end if;
3606 end if;
3608 end Resolve_Comparison_Op;
3610 ------------------------------------
3611 -- Resolve_Conditional_Expression --
3612 ------------------------------------
3614 procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
3615 Condition : constant Node_Id := First (Expressions (N));
3616 Then_Expr : constant Node_Id := Next (Condition);
3617 Else_Expr : constant Node_Id := Next (Then_Expr);
3619 begin
3620 Resolve (Condition, Standard_Boolean);
3621 Resolve (Then_Expr, Typ);
3622 Resolve (Else_Expr, Typ);
3624 Set_Etype (N, Typ);
3625 Eval_Conditional_Expression (N);
3626 end Resolve_Conditional_Expression;
3628 -----------------------------------------
3629 -- Resolve_Discrete_Subtype_Indication --
3630 -----------------------------------------
3632 procedure Resolve_Discrete_Subtype_Indication
3633 (N : Node_Id;
3634 Typ : Entity_Id)
3635 is
3636 R : Node_Id;
3637 S : Entity_Id;
3639 begin
3640 Analyze (Subtype_Mark (N));
3641 S := Entity (Subtype_Mark (N));
3643 if Nkind (Constraint (N)) /= N_Range_Constraint then
3645 Set_Etype (N, Any_Type);
3647 else
3648 R := Range_Expression (Constraint (N));
3650 if R = Error then
3651 return;
3652 end if;
3654 Analyze (R);
3656 if Base_Type (S) /= Base_Type (Typ) then
3657 Error_Msg_NE
3660 -- Rewrite the constraint as a range of Typ
3661 -- to allow compilation to proceed further.
3663 Set_Etype (N, Typ);
3664 Rewrite (Low_Bound (R),
3665 Make_Attribute_Reference (Sloc (Low_Bound (R)),
3666 Prefix => New_Occurrence_Of (Typ, Sloc (R)),
3667 Attribute_Name => Name_First));
3668 Rewrite (High_Bound (R),
3669 Make_Attribute_Reference (Sloc (High_Bound (R)),
3670 Prefix => New_Occurrence_Of (Typ, Sloc (R)),
3671 Attribute_Name => Name_First));
3673 else
3674 Resolve (R, Typ);
3675 Set_Etype (N, Etype (R));
3677 -- Additionally, we must check that the bounds are compatible
3678 -- with the given subtype, which might be different from the
3679 -- type of the context.
3681 Apply_Range_Check (R, S);
3683 -- ??? If the above check statically detects a Constraint_Error
3684 -- it replaces the offending bound(s) of the range R with a
3685 -- Constraint_Error node. When the itype which uses these bounds
3686 -- is frozen the resulting call to Duplicate_Subexpr generates
3687 -- a new temporary for the bounds.
3689 -- Unfortunately there are other itypes that are also made depend
3690 -- on these bounds, so when Duplicate_Subexpr is called they get
3691 -- a forward reference to the newly created temporaries and Gigi
3692 -- aborts on such forward references. This is probably sign of a
3693 -- more fundamental problem somewhere else in either the order of
3694 -- itype freezing or the way certain itypes are constructed.
3696 -- To get around this problem we call Remove_Side_Effects right
3697 -- away if either bounds of R are a Constraint_Error.
3699 declare
3700 L : Node_Id := Low_Bound (R);
3701 H : Node_Id := High_Bound (R);
3703 begin
3704 if Nkind (L) = N_Raise_Constraint_Error then
3705 Remove_Side_Effects (L);
3706 end if;
3708 if Nkind (H) = N_Raise_Constraint_Error then
3709 Remove_Side_Effects (H);
3710 end if;
3711 end;
3713 Check_Unset_Reference (Low_Bound (R));
3714 Check_Unset_Reference (High_Bound (R));
3715 end if;
3716 end if;
3717 end Resolve_Discrete_Subtype_Indication;
3719 -------------------------
3720 -- Resolve_Entity_Name --
3721 -------------------------
3723 -- Used to resolve identifiers and expanded names
3725 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
3726 E : constant Entity_Id := Entity (N);
3728 begin
3729 -- If garbage from errors, set to Any_Type and return
3731 if No (E) and then Total_Errors_Detected /= 0 then
3732 Set_Etype (N, Any_Type);
3733 return;
3734 end if;
3736 -- Replace named numbers by corresponding literals. Note that this is
3737 -- the one case where Resolve_Entity_Name must reset the Etype, since
3738 -- it is currently marked as universal.
3740 if Ekind (E) = E_Named_Integer then
3741 Set_Etype (N, Typ);
3742 Eval_Named_Integer (N);
3744 elsif Ekind (E) = E_Named_Real then
3745 Set_Etype (N, Typ);
3746 Eval_Named_Real (N);
3748 -- Allow use of subtype only if it is a concurrent type where we are
3749 -- currently inside the body. This will eventually be expanded
3750 -- into a call to Self (for tasks) or _object (for protected
3751 -- objects). Any other use of a subtype is invalid.
3753 elsif Is_Type (E) then
3754 if Is_Concurrent_Type (E)
3755 and then In_Open_Scopes (E)
3756 then
3757 null;
3758 else
3759 Error_Msg_N
3761 end if;
3763 -- Check discriminant use if entity is discriminant in current scope,
3764 -- i.e. discriminant of record or concurrent type currently being
3765 -- analyzed. Uses in corresponding body are unrestricted.
3767 elsif Ekind (E) = E_Discriminant
3768 and then Scope (E) = Current_Scope
3769 and then not Has_Completion (Current_Scope)
3770 then
3771 Check_Discriminant_Use (N);
3773 -- A parameterless generic function cannot appear in a context that
3774 -- requires resolution.
3776 elsif Ekind (E) = E_Generic_Function then
3779 elsif Ekind (E) = E_Out_Parameter
3780 and then Ada_83
3781 and then (Nkind (Parent (N)) in N_Op
3782 or else (Nkind (Parent (N)) = N_Assignment_Statement
3783 and then N = Expression (Parent (N)))
3784 or else Nkind (Parent (N)) = N_Explicit_Dereference)
3785 then
3788 -- In all other cases, just do the possible static evaluation
3790 else
3791 -- A deferred constant that appears in an expression must have
3792 -- a completion, unless it has been removed by in-place expansion
3793 -- of an aggregate.
3795 if Ekind (E) = E_Constant
3796 and then Comes_From_Source (E)
3797 and then No (Constant_Value (E))
3798 and then Is_Frozen (Etype (E))
3799 and then not In_Default_Expression
3800 and then not Is_Imported (E)
3801 then
3803 if No_Initialization (Parent (E))
3804 or else (Present (Full_View (E))
3805 and then No_Initialization (Parent (Full_View (E))))
3806 then
3807 null;
3808 else
3809 Error_Msg_N (
3811 end if;
3812 end if;
3814 Eval_Entity_Name (N);
3815 end if;
3816 end Resolve_Entity_Name;
3818 -------------------
3819 -- Resolve_Entry --
3820 -------------------
3822 procedure Resolve_Entry (Entry_Name : Node_Id) is
3823 Loc : constant Source_Ptr := Sloc (Entry_Name);
3824 Nam : Entity_Id;
3825 New_N : Node_Id;
3826 S : Entity_Id;
3827 Tsk : Entity_Id;
3828 E_Name : Node_Id;
3829 Index : Node_Id;
3831 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
3832 -- If the bounds of the entry family being called depend on task
3833 -- discriminants, build a new index subtype where a discriminant is
3834 -- replaced with the value of the discriminant of the target task.
3835 -- The target task is the prefix of the entry name in the call.
3837 -----------------------
3838 -- Actual_Index_Type --
3839 -----------------------
3841 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
3842 Typ : Entity_Id := Entry_Index_Type (E);
3843 Tsk : Entity_Id := Scope (E);
3844 Lo : Node_Id := Type_Low_Bound (Typ);
3845 Hi : Node_Id := Type_High_Bound (Typ);
3846 New_T : Entity_Id;
3848 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
3849 -- If the bound is given by a discriminant, replace with a reference
3850 -- to the discriminant of the same name in the target task.
3851 -- If the entry name is the target of a requeue statement and the
3852 -- entry is in the current protected object, the bound to be used
3853 -- is the discriminal of the object (see apply_range_checks for
3854 -- details of the transformation).
3856 -----------------------------
3857 -- Actual_Discriminant_Ref --
3858 -----------------------------
3860 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
3861 Typ : Entity_Id := Etype (Bound);
3862 Ref : Node_Id;
3864 begin
3865 Remove_Side_Effects (Bound);
3867 if not Is_Entity_Name (Bound)
3868 or else Ekind (Entity (Bound)) /= E_Discriminant
3869 then
3870 return Bound;
3872 elsif Is_Protected_Type (Tsk)
3873 and then In_Open_Scopes (Tsk)
3874 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
3875 then
3876 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
3878 else
3879 Ref :=
3880 Make_Selected_Component (Loc,
3881 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
3882 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
3883 Analyze (Ref);
3884 Resolve (Ref, Typ);
3885 return Ref;
3886 end if;
3887 end Actual_Discriminant_Ref;
3889 -- Start of processing for Actual_Index_Type
3891 begin
3892 if not Has_Discriminants (Tsk)
3893 or else (not Is_Entity_Name (Lo)
3894 and then not Is_Entity_Name (Hi))
3895 then
3896 return Entry_Index_Type (E);
3898 else
3899 New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
3900 Set_Etype (New_T, Base_Type (Typ));
3901 Set_Size_Info (New_T, Typ);
3902 Set_RM_Size (New_T, RM_Size (Typ));
3903 Set_Scalar_Range (New_T,
3904 Make_Range (Sloc (Entry_Name),
3905 Low_Bound => Actual_Discriminant_Ref (Lo),
3906 High_Bound => Actual_Discriminant_Ref (Hi)));
3908 return New_T;
3909 end if;
3910 end Actual_Index_Type;
3912 -- Start of processing of Resolve_Entry
3914 begin
3915 -- Find name of entry being called, and resolve prefix of name
3916 -- with its own type. The prefix can be overloaded, and the name
3917 -- and signature of the entry must be taken into account.
3919 if Nkind (Entry_Name) = N_Indexed_Component then
3921 -- Case of dealing with entry family within the current tasks
3923 E_Name := Prefix (Entry_Name);
3925 else
3926 E_Name := Entry_Name;
3927 end if;
3929 if Is_Entity_Name (E_Name) then
3930 -- Entry call to an entry (or entry family) in the current task.
3931 -- This is legal even though the task will deadlock. Rewrite as
3932 -- call to current task.
3934 -- This can also be a call to an entry in an enclosing task.
3935 -- If this is a single task, we have to retrieve its name,
3936 -- because the scope of the entry is the task type, not the
3937 -- object. If the enclosing task is a task type, the identity
3938 -- of the task is given by its own self variable.
3940 -- Finally this can be a requeue on an entry of the same task
3941 -- or protected object.
3943 S := Scope (Entity (E_Name));
3945 for J in reverse 0 .. Scope_Stack.Last loop
3947 if Is_Task_Type (Scope_Stack.Table (J).Entity)
3948 and then not Comes_From_Source (S)
3949 then
3950 -- S is an enclosing task or protected object. The concurrent
3951 -- declaration has been converted into a type declaration, and
3952 -- the object itself has an object declaration that follows
3953 -- the type in the same declarative part.
3955 Tsk := Next_Entity (S);
3957 while Etype (Tsk) /= S loop
3958 Next_Entity (Tsk);
3959 end loop;
3961 S := Tsk;
3962 exit;
3964 elsif S = Scope_Stack.Table (J).Entity then
3966 -- Call to current task. Will be transformed into call to Self
3968 exit;
3970 end if;
3971 end loop;
3973 New_N :=
3974 Make_Selected_Component (Loc,
3975 Prefix => New_Occurrence_Of (S, Loc),
3976 Selector_Name =>
3977 New_Occurrence_Of (Entity (E_Name), Loc));
3978 Rewrite (E_Name, New_N);
3979 Analyze (E_Name);
3981 elsif Nkind (Entry_Name) = N_Selected_Component
3982 and then Is_Overloaded (Prefix (Entry_Name))
3983 then
3984 -- Use the entry name (which must be unique at this point) to
3985 -- find the prefix that returns the corresponding task type or
3986 -- protected type.
3988 declare
3989 Pref : Node_Id := Prefix (Entry_Name);
3990 I : Interp_Index;
3991 It : Interp;
3992 Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
3994 begin
3995 Get_First_Interp (Pref, I, It);
3997 while Present (It.Typ) loop
3999 if Scope (Ent) = It.Typ then
4000 Set_Etype (Pref, It.Typ);
4001 exit;
4002 end if;
4004 Get_Next_Interp (I, It);
4005 end loop;
4006 end;
4007 end if;
4009 if Nkind (Entry_Name) = N_Selected_Component then
4010 Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
4012 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4013 Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4014 Resolve (Prefix (Prefix (Entry_Name)),
4015 Etype (Prefix (Prefix (Entry_Name))));
4017 Index := First (Expressions (Entry_Name));
4018 Resolve (Index, Entry_Index_Type (Nam));
4020 -- Up to this point the expression could have been the actual
4021 -- in a simple entry call, and be given by a named association.
4023 if Nkind (Index) = N_Parameter_Association then
4025 else
4026 Apply_Range_Check (Index, Actual_Index_Type (Nam));
4027 end if;
4028 end if;
4030 end Resolve_Entry;
4032 ------------------------
4033 -- Resolve_Entry_Call --
4034 ------------------------
4036 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
4037 Entry_Name : constant Node_Id := Name (N);
4038 Loc : constant Source_Ptr := Sloc (Entry_Name);
4039 Actuals : List_Id;
4040 First_Named : Node_Id;
4041 Nam : Entity_Id;
4042 Norm_OK : Boolean;
4043 Obj : Node_Id;
4044 Was_Over : Boolean;
4046 begin
4047 -- Processing of the name is similar for entry calls and protected
4048 -- operation calls. Once the entity is determined, we can complete
4049 -- the resolution of the actuals.
4051 -- The selector may be overloaded, in the case of a protected object
4052 -- with overloaded functions. The type of the context is used for
4053 -- resolution.
4055 if Nkind (Entry_Name) = N_Selected_Component
4056 and then Is_Overloaded (Selector_Name (Entry_Name))
4057 and then Typ /= Standard_Void_Type
4058 then
4059 declare
4060 I : Interp_Index;
4061 It : Interp;
4063 begin
4064 Get_First_Interp (Selector_Name (Entry_Name), I, It);
4066 while Present (It.Typ) loop
4068 if Covers (Typ, It.Typ) then
4069 Set_Entity (Selector_Name (Entry_Name), It.Nam);
4070 Set_Etype (Entry_Name, It.Typ);
4072 Generate_Reference (It.Typ, N, ' ');
4073 end if;
4075 Get_Next_Interp (I, It);
4076 end loop;
4077 end;
4078 end if;
4080 Resolve_Entry (Entry_Name);
4082 if Nkind (Entry_Name) = N_Selected_Component then
4084 -- Simple entry call.
4086 Nam := Entity (Selector_Name (Entry_Name));
4087 Obj := Prefix (Entry_Name);
4088 Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
4090 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
4092 -- Call to member of entry family.
4094 Nam := Entity (Selector_Name (Prefix (Entry_Name)));
4095 Obj := Prefix (Prefix (Entry_Name));
4096 Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
4097 end if;
4099 -- Use context type to disambiguate a protected function that can be
4100 -- called without actuals and that returns an array type, and where
4101 -- the argument list may be an indexing of the returned value.
4103 if Ekind (Nam) = E_Function
4104 and then Needs_No_Actuals (Nam)
4105 and then Present (Parameter_Associations (N))
4106 and then
4107 ((Is_Array_Type (Etype (Nam))
4108 and then Covers (Typ, Component_Type (Etype (Nam))))
4110 or else (Is_Access_Type (Etype (Nam))
4111 and then Is_Array_Type (Designated_Type (Etype (Nam)))
4112 and then Covers (Typ,
4113 Component_Type (Designated_Type (Etype (Nam))))))
4114 then
4115 declare
4116 Index_Node : Node_Id;
4118 begin
4119 Index_Node :=
4120 Make_Indexed_Component (Loc,
4121 Prefix =>
4122 Make_Function_Call (Loc,
4123 Name => Relocate_Node (Entry_Name)),
4124 Expressions => Parameter_Associations (N));
4126 -- Since we are correcting a node classification error made by
4127 -- the parser, we call Replace rather than Rewrite.
4129 Replace (N, Index_Node);
4130 Set_Etype (Prefix (N), Etype (Nam));
4131 Set_Etype (N, Typ);
4132 Resolve_Indexed_Component (N, Typ);
4133 return;
4134 end;
4135 end if;
4137 -- The operation name may have been overloaded. Order the actuals
4138 -- according to the formals of the resolved entity.
4140 if Was_Over then
4141 Normalize_Actuals (N, Nam, False, Norm_OK);
4142 pragma Assert (Norm_OK);
4143 end if;
4145 Resolve_Actuals (N, Nam);
4146 Generate_Reference (Nam, Entry_Name);
4148 if Ekind (Nam) = E_Entry
4149 or else Ekind (Nam) = E_Entry_Family
4150 then
4151 Check_Potentially_Blocking_Operation (N);
4152 end if;
4154 -- Verify that a procedure call cannot masquerade as an entry
4155 -- call where an entry call is expected.
4157 if Ekind (Nam) = E_Procedure then
4159 if Nkind (Parent (N)) = N_Entry_Call_Alternative
4160 and then N = Entry_Call_Statement (Parent (N))
4161 then
4164 elsif Nkind (Parent (N)) = N_Triggering_Alternative
4165 and then N = Triggering_Statement (Parent (N))
4166 then
4169 elsif Ekind (Scope (Nam)) = E_Task_Type
4170 and then not In_Open_Scopes (Scope (Nam))
4171 then
4173 end if;
4174 end if;
4176 -- After resolution, entry calls and protected procedure calls
4177 -- are changed into entry calls, for expansion. The structure
4178 -- of the node does not change, so it can safely be done in place.
4179 -- Protected function calls must keep their structure because they
4180 -- are subexpressions.
4182 if Ekind (Nam) /= E_Function then
4184 -- A protected operation that is not a function may modify the
4185 -- corresponding object, and cannot apply to a constant.
4186 -- If this is an internal call, the prefix is the type itself.
4188 if Is_Protected_Type (Scope (Nam))
4189 and then not Is_Variable (Obj)
4190 and then (not Is_Entity_Name (Obj)
4191 or else not Is_Type (Entity (Obj)))
4192 then
4193 Error_Msg_N
4195 Entry_Name);
4196 end if;
4198 Actuals := Parameter_Associations (N);
4199 First_Named := First_Named_Actual (N);
4201 Rewrite (N,
4202 Make_Entry_Call_Statement (Loc,
4203 Name => Entry_Name,
4204 Parameter_Associations => Actuals));
4206 Set_First_Named_Actual (N, First_Named);
4207 Set_Analyzed (N, True);
4209 -- Protected functions can return on the secondary stack, in which
4210 -- case we must trigger the transient scope mechanism
4212 elsif Expander_Active
4213 and then Requires_Transient_Scope (Etype (Nam))
4214 then
4215 Establish_Transient_Scope (N,
4216 Sec_Stack => not Functions_Return_By_DSP_On_Target);
4217 end if;
4219 end Resolve_Entry_Call;
4221 -------------------------
4222 -- Resolve_Equality_Op --
4223 -------------------------
4225 -- Both arguments must have the same type, and the boolean context
4226 -- does not participate in the resolution. The first pass verifies
4227 -- that the interpretation is not ambiguous, and the type of the left
4228 -- argument is correctly set, or is Any_Type in case of ambiguity.
4229 -- If both arguments are strings or aggregates, allocators, or Null,
4230 -- they are ambiguous even though they carry a single (universal) type.
4231 -- Diagnose this case here.
4233 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
4234 L : constant Node_Id := Left_Opnd (N);
4235 R : constant Node_Id := Right_Opnd (N);
4236 T : Entity_Id := Find_Unique_Type (L, R);
4238 function Find_Unique_Access_Type return Entity_Id;
4239 -- In the case of allocators, make a last-ditch attempt to find a single
4240 -- access type with the right designated type. This is semantically
4241 -- dubious, and of no interest to any real code, but c48008a makes it
4242 -- all worthwhile.
4244 -----------------------------
4245 -- Find_Unique_Access_Type --
4246 -----------------------------
4248 function Find_Unique_Access_Type return Entity_Id is
4249 Acc : Entity_Id;
4250 E : Entity_Id;
4251 S : Entity_Id := Current_Scope;
4253 begin
4254 if Ekind (Etype (R)) = E_Allocator_Type then
4255 Acc := Designated_Type (Etype (R));
4257 elsif Ekind (Etype (L)) = E_Allocator_Type then
4258 Acc := Designated_Type (Etype (L));
4260 else
4261 return Empty;
4262 end if;
4264 while S /= Standard_Standard loop
4265 E := First_Entity (S);
4267 while Present (E) loop
4269 if Is_Type (E)
4270 and then Is_Access_Type (E)
4271 and then Ekind (E) /= E_Allocator_Type
4272 and then Designated_Type (E) = Base_Type (Acc)
4273 then
4274 return E;
4275 end if;
4277 Next_Entity (E);
4278 end loop;
4280 S := Scope (S);
4281 end loop;
4283 return Empty;
4284 end Find_Unique_Access_Type;
4286 -- Start of processing for Resolve_Equality_Op
4288 begin
4289 Set_Etype (N, Base_Type (Typ));
4290 Generate_Reference (T, N, ' ');
4292 if T = Any_Fixed then
4293 T := Unique_Fixed_Point_Type (L);
4294 end if;
4296 if T /= Any_Type then
4298 if T = Any_String
4299 or else T = Any_Composite
4300 or else T = Any_Character
4301 then
4303 if T = Any_Character then
4304 Ambiguous_Character (L);
4305 else
4307 end if;
4309 Set_Etype (N, Any_Type);
4310 return;
4312 elsif T = Any_Access
4313 or else Ekind (T) = E_Allocator_Type
4314 then
4315 T := Find_Unique_Access_Type;
4317 if No (T) then
4319 Set_Etype (N, Any_Type);
4320 return;
4321 end if;
4322 end if;
4324 if Comes_From_Source (N)
4325 and then Has_Unchecked_Union (T)
4326 then
4327 Error_Msg_N
4329 end if;
4331 Resolve (L, T);
4332 Resolve (R, T);
4333 Check_Unset_Reference (L);
4334 Check_Unset_Reference (R);
4335 Generate_Operator_Reference (N);
4337 -- If this is an inequality, it may be the implicit inequality
4338 -- created for a user-defined operation, in which case the corres-
4339 -- ponding equality operation is not intrinsic, and the operation
4340 -- cannot be constant-folded. Else fold.
4342 if Nkind (N) = N_Op_Eq
4343 or else Comes_From_Source (Entity (N))
4344 or else Ekind (Entity (N)) = E_Operator
4345 or else Is_Intrinsic_Subprogram
4346 (Corresponding_Equality (Entity (N)))
4347 then
4348 Eval_Relational_Op (N);
4349 elsif Nkind (N) = N_Op_Ne
4350 and then Is_Abstract (Entity (N))
4351 then
4353 end if;
4354 end if;
4355 end Resolve_Equality_Op;
4357 ----------------------------------
4358 -- Resolve_Explicit_Dereference --
4359 ----------------------------------
4361 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
4362 P : constant Node_Id := Prefix (N);
4363 I : Interp_Index;
4364 It : Interp;
4366 begin
4367 -- Now that we know the type, check that this is not a
4368 -- dereference of an uncompleted type. Note that this
4369 -- is not entirely correct, because dereferences of
4370 -- private types are legal in default expressions.
4371 -- This consideration also applies to similar checks
4372 -- for allocators, qualified expressions, and type
4373 -- conversions. ???
4375 Check_Fully_Declared (Typ, N);
4377 if Is_Overloaded (P) then
4379 -- Use the context type to select the prefix that has the
4380 -- correct designated type.
4382 Get_First_Interp (P, I, It);
4383 while Present (It.Typ) loop
4384 exit when Is_Access_Type (It.Typ)
4385 and then Covers (Typ, Designated_Type (It.Typ));
4387 Get_Next_Interp (I, It);
4388 end loop;
4390 Resolve (P, It.Typ);
4391 Set_Etype (N, Designated_Type (It.Typ));
4393 else
4394 Resolve (P, Etype (P));
4395 end if;
4397 if Is_Access_Type (Etype (P)) then
4398 Apply_Access_Check (N);
4399 end if;
4401 -- If the designated type is a packed unconstrained array type,
4402 -- and the explicit dereference is not in the context of an
4403 -- attribute reference, then we must compute and set the actual
4404 -- subtype, since it is needed by Gigi. The reason we exclude
4405 -- the attribute case is that this is handled fine by Gigi, and
4406 -- in fact we use such attributes to build the actual subtype.
4407 -- We also exclude generated code (which builds actual subtypes
4408 -- directly if they are needed).
4410 if Is_Array_Type (Etype (N))
4411 and then Is_Packed (Etype (N))
4412 and then not Is_Constrained (Etype (N))
4413 and then Nkind (Parent (N)) /= N_Attribute_Reference
4414 and then Comes_From_Source (N)
4415 then
4416 Set_Etype (N, Get_Actual_Subtype (N));
4417 end if;
4419 -- Note: there is no Eval processing required for an explicit
4420 -- deference, because the type is known to be an allocators, and
4421 -- allocator expressions can never be static.
4423 end Resolve_Explicit_Dereference;
4425 -------------------------------
4426 -- Resolve_Indexed_Component --
4427 -------------------------------
4429 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
4430 Name : constant Node_Id := Prefix (N);
4431 Expr : Node_Id;
4432 Array_Type : Entity_Id := Empty; -- to prevent junk warning
4433 Index : Node_Id;
4435 begin
4436 if Is_Overloaded (Name) then
4438 -- Use the context type to select the prefix that yields the
4439 -- correct component type.
4441 declare
4442 I : Interp_Index;
4443 It : Interp;
4444 I1 : Interp_Index := 0;
4445 P : constant Node_Id := Prefix (N);
4446 Found : Boolean := False;
4448 begin
4449 Get_First_Interp (P, I, It);
4451 while Present (It.Typ) loop
4453 if (Is_Array_Type (It.Typ)
4454 and then Covers (Typ, Component_Type (It.Typ)))
4455 or else (Is_Access_Type (It.Typ)
4456 and then Is_Array_Type (Designated_Type (It.Typ))
4457 and then Covers
4458 (Typ, Component_Type (Designated_Type (It.Typ))))
4459 then
4460 if Found then
4461 It := Disambiguate (P, I1, I, Any_Type);
4463 if It = No_Interp then
4465 Set_Etype (N, Typ);
4466 return;
4468 else
4469 Found := True;
4470 Array_Type := It.Typ;
4471 I1 := I;
4472 end if;
4474 else
4475 Found := True;
4476 Array_Type := It.Typ;
4477 I1 := I;
4478 end if;
4479 end if;
4481 Get_Next_Interp (I, It);
4482 end loop;
4483 end;
4485 else
4486 Array_Type := Etype (Name);
4487 end if;
4489 Resolve (Name, Array_Type);
4490 Array_Type := Get_Actual_Subtype_If_Available (Name);
4492 -- If prefix is access type, dereference to get real array type.
4493 -- Note: we do not apply an access check because the expander always
4494 -- introduces an explicit dereference, and the check will happen there.
4496 if Is_Access_Type (Array_Type) then
4497 Array_Type := Designated_Type (Array_Type);
4498 end if;
4500 -- If name was overloaded, set component type correctly now.
4502 Set_Etype (N, Component_Type (Array_Type));
4504 Index := First_Index (Array_Type);
4505 Expr := First (Expressions (N));
4507 -- The prefix may have resolved to a string literal, in which case
4508 -- its etype has a special representation. This is only possible
4509 -- currently if the prefix is a static concatenation, written in
4510 -- functional notation.
4512 if Ekind (Array_Type) = E_String_Literal_Subtype then
4513 Resolve (Expr, Standard_Positive);
4515 else
4516 while Present (Index) and Present (Expr) loop
4517 Resolve (Expr, Etype (Index));
4518 Check_Unset_Reference (Expr);
4520 if Is_Scalar_Type (Etype (Expr)) then
4521 Apply_Scalar_Range_Check (Expr, Etype (Index));
4522 else
4523 Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
4524 end if;
4526 Next_Index (Index);
4527 Next (Expr);
4528 end loop;
4529 end if;
4531 Eval_Indexed_Component (N);
4533 end Resolve_Indexed_Component;
4535 -----------------------------
4536 -- Resolve_Integer_Literal --
4537 -----------------------------
4539 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
4540 begin
4541 Set_Etype (N, Typ);
4542 Eval_Integer_Literal (N);
4543 end Resolve_Integer_Literal;
4545 ---------------------------------
4546 -- Resolve_Intrinsic_Operator --
4547 ---------------------------------
4549 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
4550 Op : Entity_Id;
4551 Arg1 : Node_Id := Left_Opnd (N);
4552 Arg2 : Node_Id := Right_Opnd (N);
4554 begin
4555 Op := Entity (N);
4557 while Scope (Op) /= Standard_Standard loop
4558 Op := Homonym (Op);
4559 pragma Assert (Present (Op));
4560 end loop;
4562 Set_Entity (N, Op);
4564 if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
4565 Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
4566 Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
4568 Analyze (Left_Opnd (N));
4569 Analyze (Right_Opnd (N));
4570 end if;
4572 Resolve_Arithmetic_Op (N, Typ);
4573 end Resolve_Intrinsic_Operator;
4575 ------------------------
4576 -- Resolve_Logical_Op --
4577 ------------------------
4579 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
4580 B_Typ : Entity_Id;
4582 begin
4583 -- Predefined operations on scalar types yield the base type. On
4584 -- the other hand, logical operations on arrays yield the type of
4585 -- the arguments (and the context).
4587 if Is_Array_Type (Typ) then
4588 B_Typ := Typ;
4589 else
4590 B_Typ := Base_Type (Typ);
4591 end if;
4593 -- The following test is required because the operands of the operation
4594 -- may be literals, in which case the resulting type appears to be
4595 -- compatible with a signed integer type, when in fact it is compatible
4596 -- only with modular types. If the context itself is universal, the
4597 -- operation is illegal.
4599 if not Valid_Boolean_Arg (Typ) then
4601 Set_Etype (N, Any_Type);
4602 return;
4604 elsif Typ = Any_Modular then
4605 Error_Msg_N
4607 Set_Etype (N, Any_Type);
4608 return;
4609 elsif Is_Modular_Integer_Type (Typ)
4610 and then Etype (Left_Opnd (N)) = Universal_Integer
4611 and then Etype (Right_Opnd (N)) = Universal_Integer
4612 then
4613 Check_For_Visible_Operator (N, B_Typ);
4614 end if;
4616 Resolve (Left_Opnd (N), B_Typ);
4617 Resolve (Right_Opnd (N), B_Typ);
4619 Check_Unset_Reference (Left_Opnd (N));
4620 Check_Unset_Reference (Right_Opnd (N));
4622 Set_Etype (N, B_Typ);
4623 Generate_Operator_Reference (N);
4624 Eval_Logical_Op (N);
4625 end Resolve_Logical_Op;
4627 ---------------------------
4628 -- Resolve_Membership_Op --
4629 ---------------------------
4631 -- The context can only be a boolean type, and does not determine
4632 -- the arguments. Arguments should be unambiguous, but the preference
4633 -- rule for universal types applies.
4635 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
4636 pragma Warnings (Off, Typ);
4638 L : constant Node_Id := Left_Opnd (N);
4639 R : constant Node_Id := Right_Opnd (N);
4640 T : Entity_Id;
4642 begin
4643 if L = Error or else R = Error then
4644 return;
4645 end if;
4647 if not Is_Overloaded (R)
4648 and then
4649 (Etype (R) = Universal_Integer or else
4650 Etype (R) = Universal_Real)
4651 and then Is_Overloaded (L)
4652 then
4653 T := Etype (R);
4654 else
4655 T := Intersect_Types (L, R);
4656 end if;
4658 Resolve (L, T);
4659 Check_Unset_Reference (L);
4661 if Nkind (R) = N_Range
4662 and then not Is_Scalar_Type (T)
4663 then
4665 end if;
4667 if Is_Entity_Name (R) then
4668 Freeze_Expression (R);
4669 else
4670 Resolve (R, T);
4671 Check_Unset_Reference (R);
4672 end if;
4674 Eval_Membership_Op (N);
4675 end Resolve_Membership_Op;
4677 ------------------
4678 -- Resolve_Null --
4679 ------------------
4681 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
4682 begin
4683 -- For now allow circumvention of the restriction against
4684 -- anonymous null access values via a debug switch to allow
4685 -- for easier transition.
4687 if not Debug_Flag_J
4688 and then Ekind (Typ) = E_Anonymous_Access_Type
4689 and then Comes_From_Source (N)
4690 then
4691 -- In the common case of a call which uses an explicitly null
4692 -- value for an access parameter, give specialized error msg
4694 if Nkind (Parent (N)) = N_Procedure_Call_Statement
4695 or else
4696 Nkind (Parent (N)) = N_Function_Call
4697 then
4698 Error_Msg_N
4701 -- Standard message for all other cases (are there any?)
4703 else
4704 Error_Msg_N
4706 end if;
4707 end if;
4709 -- In a distributed context, null for a remote access to subprogram
4710 -- may need to be replaced with a special record aggregate. In this
4711 -- case, return after having done the transformation.
4713 if (Ekind (Typ) = E_Record_Type
4714 or else Is_Remote_Access_To_Subprogram_Type (Typ))
4715 and then Remote_AST_Null_Value (N, Typ)
4716 then
4717 return;
4718 end if;
4720 -- The null literal takes its type from the context.
4722 Set_Etype (N, Typ);
4723 end Resolve_Null;
4725 -----------------------
4726 -- Resolve_Op_Concat --
4727 -----------------------
4729 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
4730 Btyp : constant Entity_Id := Base_Type (Typ);
4731 Op1 : constant Node_Id := Left_Opnd (N);
4732 Op2 : constant Node_Id := Right_Opnd (N);
4734 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
4735 -- Internal procedure to resolve one operand of concatenation operator.
4736 -- The operand is either of the array type or of the component type.
4737 -- If the operand is an aggregate, and the component type is composite,
4738 -- this is ambiguous if component type has aggregates.
4740 -------------------------------
4741 -- Resolve_Concatenation_Arg --
4742 -------------------------------
4744 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
4745 begin
4746 if In_Instance then
4747 if Is_Comp
4748 or else (not Is_Overloaded (Arg)
4749 and then Etype (Arg) /= Any_Composite
4750 and then Covers (Component_Type (Typ), Etype (Arg)))
4751 then
4752 Resolve (Arg, Component_Type (Typ));
4753 else
4754 Resolve (Arg, Btyp);
4755 end if;
4757 elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
4759 if Nkind (Arg) = N_Aggregate
4760 and then Is_Composite_Type (Component_Type (Typ))
4761 then
4762 if Is_Private_Type (Component_Type (Typ)) then
4763 Resolve (Arg, Btyp);
4765 else
4767 Set_Etype (Arg, Any_Type);
4768 end if;
4770 else
4771 if Is_Overloaded (Arg)
4772 and then Has_Compatible_Type (Arg, Typ)
4773 and then Etype (Arg) /= Any_Type
4774 then
4777 declare
4778 I : Interp_Index;
4779 It : Interp;
4781 begin
4782 Get_First_Interp (Arg, I, It);
4784 while Present (It.Nam) loop
4786 if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
4787 or else Base_Type (Etype (It.Nam)) =
4788 Base_Type (Component_Type (Typ))
4789 then
4790 Error_Msg_Sloc := Sloc (It.Nam);
4792 end if;
4794 Get_Next_Interp (I, It);
4795 end loop;
4796 end;
4797 end if;
4799 Resolve (Arg, Component_Type (Typ));
4801 if Arg = Left_Opnd (N) then
4802 Set_Is_Component_Left_Opnd (N);
4803 else
4804 Set_Is_Component_Right_Opnd (N);
4805 end if;
4806 end if;
4808 else
4809 Resolve (Arg, Btyp);
4810 end if;
4812 Check_Unset_Reference (Arg);
4813 end Resolve_Concatenation_Arg;
4815 -- Start of processing for Resolve_Op_Concat
4817 begin
4818 Set_Etype (N, Btyp);
4820 if Is_Limited_Composite (Btyp) then
4822 end if;
4824 -- If the operands are themselves concatenations, resolve them as
4825 -- such directly. This removes several layers of recursion and allows
4826 -- GNAT to handle larger multiple concatenations.
4828 if Nkind (Op1) = N_Op_Concat
4829 and then not Is_Array_Type (Component_Type (Typ))
4830 and then Entity (Op1) = Entity (N)
4831 then
4832 Resolve_Op_Concat (Op1, Typ);
4833 else
4834 Resolve_Concatenation_Arg
4835 (Op1, Is_Component_Left_Opnd (N));
4836 end if;
4838 if Nkind (Op2) = N_Op_Concat
4839 and then not Is_Array_Type (Component_Type (Typ))
4840 and then Entity (Op2) = Entity (N)
4841 then
4842 Resolve_Op_Concat (Op2, Typ);
4843 else
4844 Resolve_Concatenation_Arg
4845 (Op2, Is_Component_Right_Opnd (N));
4846 end if;
4848 Generate_Operator_Reference (N);
4850 if Is_String_Type (Typ) then
4851 Eval_Concatenation (N);
4852 end if;
4854 -- If this is not a static concatenation, but the result is a
4855 -- string type (and not an array of strings) insure that static
4856 -- string operands have their subtypes properly constructed.
4858 if Nkind (N) /= N_String_Literal
4859 and then Is_Character_Type (Component_Type (Typ))
4860 then
4861 Set_String_Literal_Subtype (Op1, Typ);
4862 Set_String_Literal_Subtype (Op2, Typ);
4863 end if;
4864 end Resolve_Op_Concat;
4866 ----------------------
4867 -- Resolve_Op_Expon --
4868 ----------------------
4870 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
4871 B_Typ : constant Entity_Id := Base_Type (Typ);
4873 begin
4874 -- Catch attempts to do fixed-point exponentation with universal
4875 -- operands, which is a case where the illegality is not caught
4876 -- during normal operator analysis.
4878 if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
4880 return;
4881 end if;
4883 if Etype (Left_Opnd (N)) = Universal_Integer
4884 or else Etype (Left_Opnd (N)) = Universal_Real
4885 then
4886 Check_For_Visible_Operator (N, B_Typ);
4887 end if;
4889 -- We do the resolution using the base type, because intermediate values
4890 -- in expressions always are of the base type, not a subtype of it.
4892 Resolve (Left_Opnd (N), B_Typ);
4893 Resolve (Right_Opnd (N), Standard_Integer);
4895 Check_Unset_Reference (Left_Opnd (N));
4896 Check_Unset_Reference (Right_Opnd (N));
4898 Set_Etype (N, B_Typ);
4899 Generate_Operator_Reference (N);
4900 Eval_Op_Expon (N);
4902 -- Set overflow checking bit. Much cleverer code needed here eventually
4903 -- and perhaps the Resolve routines should be separated for the various
4904 -- arithmetic operations, since they will need different processing. ???
4906 if Nkind (N) in N_Op then
4907 if not Overflow_Checks_Suppressed (Etype (N)) then
4908 Set_Do_Overflow_Check (N, True);
4909 end if;
4910 end if;
4912 end Resolve_Op_Expon;
4914 --------------------
4915 -- Resolve_Op_Not --
4916 --------------------
4918 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
4919 B_Typ : Entity_Id;
4921 function Parent_Is_Boolean return Boolean;
4922 -- This function determines if the parent node is a boolean operator
4923 -- or operation (comparison op, membership test, or short circuit form)
4924 -- and the not in question is the left operand of this operation.
4925 -- Note that if the not is in parens, then false is returned.
4927 function Parent_Is_Boolean return Boolean is
4928 begin
4929 if Paren_Count (N) /= 0 then
4930 return False;
4932 else
4933 case Nkind (Parent (N)) is
4934 when N_Op_And |
4935 N_Op_Eq |
4936 N_Op_Ge |
4937 N_Op_Gt |
4938 N_Op_Le |
4939 N_Op_Lt |
4940 N_Op_Ne |
4941 N_Op_Or |
4942 N_Op_Xor |
4943 N_In |
4944 N_Not_In |
4945 N_And_Then |
4946 N_Or_Else =>
4948 return Left_Opnd (Parent (N)) = N;
4950 when others =>
4951 return False;
4952 end case;
4953 end if;
4954 end Parent_Is_Boolean;
4956 -- Start of processing for Resolve_Op_Not
4958 begin
4959 -- Predefined operations on scalar types yield the base type. On
4960 -- the other hand, logical operations on arrays yield the type of
4961 -- the arguments (and the context).
4963 if Is_Array_Type (Typ) then
4964 B_Typ := Typ;
4965 else
4966 B_Typ := Base_Type (Typ);
4967 end if;
4969 if not Valid_Boolean_Arg (Typ) then
4971 Set_Etype (N, Any_Type);
4972 return;
4974 elsif (Typ = Universal_Integer
4975 or else Typ = Any_Modular)
4976 then
4977 if Parent_Is_Boolean then
4978 Error_Msg_N
4980 Right_Opnd (N));
4981 else
4982 Error_Msg_N
4984 end if;
4986 Set_Etype (N, Any_Type);
4987 return;
4989 else
4990 if not Is_Boolean_Type (Typ)
4991 and then Parent_Is_Boolean
4992 then
4994 end if;
4996 Resolve (Right_Opnd (N), B_Typ);
4997 Check_Unset_Reference (Right_Opnd (N));
4998 Set_Etype (N, B_Typ);
4999 Generate_Operator_Reference (N);
5000 Eval_Op_Not (N);
5001 end if;
5002 end Resolve_Op_Not;
5004 -----------------------------
5005 -- Resolve_Operator_Symbol --
5006 -----------------------------
5008 -- Nothing to be done, all resolved already
5010 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
5011 pragma Warnings (Off, N);
5012 pragma Warnings (Off, Typ);
5014 begin
5015 null;
5016 end Resolve_Operator_Symbol;
5018 ----------------------------------
5019 -- Resolve_Qualified_Expression --
5020 ----------------------------------
5022 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
5023 pragma Warnings (Off, Typ);
5025 Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
5026 Expr : constant Node_Id := Expression (N);
5028 begin
5029 Resolve (Expr, Target_Typ);
5031 -- A qualified expression requires an exact match of the type,
5032 -- class-wide matching is not allowed.
5034 if Is_Class_Wide_Type (Target_Typ)
5035 and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
5036 then
5037 Wrong_Type (Expr, Target_Typ);
5038 end if;
5040 -- If the target type is unconstrained, then we reset the type of
5041 -- the result from the type of the expression. For other cases, the
5042 -- actual subtype of the expression is the target type.
5044 if Is_Composite_Type (Target_Typ)
5045 and then not Is_Constrained (Target_Typ)
5046 then
5047 Set_Etype (N, Etype (Expr));
5048 end if;
5050 Eval_Qualified_Expression (N);
5051 end Resolve_Qualified_Expression;
5053 -------------------
5054 -- Resolve_Range --
5055 -------------------
5057 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
5058 L : constant Node_Id := Low_Bound (N);
5059 H : constant Node_Id := High_Bound (N);
5061 begin
5062 Set_Etype (N, Typ);
5063 Resolve (L, Typ);
5064 Resolve (H, Typ);
5066 Check_Unset_Reference (L);
5067 Check_Unset_Reference (H);
5069 -- We have to check the bounds for being within the base range as
5070 -- required for a non-static context. Normally this is automatic
5071 -- and done as part of evaluating expressions, but the N_Range
5072 -- node is an exception, since in GNAT we consider this node to
5073 -- be a subexpression, even though in Ada it is not. The circuit
5074 -- in Sem_Eval could check for this, but that would put the test
5075 -- on the main evaluation path for expressions.
5077 Check_Non_Static_Context (L);
5078 Check_Non_Static_Context (H);
5080 end Resolve_Range;
5082 --------------------------
5083 -- Resolve_Real_Literal --
5084 --------------------------
5086 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
5087 Actual_Typ : constant Entity_Id := Etype (N);
5089 begin
5090 -- Special processing for fixed-point literals to make sure that the
5091 -- value is an exact multiple of small where this is required. We
5092 -- skip this for the universal real case, and also for generic types.
5094 if Is_Fixed_Point_Type (Typ)
5095 and then Typ /= Universal_Fixed
5096 and then Typ /= Any_Fixed
5097 and then not Is_Generic_Type (Typ)
5098 then
5099 declare
5100 Val : constant Ureal := Realval (N);
5101 Cintr : constant Ureal := Val / Small_Value (Typ);
5102 Cint : constant Uint := UR_Trunc (Cintr);
5103 Den : constant Uint := Norm_Den (Cintr);
5104 Stat : Boolean;
5106 begin
5107 -- Case of literal is not an exact multiple of the Small
5109 if Den /= 1 then
5111 -- For a source program literal for a decimal fixed-point
5112 -- type, this is statically illegal (RM 4.9(36)).
5114 if Is_Decimal_Fixed_Point_Type (Typ)
5115 and then Actual_Typ = Universal_Real
5116 and then Comes_From_Source (N)
5117 then
5119 end if;
5121 -- Replace literal by a value that is the exact representation
5122 -- of a value of the type, i.e. a multiple of the small value,
5123 -- by truncation, since Machine_Rounds is false for all GNAT
5124 -- fixed-point types (RM 4.9(38)).
5126 Stat := Is_Static_Expression (N);
5127 Rewrite (N,
5128 Make_Real_Literal (Sloc (N),
5129 Realval => Small_Value (Typ) * Cint));
5131 Set_Is_Static_Expression (N, Stat);
5132 end if;
5134 -- In all cases, set the corresponding integer field
5136 Set_Corresponding_Integer_Value (N, Cint);
5137 end;
5138 end if;
5140 -- Now replace the actual type by the expected type as usual
5142 Set_Etype (N, Typ);
5143 Eval_Real_Literal (N);
5144 end Resolve_Real_Literal;
5146 -----------------------
5147 -- Resolve_Reference --
5148 -----------------------
5150 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
5151 P : constant Node_Id := Prefix (N);
5153 begin
5154 -- Replace general access with specific type
5156 if Ekind (Etype (N)) = E_Allocator_Type then
5157 Set_Etype (N, Base_Type (Typ));
5158 end if;
5160 Resolve (P, Designated_Type (Etype (N)));
5162 -- If we are taking the reference of a volatile entity, then treat
5163 -- it as a potential modification of this entity. This is much too
5164 -- conservative, but is necessary because remove side effects can
5165 -- result in transformations of normal assignments into reference
5166 -- sequences that otherwise fail to notice the modification.
5168 if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
5169 Note_Possible_Modification (P);
5170 end if;
5171 end Resolve_Reference;
5173 --------------------------------
5174 -- Resolve_Selected_Component --
5175 --------------------------------
5177 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
5178 Comp : Entity_Id;
5179 Comp1 : Entity_Id := Empty; -- prevent junk warning
5180 P : constant Node_Id := Prefix (N);
5181 S : constant Node_Id := Selector_Name (N);
5182 T : Entity_Id := Etype (P);
5183 I : Interp_Index;
5184 I1 : Interp_Index := 0; -- prevent junk warning
5185 It : Interp;
5186 It1 : Interp;
5187 Found : Boolean;
5189 function Init_Component return Boolean;
5190 -- Check whether this is the initialization of a component within an
5191 -- init_proc (by assignment or call to another init_proc). If true,
5192 -- there is no need for a discriminant check.
5194 --------------------
5195 -- Init_Component --
5196 --------------------
5198 function Init_Component return Boolean is
5199 begin
5200 return Inside_Init_Proc
5201 and then Nkind (Prefix (N)) = N_Identifier
5202 and then Chars (Prefix (N)) = Name_uInit
5203 and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
5204 end Init_Component;
5206 -- Start of processing for Resolve_Selected_Component
5208 begin
5209 if Is_Overloaded (P) then
5211 -- Use the context type to select the prefix that has a selector
5212 -- of the correct name and type.
5214 Found := False;
5215 Get_First_Interp (P, I, It);
5217 Search : while Present (It.Typ) loop
5218 if Is_Access_Type (It.Typ) then
5219 T := Designated_Type (It.Typ);
5220 else
5221 T := It.Typ;
5222 end if;
5224 if Is_Record_Type (T) then
5225 Comp := First_Entity (T);
5227 while Present (Comp) loop
5229 if Chars (Comp) = Chars (S)
5230 and then Covers (Etype (Comp), Typ)
5231 then
5232 if not Found then
5233 Found := True;
5234 I1 := I;
5235 It1 := It;
5236 Comp1 := Comp;
5238 else
5239 It := Disambiguate (P, I1, I, Any_Type);
5241 if It = No_Interp then
5242 Error_Msg_N
5244 Set_Etype (N, Typ);
5245 return;
5247 else
5248 It1 := It;
5250 if Scope (Comp1) /= It1.Typ then
5252 -- Resolution chooses the new interpretation.
5253 -- Find the component with the right name.
5255 Comp1 := First_Entity (It1.Typ);
5257 while Present (Comp1)
5258 and then Chars (Comp1) /= Chars (S)
5259 loop
5260 Comp1 := Next_Entity (Comp1);
5261 end loop;
5262 end if;
5264 exit Search;
5265 end if;
5266 end if;
5267 end if;
5269 Comp := Next_Entity (Comp);
5270 end loop;
5272 end if;
5274 Get_Next_Interp (I, It);
5276 end loop Search;
5278 Resolve (P, It1.Typ);
5279 Set_Etype (N, Typ);
5280 Set_Entity (S, Comp1);
5282 else
5283 -- Resolve prefix with its type.
5285 Resolve (P, T);
5286 end if;
5288 -- Deal with access type case
5290 if Is_Access_Type (Etype (P)) then
5291 Apply_Access_Check (N);
5292 T := Designated_Type (Etype (P));
5293 else
5294 T := Etype (P);
5295 end if;
5297 if Has_Discriminants (T)
5298 and then Present (Original_Record_Component (Entity (S)))
5299 and then Ekind (Original_Record_Component (Entity (S))) = E_Component
5300 and then Present (Discriminant_Checking_Func
5301 (Original_Record_Component (Entity (S))))
5302 and then not Discriminant_Checks_Suppressed (T)
5303 and then not Init_Component
5304 then
5305 Set_Do_Discriminant_Check (N);
5306 end if;
5308 if Ekind (Entity (S)) = E_Void then
5310 end if;
5312 -- If the prefix is a record conversion, this may be a renamed
5313 -- discriminant whose bounds differ from those of the original
5314 -- one, so we must ensure that a range check is performed.
5316 if Nkind (P) = N_Type_Conversion
5317 and then Ekind (Entity (S)) = E_Discriminant
5318 then
5319 Set_Etype (N, Base_Type (Typ));
5320 end if;
5322 -- Note: No Eval processing is required, because the prefix is of a
5323 -- record type, or protected type, and neither can possibly be static.
5325 end Resolve_Selected_Component;
5327 -------------------
5328 -- Resolve_Shift --
5329 -------------------
5331 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
5332 B_Typ : constant Entity_Id := Base_Type (Typ);
5333 L : constant Node_Id := Left_Opnd (N);
5334 R : constant Node_Id := Right_Opnd (N);
5336 begin
5337 -- We do the resolution using the base type, because intermediate values
5338 -- in expressions always are of the base type, not a subtype of it.
5340 Resolve (L, B_Typ);
5341 Resolve (R, Standard_Natural);
5343 Check_Unset_Reference (L);
5344 Check_Unset_Reference (R);
5346 Set_Etype (N, B_Typ);
5347 Generate_Operator_Reference (N);
5348 Eval_Shift (N);
5349 end Resolve_Shift;
5351 ---------------------------
5352 -- Resolve_Short_Circuit --
5353 ---------------------------
5355 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
5356 B_Typ : constant Entity_Id := Base_Type (Typ);
5357 L : constant Node_Id := Left_Opnd (N);
5358 R : constant Node_Id := Right_Opnd (N);
5360 begin
5361 Resolve (L, B_Typ);
5362 Resolve (R, B_Typ);
5364 Check_Unset_Reference (L);
5365 Check_Unset_Reference (R);
5367 Set_Etype (N, B_Typ);
5368 Eval_Short_Circuit (N);
5369 end Resolve_Short_Circuit;
5371 -------------------
5372 -- Resolve_Slice --
5373 -------------------
5375 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
5376 Name : constant Node_Id := Prefix (N);
5377 Drange : constant Node_Id := Discrete_Range (N);
5378 Array_Type : Entity_Id := Empty;
5379 Index : Node_Id;
5381 begin
5382 if Is_Overloaded (Name) then
5384 -- Use the context type to select the prefix that yields the
5385 -- correct array type.
5387 declare
5388 I : Interp_Index;
5389 I1 : Interp_Index := 0;
5390 It : Interp;
5391 P : constant Node_Id := Prefix (N);
5392 Found : Boolean := False;
5394 begin
5395 Get_First_Interp (P, I, It);
5397 while Present (It.Typ) loop
5399 if (Is_Array_Type (It.Typ)
5400 and then Covers (Typ, It.Typ))
5401 or else (Is_Access_Type (It.Typ)
5402 and then Is_Array_Type (Designated_Type (It.Typ))
5403 and then Covers (Typ, Designated_Type (It.Typ)))
5404 then
5405 if Found then
5406 It := Disambiguate (P, I1, I, Any_Type);
5408 if It = No_Interp then
5410 Set_Etype (N, Typ);
5411 return;
5412 else
5413 Found := True;
5414 Array_Type := It.Typ;
5415 I1 := I;
5416 end if;
5417 else
5418 Found := True;
5419 Array_Type := It.Typ;
5420 I1 := I;
5421 end if;
5422 end if;
5424 Get_Next_Interp (I, It);
5425 end loop;
5426 end;
5428 else
5429 Array_Type := Etype (Name);
5430 end if;
5432 Resolve (Name, Array_Type);
5434 if Is_Access_Type (Array_Type) then
5435 Apply_Access_Check (N);
5436 Array_Type := Designated_Type (Array_Type);
5438 elsif Is_Entity_Name (Name)
5439 or else (Nkind (Name) = N_Function_Call
5440 and then not Is_Constrained (Etype (Name)))
5441 then
5442 Array_Type := Get_Actual_Subtype (Name);
5443 end if;
5445 -- If name was overloaded, set slice type correctly now
5447 Set_Etype (N, Array_Type);
5449 -- If the range is specified by a subtype mark, no resolution
5450 -- is necessary.
5452 if not Is_Entity_Name (Drange) then
5453 Index := First_Index (Array_Type);
5454 Resolve (Drange, Base_Type (Etype (Index)));
5456 if Nkind (Drange) = N_Range then
5457 Apply_Range_Check (Drange, Etype (Index));
5458 end if;
5459 end if;
5461 Set_Slice_Subtype (N);
5462 Eval_Slice (N);
5464 end Resolve_Slice;
5466 ----------------------------
5467 -- Resolve_String_Literal --
5468 ----------------------------
5470 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
5471 C_Typ : constant Entity_Id := Component_Type (Typ);
5472 R_Typ : constant Entity_Id := Root_Type (C_Typ);
5473 Loc : constant Source_Ptr := Sloc (N);
5474 Str : constant String_Id := Strval (N);
5475 Strlen : constant Nat := String_Length (Str);
5476 Subtype_Id : Entity_Id;
5477 Need_Check : Boolean;
5479 begin
5480 -- For a string appearing in a concatenation, defer creation of the
5481 -- string_literal_subtype until the end of the resolution of the
5482 -- concatenation, because the literal may be constant-folded away.
5483 -- This is a useful optimization for long concatenation expressions.
5485 -- If the string is an aggregate built for a single character (which
5486 -- happens in a non-static context) or a is null string to which special
5487 -- checks may apply, we build the subtype. Wide strings must also get
5488 -- a string subtype if they come from a one character aggregate. Strings
5489 -- generated by attributes might be static, but it is often hard to
5490 -- determine whether the enclosing context is static, so we generate
5491 -- subtypes for them as well, thus losing some rarer optimizations ???
5492 -- Same for strings that come from a static conversion.
5494 Need_Check :=
5495 (Strlen = 0 and then Typ /= Standard_String)
5496 or else Nkind (Parent (N)) /= N_Op_Concat
5497 or else (N /= Left_Opnd (Parent (N))
5498 and then N /= Right_Opnd (Parent (N)))
5499 or else (Typ = Standard_Wide_String
5500 and then Nkind (Original_Node (N)) /= N_String_Literal);
5502 -- If the resolving type is itself a string literal subtype, we
5503 -- can just reuse it, since there is no point in creating another.
5505 if Ekind (Typ) = E_String_Literal_Subtype then
5506 Subtype_Id := Typ;
5508 elsif Nkind (Parent (N)) = N_Op_Concat
5509 and then not Need_Check
5510 and then Nkind (Original_Node (N)) /= N_Character_Literal
5511 and then Nkind (Original_Node (N)) /= N_Attribute_Reference
5512 and then Nkind (Original_Node (N)) /= N_Qualified_Expression
5513 and then Nkind (Original_Node (N)) /= N_Type_Conversion
5514 then
5515 Subtype_Id := Typ;
5517 -- Otherwise we must create a string literal subtype. Note that the
5518 -- whole idea of string literal subtypes is simply to avoid the need
5519 -- for building a full fledged array subtype for each literal.
5520 else
5521 Set_String_Literal_Subtype (N, Typ);
5522 Subtype_Id := Etype (N);
5523 end if;
5525 if Nkind (Parent (N)) /= N_Op_Concat
5526 or else Need_Check
5527 then
5528 Set_Etype (N, Subtype_Id);
5529 Eval_String_Literal (N);
5530 end if;
5532 if Is_Limited_Composite (Typ)
5533 or else Is_Private_Composite (Typ)
5534 then
5536 Set_Etype (N, Any_Type);
5537 return;
5538 end if;
5540 -- The validity of a null string has been checked in the
5541 -- call to Eval_String_Literal.
5543 if Strlen = 0 then
5544 return;
5546 -- Always accept string literal with component type Any_Character,
5547 -- which occurs in error situations and in comparisons of literals,
5548 -- both of which should accept all literals.
5550 elsif R_Typ = Any_Character then
5551 return;
5553 -- If the type is bit-packed, then we always tranform the string
5554 -- literal into a full fledged aggregate.
5556 elsif Is_Bit_Packed_Array (Typ) then
5557 null;
5559 -- Deal with cases of Wide_String and String
5561 else
5562 -- For Standard.Wide_String, or any other type whose component
5563 -- type is Standard.Wide_Character, we know that all the
5564 -- characters in the string must be acceptable, since the parser
5565 -- accepted the characters as valid character literals.
5567 if R_Typ = Standard_Wide_Character then
5568 null;
5570 -- For the case of Standard.String, or any other type whose
5571 -- component type is Standard.Character, we must make sure that
5572 -- there are no wide characters in the string, i.e. that it is
5573 -- entirely composed of characters in range of type String.
5575 -- If the string literal is the result of a static concatenation,
5576 -- the test has already been performed on the components, and need
5577 -- not be repeated.
5579 elsif R_Typ = Standard_Character
5580 and then Nkind (Original_Node (N)) /= N_Op_Concat
5581 then
5582 for J in 1 .. Strlen loop
5583 if not In_Character_Range (Get_String_Char (Str, J)) then
5585 -- If we are out of range, post error. This is one of the
5586 -- very few places that we place the flag in the middle of
5587 -- a token, right under the offending wide character.
5589 Error_Msg
5591 Source_Ptr (Int (Loc) + J));
5592 return;
5593 end if;
5594 end loop;
5596 -- If the root type is not a standard character, then we will convert
5597 -- the string into an aggregate and will let the aggregate code do
5598 -- the checking.
5600 else
5601 null;
5603 end if;
5605 -- See if the component type of the array corresponding to the
5606 -- string has compile time known bounds. If yes we can directly
5607 -- check whether the evaluation of the string will raise constraint
5608 -- error. Otherwise we need to transform the string literal into
5609 -- the corresponding character aggregate and let the aggregate
5610 -- code do the checking.
5612 if R_Typ = Standard_Wide_Character
5613 or else R_Typ = Standard_Character
5614 then
5615 -- Check for the case of full range, where we are definitely OK
5617 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
5618 return;
5619 end if;
5621 -- Here the range is not the complete base type range, so check
5623 declare
5624 Comp_Typ_Lo : constant Node_Id :=
5625 Type_Low_Bound (Component_Type (Typ));
5626 Comp_Typ_Hi : constant Node_Id :=
5627 Type_High_Bound (Component_Type (Typ));
5629 Char_Val : Uint;
5631 begin
5632 if Compile_Time_Known_Value (Comp_Typ_Lo)
5633 and then Compile_Time_Known_Value (Comp_Typ_Hi)
5634 then
5635 for J in 1 .. Strlen loop
5636 Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
5638 if Char_Val < Expr_Value (Comp_Typ_Lo)
5639 or else Char_Val > Expr_Value (Comp_Typ_Hi)
5640 then
5641 Apply_Compile_Time_Constraint_Error
5643 Loc => Source_Ptr (Int (Loc) + J));
5644 end if;
5645 end loop;
5647 return;
5648 end if;
5649 end;
5650 end if;
5651 end if;
5653 -- If we got here we meed to transform the string literal into the
5654 -- equivalent qualified positional array aggregate. This is rather
5655 -- heavy artillery for this situation, but it is hard work to avoid.
5657 declare
5658 Lits : List_Id := New_List;
5659 P : Source_Ptr := Loc + 1;
5660 C : Char_Code;
5662 begin
5663 -- Build the character literals, we give them source locations
5664 -- that correspond to the string positions, which is a bit tricky
5665 -- given the possible presence of wide character escape sequences.
5667 for J in 1 .. Strlen loop
5668 C := Get_String_Char (Str, J);
5669 Set_Character_Literal_Name (C);
5671 Append_To (Lits,
5672 Make_Character_Literal (P, Name_Find, C));
5674 if In_Character_Range (C) then
5675 P := P + 1;
5677 -- Should we have a call to Skip_Wide here ???
5678 -- ??? else
5679 -- Skip_Wide (P);
5681 end if;
5682 end loop;
5684 Rewrite (N,
5685 Make_Qualified_Expression (Loc,
5686 Subtype_Mark => New_Reference_To (Typ, Loc),
5687 Expression =>
5688 Make_Aggregate (Loc, Expressions => Lits)));
5690 Analyze_And_Resolve (N, Typ);
5691 end;
5692 end Resolve_String_Literal;
5694 -----------------------------
5695 -- Resolve_Subprogram_Info --
5696 -----------------------------
5698 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
5699 begin
5700 Set_Etype (N, Typ);
5701 end Resolve_Subprogram_Info;
5703 -----------------------------
5704 -- Resolve_Type_Conversion --
5705 -----------------------------
5707 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
5708 Target_Type : constant Entity_Id := Etype (N);
5709 Conv_OK : constant Boolean := Conversion_OK (N);
5710 Operand : Node_Id;
5711 Opnd_Type : Entity_Id;
5712 Rop : Node_Id;
5714 begin
5715 Operand := Expression (N);
5717 if not Conv_OK
5718 and then not Valid_Conversion (N, Target_Type, Operand)
5719 then
5720 return;
5721 end if;
5723 if Etype (Operand) = Any_Fixed then
5725 -- Mixed-mode operation involving a literal. Context must be a fixed
5726 -- type which is applied to the literal subsequently.
5728 if Is_Fixed_Point_Type (Typ) then
5729 Set_Etype (Operand, Universal_Real);
5731 elsif Is_Numeric_Type (Typ)
5732 and then (Nkind (Operand) = N_Op_Multiply
5733 or else Nkind (Operand) = N_Op_Divide)
5734 and then (Etype (Right_Opnd (Operand)) = Universal_Real
5735 or else Etype (Left_Opnd (Operand)) = Universal_Real)
5736 then
5737 if Unique_Fixed_Point_Type (N) = Any_Type then
5738 return; -- expression is ambiguous.
5739 else
5740 Set_Etype (Operand, Standard_Duration);
5741 end if;
5743 if Etype (Right_Opnd (Operand)) = Universal_Real then
5744 Rop := New_Copy_Tree (Right_Opnd (Operand));
5745 else
5746 Rop := New_Copy_Tree (Left_Opnd (Operand));
5747 end if;
5749 Resolve (Rop, Standard_Long_Long_Float);
5751 if Realval (Rop) /= Ureal_0
5752 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
5753 then
5755 Rop);
5757 end if;
5759 else
5761 Set_Etype (Operand, Any_Type);
5762 return;
5763 end if;
5764 end if;
5766 Opnd_Type := Etype (Operand);
5767 Resolve (Operand, Opnd_Type);
5769 -- Note: we do the Eval_Type_Conversion call before applying the
5770 -- required checks for a subtype conversion. This is important,
5771 -- since both are prepared under certain circumstances to change
5772 -- the type conversion to a constraint error node, but in the case
5773 -- of Eval_Type_Conversion this may reflect an illegality in the
5774 -- static case, and we would miss the illegality (getting only a
5775 -- warning message), if we applied the type conversion checks first.
5777 Eval_Type_Conversion (N);
5779 -- If after evaluation, we still have a type conversion, then we
5780 -- may need to apply checks required for a subtype conversion.
5782 -- Skip these type conversion checks if universal fixed operands
5783 -- operands involved, since range checks are handled separately for
5784 -- these cases (in the appropriate Expand routines in unit Exp_Fixd).
5786 if Nkind (N) = N_Type_Conversion
5787 and then not Is_Generic_Type (Root_Type (Target_Type))
5788 and then Target_Type /= Universal_Fixed
5789 and then Opnd_Type /= Universal_Fixed
5790 then
5791 Apply_Type_Conversion_Checks (N);
5792 end if;
5794 -- Issue warning for conversion of simple object to its own type
5796 if Warn_On_Redundant_Constructs
5797 and then Comes_From_Source (N)
5798 and then Nkind (N) = N_Type_Conversion
5799 and then Is_Entity_Name (Expression (N))
5800 and then Etype (Entity (Expression (N))) = Target_Type
5801 then
5802 Error_Msg_NE
5804 N, Entity (Expression (N)));
5805 end if;
5806 end Resolve_Type_Conversion;
5808 ----------------------
5809 -- Resolve_Unary_Op --
5810 ----------------------
5812 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
5813 B_Typ : Entity_Id := Base_Type (Typ);
5814 R : constant Node_Id := Right_Opnd (N);
5816 begin
5817 -- Generate warning for expressions like -5 mod 3
5819 if Paren_Count (N) = 0
5820 and then Nkind (N) = N_Op_Minus
5821 and then Nkind (Right_Opnd (N)) = N_Op_Mod
5822 then
5823 Error_Msg_N
5825 end if;
5827 if Etype (R) = Universal_Integer
5828 or else Etype (R) = Universal_Real
5829 then
5830 Check_For_Visible_Operator (N, B_Typ);
5831 end if;
5833 Set_Etype (N, B_Typ);
5834 Resolve (R, B_Typ);
5835 Check_Unset_Reference (R);
5836 Generate_Operator_Reference (N);
5837 Eval_Unary_Op (N);
5839 -- Set overflow checking bit. Much cleverer code needed here eventually
5840 -- and perhaps the Resolve routines should be separated for the various
5841 -- arithmetic operations, since they will need different processing ???
5843 if Nkind (N) in N_Op then
5844 if not Overflow_Checks_Suppressed (Etype (N)) then
5845 Set_Do_Overflow_Check (N, True);
5846 end if;
5847 end if;
5849 end Resolve_Unary_Op;
5851 ----------------------------------
5852 -- Resolve_Unchecked_Expression --
5853 ----------------------------------
5855 procedure Resolve_Unchecked_Expression
5856 (N : Node_Id;
5857 Typ : Entity_Id)
5858 is
5859 begin
5860 Resolve (Expression (N), Typ, Suppress => All_Checks);
5861 Set_Etype (N, Typ);
5862 end Resolve_Unchecked_Expression;
5864 ---------------------------------------
5865 -- Resolve_Unchecked_Type_Conversion --
5866 ---------------------------------------
5868 procedure Resolve_Unchecked_Type_Conversion
5869 (N : Node_Id;
5870 Typ : Entity_Id)
5871 is
5872 pragma Warnings (Off, Typ);
5874 Operand : constant Node_Id := Expression (N);
5875 Opnd_Type : constant Entity_Id := Etype (Operand);
5877 begin
5878 -- Resolve operand using its own type.
5880 Resolve (Operand, Opnd_Type);
5881 Eval_Unchecked_Conversion (N);
5883 end Resolve_Unchecked_Type_Conversion;
5885 ------------------------------
5886 -- Rewrite_Operator_As_Call --
5887 ------------------------------
5889 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
5890 Loc : Source_Ptr := Sloc (N);
5891 Actuals : List_Id := New_List;
5892 New_N : Node_Id;
5894 begin
5895 if Nkind (N) in N_Binary_Op then
5896 Append (Left_Opnd (N), Actuals);
5897 end if;
5899 Append (Right_Opnd (N), Actuals);
5901 New_N :=
5902 Make_Function_Call (Sloc => Loc,
5903 Name => New_Occurrence_Of (Nam, Loc),
5904 Parameter_Associations => Actuals);
5906 Preserve_Comes_From_Source (New_N, N);
5907 Preserve_Comes_From_Source (Name (New_N), N);
5908 Rewrite (N, New_N);
5909 Set_Etype (N, Etype (Nam));
5910 end Rewrite_Operator_As_Call;
5912 ------------------------------
5913 -- Rewrite_Renamed_Operator --
5914 ------------------------------
5916 procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
5917 Nam : constant Name_Id := Chars (Op);
5918 Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
5919 Op_Node : Node_Id;
5921 begin
5922 if Chars (N) /= Nam then
5924 -- Rewrite the operator node using the real operator, not its
5925 -- renaming.
5927 Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
5928 Set_Chars (Op_Node, Nam);
5929 Set_Etype (Op_Node, Etype (N));
5930 Set_Entity (Op_Node, Op);
5931 Set_Right_Opnd (Op_Node, Right_Opnd (N));
5933 Generate_Reference (Op, N);
5935 if Is_Binary then
5936 Set_Left_Opnd (Op_Node, Left_Opnd (N));
5937 end if;
5939 Rewrite (N, Op_Node);
5940 end if;
5941 end Rewrite_Renamed_Operator;
5943 -----------------------
5944 -- Set_Slice_Subtype --
5945 -----------------------
5947 -- Build an implicit subtype declaration to represent the type delivered
5948 -- by the slice. This is an abbreviated version of an array subtype. We
5949 -- define an index subtype for the slice, using either the subtype name
5950 -- or the discrete range of the slice. To be consistent with index usage
5951 -- elsewhere, we create a list header to hold the single index. This list
5952 -- is not otherwise attached to the syntax tree.
5954 procedure Set_Slice_Subtype (N : Node_Id) is
5955 Loc : constant Source_Ptr := Sloc (N);
5956 Index : Node_Id;
5957 Index_List : List_Id := New_List;
5958 Index_Subtype : Entity_Id;
5959 Index_Type : Entity_Id;
5960 Slice_Subtype : Entity_Id;
5961 Drange : constant Node_Id := Discrete_Range (N);
5963 begin
5964 if Is_Entity_Name (Drange) then
5965 Index_Subtype := Entity (Drange);
5967 else
5968 -- We force the evaluation of a range. This is definitely needed in
5969 -- the renamed case, and seems safer to do unconditionally. Note in
5970 -- any case that since we will create and insert an Itype referring
5971 -- to this range, we must make sure any side effect removal actions
5972 -- are inserted before the Itype definition.
5974 if Nkind (Drange) = N_Range then
5975 Force_Evaluation (Low_Bound (Drange));
5976 Force_Evaluation (High_Bound (Drange));
5977 end if;
5979 Index_Type := Base_Type (Etype (Drange));
5981 Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
5983 Set_Scalar_Range (Index_Subtype, Drange);
5984 Set_Etype (Index_Subtype, Index_Type);
5985 Set_Size_Info (Index_Subtype, Index_Type);
5986 Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
5987 end if;
5989 Slice_Subtype := Create_Itype (E_Array_Subtype, N);
5991 Index := New_Occurrence_Of (Index_Subtype, Loc);
5992 Set_Etype (Index, Index_Subtype);
5993 Append (Index, Index_List);
5995 Set_First_Index (Slice_Subtype, Index);
5996 Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
5997 Set_Is_Constrained (Slice_Subtype, True);
5998 Init_Size_Align (Slice_Subtype);
6000 Check_Compile_Time_Size (Slice_Subtype);
6002 -- The Etype of the existing Slice node is reset to this slice
6003 -- subtype. Its bounds are obtained from its first index.
6005 Set_Etype (N, Slice_Subtype);
6007 -- In the packed case, this must be immediately frozen
6009 -- Couldn't we always freeze here??? and if we did, then the above
6010 -- call to Check_Compile_Time_Size could be eliminated, which would
6011 -- be nice, because then that routine could be made private to Freeze.
6013 if Is_Packed (Slice_Subtype) and not In_Default_Expression then
6014 Freeze_Itype (Slice_Subtype, N);
6015 end if;
6017 end Set_Slice_Subtype;
6019 --------------------------------
6020 -- Set_String_Literal_Subtype --
6021 --------------------------------
6023 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
6024 Subtype_Id : Entity_Id;
6026 begin
6027 if Nkind (N) /= N_String_Literal then
6028 return;
6029 else
6030 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
6031 end if;
6033 Set_String_Literal_Length (Subtype_Id,
6034 UI_From_Int (String_Length (Strval (N))));
6035 Set_Etype (Subtype_Id, Base_Type (Typ));
6036 Set_Is_Constrained (Subtype_Id);
6038 -- The low bound is set from the low bound of the corresponding
6039 -- index type. Note that we do not store the high bound in the
6040 -- string literal subtype, but it can be deduced if necssary
6041 -- from the length and the low bound.
6043 Set_String_Literal_Low_Bound
6044 (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
6046 Set_Etype (N, Subtype_Id);
6047 end Set_String_Literal_Subtype;
6049 -----------------------------
6050 -- Unique_Fixed_Point_Type --
6051 -----------------------------
6053 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
6054 T1 : Entity_Id := Empty;
6055 T2 : Entity_Id;
6056 Item : Node_Id;
6057 Scop : Entity_Id;
6059 procedure Fixed_Point_Error;
6060 -- If true ambiguity, give details.
6062 procedure Fixed_Point_Error is
6063 begin
6067 end Fixed_Point_Error;
6069 begin
6070 -- The operations on Duration are visible, so Duration is always a
6071 -- possible interpretation.
6073 T1 := Standard_Duration;
6075 Scop := Current_Scope;
6077 -- Look for fixed-point types in enclosing scopes.
6079 while Scop /= Standard_Standard loop
6080 T2 := First_Entity (Scop);
6082 while Present (T2) loop
6083 if Is_Fixed_Point_Type (T2)
6084 and then Current_Entity (T2) = T2
6085 and then Scope (Base_Type (T2)) = Scop
6086 then
6087 if Present (T1) then
6088 Fixed_Point_Error;
6089 return Any_Type;
6090 else
6091 T1 := T2;
6092 end if;
6093 end if;
6095 Next_Entity (T2);
6096 end loop;
6098 Scop := Scope (Scop);
6099 end loop;
6101 -- Look for visible fixed type declarations in the context.
6103 Item := First (Context_Items (Cunit (Current_Sem_Unit)));
6105 while Present (Item) loop
6107 if Nkind (Item) = N_With_Clause then
6108 Scop := Entity (Name (Item));
6109 T2 := First_Entity (Scop);
6111 while Present (T2) loop
6112 if Is_Fixed_Point_Type (T2)
6113 and then Scope (Base_Type (T2)) = Scop
6114 and then (Is_Potentially_Use_Visible (T2)
6115 or else In_Use (T2))
6116 then
6117 if Present (T1) then
6118 Fixed_Point_Error;
6119 return Any_Type;
6120 else
6121 T1 := T2;
6122 end if;
6123 end if;
6125 Next_Entity (T2);
6126 end loop;
6127 end if;
6129 Next (Item);
6130 end loop;
6132 if Nkind (N) = N_Real_Literal then
6135 else
6137 end if;
6139 return T1;
6140 end Unique_Fixed_Point_Type;
6142 ----------------------
6143 -- Valid_Conversion --
6144 ----------------------
6146 function Valid_Conversion
6147 (N : Node_Id;
6148 Target : Entity_Id;
6149 Operand : Node_Id)
6150 return Boolean
6151 is
6152 Target_Type : Entity_Id := Base_Type (Target);
6153 Opnd_Type : Entity_Id := Etype (Operand);
6155 function Conversion_Check
6156 (Valid : Boolean;
6157 Msg : String)
6158 return Boolean;
6159 -- Little routine to post Msg if Valid is False, returns Valid value
6161 function Valid_Tagged_Conversion
6162 (Target_Type : Entity_Id;
6163 Opnd_Type : Entity_Id)
6164 return Boolean;
6165 -- Specifically test for validity of tagged conversions
6167 ----------------------
6168 -- Conversion_Check --
6169 ----------------------
6171 function Conversion_Check
6172 (Valid : Boolean;
6173 Msg : String)
6174 return Boolean
6175 is
6176 begin
6177 if not Valid then
6178 Error_Msg_N (Msg, Operand);
6179 end if;
6181 return Valid;
6182 end Conversion_Check;
6184 -----------------------------
6185 -- Valid_Tagged_Conversion --
6186 -----------------------------
6188 function Valid_Tagged_Conversion
6189 (Target_Type : Entity_Id;
6190 Opnd_Type : Entity_Id)
6191 return Boolean
6192 is
6193 begin
6194 -- Upward conversions are allowed (RM 4.6(22)).
6196 if Covers (Target_Type, Opnd_Type)
6197 or else Is_Ancestor (Target_Type, Opnd_Type)
6198 then
6199 return True;
6201 -- Downward conversion are allowed if the operand is
6202 -- is class-wide (RM 4.6(23)).
6204 elsif Is_Class_Wide_Type (Opnd_Type)
6205 and then Covers (Opnd_Type, Target_Type)
6206 then
6207 return True;
6209 elsif Covers (Opnd_Type, Target_Type)
6210 or else Is_Ancestor (Opnd_Type, Target_Type)
6211 then
6212 return
6213 Conversion_Check (False,
6215 else
6216 Error_Msg_NE
6218 N, First_Subtype (Opnd_Type));
6219 return False;
6220 end if;
6221 end Valid_Tagged_Conversion;
6223 -- Start of processing for Valid_Conversion
6225 begin
6226 Check_Parameterless_Call (Operand);
6228 if Is_Overloaded (Operand) then
6229 declare
6230 I : Interp_Index;
6231 I1 : Interp_Index;
6232 It : Interp;
6233 It1 : Interp;
6234 N1 : Entity_Id;
6236 begin
6237 -- Remove procedure calls, which syntactically cannot appear
6238 -- in this context, but which cannot be removed by type checking,
6239 -- because the context does not impose a type.
6241 Get_First_Interp (Operand, I, It);
6243 while Present (It.Typ) loop
6245 if It.Typ = Standard_Void_Type then
6246 Remove_Interp (I);
6247 end if;
6249 Get_Next_Interp (I, It);
6250 end loop;
6252 Get_First_Interp (Operand, I, It);
6253 I1 := I;
6254 It1 := It;
6256 if No (It.Typ) then
6258 return False;
6259 end if;
6261 Get_Next_Interp (I, It);
6263 if Present (It.Typ) then
6264 N1 := It1.Nam;
6265 It1 := Disambiguate (Operand, I1, I, Any_Type);
6267 if It1 = No_Interp then
6270 Error_Msg_Sloc := Sloc (It.Nam);
6273 Error_Msg_Sloc := Sloc (N1);
6276 return False;
6277 end if;
6278 end if;
6280 Set_Etype (Operand, It1.Typ);
6281 Opnd_Type := It1.Typ;
6282 end;
6283 end if;
6285 if Chars (Current_Scope) = Name_Unchecked_Conversion then
6287 -- This check is dubious, what if there were a user defined
6288 -- scope whose name was Unchecked_Conversion ???
6290 return True;
6292 elsif Is_Numeric_Type (Target_Type) then
6293 if Opnd_Type = Universal_Fixed then
6294 return True;
6295 else
6296 return Conversion_Check (Is_Numeric_Type (Opnd_Type),
6298 end if;
6300 elsif Is_Array_Type (Target_Type) then
6301 if not Is_Array_Type (Opnd_Type)
6302 or else Opnd_Type = Any_Composite
6303 or else Opnd_Type = Any_String
6304 then
6305 Error_Msg_N
6307 return False;
6309 elsif Number_Dimensions (Target_Type) /=
6310 Number_Dimensions (Opnd_Type)
6311 then
6312 Error_Msg_N
6314 return False;
6316 else
6317 declare
6318 Target_Index : Node_Id := First_Index (Target_Type);
6319 Opnd_Index : Node_Id := First_Index (Opnd_Type);
6321 Target_Index_Type : Entity_Id;
6322 Opnd_Index_Type : Entity_Id;
6324 Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
6325 Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
6327 begin
6328 while Present (Target_Index) and then Present (Opnd_Index) loop
6329 Target_Index_Type := Etype (Target_Index);
6330 Opnd_Index_Type := Etype (Opnd_Index);
6332 if not (Is_Integer_Type (Target_Index_Type)
6333 and then Is_Integer_Type (Opnd_Index_Type))
6334 and then (Root_Type (Target_Index_Type)
6335 /= Root_Type (Opnd_Index_Type))
6336 then
6337 Error_Msg_N
6339 Operand);
6340 return False;
6341 end if;
6343 Next_Index (Target_Index);
6344 Next_Index (Opnd_Index);
6345 end loop;
6347 if Base_Type (Target_Comp_Type) /=
6348 Base_Type (Opnd_Comp_Type)
6349 then
6350 Error_Msg_N
6352 Operand);
6353 return False;
6355 elsif
6356 Is_Constrained (Target_Comp_Type)
6357 /= Is_Constrained (Opnd_Comp_Type)
6358 or else not Subtypes_Statically_Match
6359 (Target_Comp_Type, Opnd_Comp_Type)
6360 then
6361 Error_Msg_N
6363 return False;
6365 end if;
6366 end;
6367 end if;
6369 return True;
6371 elsif (Ekind (Target_Type) = E_General_Access_Type
6372 or else Ekind (Target_Type) = E_Anonymous_Access_Type)
6373 and then
6374 Conversion_Check
6375 (Is_Access_Type (Opnd_Type)
6376 and then Ekind (Opnd_Type) /=
6377 E_Access_Subprogram_Type
6378 and then Ekind (Opnd_Type) /=
6379 E_Access_Protected_Subprogram_Type,
6381 then
6382 if Is_Access_Constant (Opnd_Type)
6383 and then not Is_Access_Constant (Target_Type)
6384 then
6385 Error_Msg_N
6387 return False;
6388 end if;
6390 -- Check the static accessibility rule of 4.6(17). Note that
6391 -- the check is not enforced when within an instance body, since
6392 -- the RM requires such cases to be caught at run time.
6394 if Ekind (Target_Type) /= E_Anonymous_Access_Type then
6395 if Type_Access_Level (Opnd_Type)
6396 > Type_Access_Level (Target_Type)
6397 then
6398 -- In an instance, this is a run-time check, but one we
6399 -- know will fail, so generate an appropriate warning.
6400 -- The raise will be generated by Expand_N_Type_Conversion.
6402 if In_Instance_Body then
6403 Error_Msg_N
6405 Operand);
6406 Error_Msg_N
6409 else
6410 Error_Msg_N
6412 Operand);
6413 return False;
6414 end if;
6416 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
6418 -- When the operand is a selected access discriminant
6419 -- the check needs to be made against the level of the
6420 -- object denoted by the prefix of the selected name.
6421 -- (Object_Access_Level handles checking the prefix
6422 -- of the operand for this case.)
6424 if Nkind (Operand) = N_Selected_Component
6425 and then Object_Access_Level (Operand)
6426 > Type_Access_Level (Target_Type)
6427 then
6428 -- In an instance, this is a run-time check, but one we
6429 -- know will fail, so generate an appropriate warning.
6430 -- The raise will be generated by Expand_N_Type_Conversion.
6432 if In_Instance_Body then
6433 Error_Msg_N
6436 Error_Msg_N
6439 else
6440 Error_Msg_N
6443 return False;
6444 end if;
6445 end if;
6447 -- The case of a reference to an access discriminant
6448 -- from within a type declaration (which will appear
6449 -- as a discriminal) is always illegal because the
6450 -- level of the discriminant is considered to be
6451 -- deeper than any (namable) access type.
6453 if Is_Entity_Name (Operand)
6454 and then (Ekind (Entity (Operand)) = E_In_Parameter
6455 or else Ekind (Entity (Operand)) = E_Constant)
6456 and then Present (Discriminal_Link (Entity (Operand)))
6457 then
6458 Error_Msg_N
6460 Operand);
6461 return False;
6462 end if;
6463 end if;
6464 end if;
6466 declare
6467 Target : constant Entity_Id := Designated_Type (Target_Type);
6468 Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
6470 begin
6471 if Is_Tagged_Type (Target) then
6472 return Valid_Tagged_Conversion (Target, Opnd);
6474 else
6475 if Base_Type (Target) /= Base_Type (Opnd) then
6476 Error_Msg_NE
6478 N, Base_Type (Opnd));
6479 return False;
6481 elsif not Subtypes_Statically_Match (Target, Opnd)
6482 and then (not Has_Discriminants (Target)
6483 or else Is_Constrained (Target))
6484 then
6485 Error_Msg_NE
6487 N, Opnd);
6488 return False;
6490 else
6491 return True;
6492 end if;
6493 end if;
6494 end;
6496 elsif Ekind (Target_Type) = E_Access_Subprogram_Type
6497 and then Conversion_Check
6498 (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
6500 then
6501 -- Check that the designated types are subtype conformant
6503 if not Subtype_Conformant (Designated_Type (Opnd_Type),
6504 Designated_Type (Target_Type))
6505 then
6506 Error_Msg_N
6508 Operand);
6509 end if;
6511 -- Check the static accessibility rule of 4.6(20)
6513 if Type_Access_Level (Opnd_Type) >
6514 Type_Access_Level (Target_Type)
6515 then
6516 Error_Msg_N
6518 Operand);
6520 -- Check that if the operand type is declared in a generic body,
6521 -- then the target type must be declared within that same body
6522 -- (enforces last sentence of 4.6(20)).
6524 elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
6525 declare
6526 O_Gen : constant Node_Id :=
6527 Enclosing_Generic_Body (Opnd_Type);
6529 T_Gen : Node_Id :=
6530 Enclosing_Generic_Body (Target_Type);
6532 begin
6533 while Present (T_Gen) and then T_Gen /= O_Gen loop
6534 T_Gen := Enclosing_Generic_Body (T_Gen);
6535 end loop;
6537 if T_Gen /= O_Gen then
6538 Error_Msg_N
6541 end if;
6542 end;
6543 end if;
6545 return True;
6547 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
6548 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
6549 then
6550 -- It is valid to convert from one RAS type to another provided
6551 -- that their specification statically match.
6553 Check_Subtype_Conformant
6554 (New_Id =>
6555 Designated_Type (Corresponding_Remote_Type (Target_Type)),
6556 Old_Id =>
6557 Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
6558 Err_Loc =>
6559 N);
6560 return True;
6562 elsif Is_Tagged_Type (Target_Type) then
6563 return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
6565 -- Types derived from the same root type are convertible.
6567 elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
6568 return True;
6570 -- In an instance, there may be inconsistent views of the same
6571 -- type, or types derived from the same type.
6573 elsif In_Instance
6574 and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
6575 then
6576 return True;
6578 -- Special check for common access type error case
6580 elsif Ekind (Target_Type) = E_Access_Type
6581 and then Is_Access_Type (Opnd_Type)
6582 then
6586 return False;
6588 else
6590 N, Opnd_Type);
6592 return False;
6593 end if;
6594 end Valid_Conversion;
6596 end Sem_Res;