1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Debug_A
; use Debug_A
;
31 with Einfo
; use Einfo
;
32 with Errout
; use Errout
;
33 with Expander
; use Expander
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Util
; use Exp_Util
;
36 with Freeze
; use Freeze
;
37 with Itypes
; use Itypes
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Namet
; use Namet
;
41 with Nmake
; use Nmake
;
42 with Nlists
; use Nlists
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Aggr
; use Sem_Aggr
;
49 with Sem_Attr
; use Sem_Attr
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch4
; use Sem_Ch4
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Dist
; use Sem_Dist
;
56 with Sem_Elab
; use Sem_Elab
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Intr
; use Sem_Intr
;
59 with Sem_Util
; use Sem_Util
;
60 with Sem_Type
; use Sem_Type
;
61 with Sem_Warn
; use Sem_Warn
;
62 with Sinfo
; use Sinfo
;
63 with Stand
; use Stand
;
64 with Stringt
; use Stringt
;
65 with Targparm
; use Targparm
;
66 with Tbuild
; use Tbuild
;
67 with Uintp
; use Uintp
;
68 with Urealp
; use Urealp
;
70 package body Sem_Res
is
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
85 procedure Ambiguous_Character
(C
: Node_Id
);
86 -- Give list of candidate interpretations when a character literal cannot
89 procedure Check_Discriminant_Use
(N
: Node_Id
);
90 -- Enforce the restrictions on the use of discriminants when constraining
91 -- a component of a discriminated type (record or concurrent type).
93 procedure Check_For_Visible_Operator
(N
: Node_Id
; T
: Entity_Id
);
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.
99 function Check_Infinite_Recursion
(N
: Node_Id
) return Boolean;
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.
105 procedure Check_Initialization_Call
(N
: Entity_Id
; Nam
: Entity_Id
);
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?
112 function Is_Predefined_Op
(Nam
: Entity_Id
) return Boolean;
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.
118 procedure Replace_Actual_Discriminants
(N
: Node_Id
; Default
: Node_Id
);
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.
123 procedure Resolve_Allocator
(N
: Node_Id
; Typ
: Entity_Id
);
124 procedure Resolve_Arithmetic_Op
(N
: Node_Id
; Typ
: Entity_Id
);
125 procedure Resolve_Call
(N
: Node_Id
; Typ
: Entity_Id
);
126 procedure Resolve_Character_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
127 procedure Resolve_Comparison_Op
(N
: Node_Id
; Typ
: Entity_Id
);
128 procedure Resolve_Conditional_Expression
(N
: Node_Id
; Typ
: Entity_Id
);
129 procedure Resolve_Equality_Op
(N
: Node_Id
; Typ
: Entity_Id
);
130 procedure Resolve_Explicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
);
131 procedure Resolve_Entity_Name
(N
: Node_Id
; Typ
: Entity_Id
);
132 procedure Resolve_Indexed_Component
(N
: Node_Id
; Typ
: Entity_Id
);
133 procedure Resolve_Integer_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
134 procedure Resolve_Logical_Op
(N
: Node_Id
; Typ
: Entity_Id
);
135 procedure Resolve_Membership_Op
(N
: Node_Id
; Typ
: Entity_Id
);
136 procedure Resolve_Null
(N
: Node_Id
; Typ
: Entity_Id
);
137 procedure Resolve_Operator_Symbol
(N
: Node_Id
; Typ
: Entity_Id
);
138 procedure Resolve_Op_Concat
(N
: Node_Id
; Typ
: Entity_Id
);
139 procedure Resolve_Op_Expon
(N
: Node_Id
; Typ
: Entity_Id
);
140 procedure Resolve_Op_Not
(N
: Node_Id
; Typ
: Entity_Id
);
141 procedure Resolve_Qualified_Expression
(N
: Node_Id
; Typ
: Entity_Id
);
142 procedure Resolve_Range
(N
: Node_Id
; Typ
: Entity_Id
);
143 procedure Resolve_Real_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
144 procedure Resolve_Reference
(N
: Node_Id
; Typ
: Entity_Id
);
145 procedure Resolve_Selected_Component
(N
: Node_Id
; Typ
: Entity_Id
);
146 procedure Resolve_Shift
(N
: Node_Id
; Typ
: Entity_Id
);
147 procedure Resolve_Short_Circuit
(N
: Node_Id
; Typ
: Entity_Id
);
148 procedure Resolve_Slice
(N
: Node_Id
; Typ
: Entity_Id
);
149 procedure Resolve_String_Literal
(N
: Node_Id
; Typ
: Entity_Id
);
150 procedure Resolve_Subprogram_Info
(N
: Node_Id
; Typ
: Entity_Id
);
151 procedure Resolve_Type_Conversion
(N
: Node_Id
; Typ
: Entity_Id
);
152 procedure Resolve_Unary_Op
(N
: Node_Id
; Typ
: Entity_Id
);
153 procedure Resolve_Unchecked_Expression
(N
: Node_Id
; Typ
: Entity_Id
);
154 procedure Resolve_Unchecked_Type_Conversion
(N
: Node_Id
; Typ
: Entity_Id
);
156 function Operator_Kind
160 -- Utility to map the name of an operator into the corresponding Node. Used
161 -- by other node rewriting procedures.
163 procedure Resolve_Actuals
(N
: Node_Id
; Nam
: Entity_Id
);
164 -- Resolve actuals of call, and add default expressions for missing ones.
166 procedure Resolve_Entry_Call
(N
: Node_Id
; Typ
: Entity_Id
);
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.
173 procedure Resolve_Intrinsic_Operator
(N
: Node_Id
; Typ
: Entity_Id
);
174 -- A call to a user-defined intrinsic operator is rewritten as a call
175 -- to the corresponding predefined operator, with suitable conversions.
177 procedure Rewrite_Operator_As_Call
(N
: Node_Id
; Nam
: Entity_Id
);
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.
190 procedure Rewrite_Renamed_Operator
(N
: Node_Id
; Op
: Entity_Id
);
191 -- An operator can rename another, e.g. in an instantiation. In that
192 -- case, the proper operator node must be constructed.
194 procedure Set_String_Literal_Subtype
(N
: Node_Id
; Typ
: Entity_Id
);
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.
199 procedure Set_Slice_Subtype
(N
: Node_Id
);
200 -- Build subtype of array type, with the range specified by the slice.
202 function Unique_Fixed_Point_Type
(N
: Node_Id
) return Entity_Id
;
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 -------------------------
222 procedure Ambiguous_Character
(C
: Node_Id
) is
226 if Nkind
(C
) = N_Character_Literal
then
227 Error_Msg_N
("ambiguous character literal", C
);
229 ("\possible interpretations: Character, Wide_Character!", C
);
231 E
:= Current_Entity
(C
);
235 while Present
(E
) loop
236 Error_Msg_NE
("\possible interpretation:}!", C
, Etype
(E
));
241 end Ambiguous_Character
;
243 -------------------------
244 -- Analyze_And_Resolve --
245 -------------------------
247 procedure Analyze_And_Resolve
(N
: Node_Id
) is
250 Resolve
(N
, Etype
(N
));
251 end Analyze_And_Resolve
;
253 procedure Analyze_And_Resolve
(N
: Node_Id
; Typ
: Entity_Id
) is
257 end Analyze_And_Resolve
;
259 -- Version withs check(s) suppressed
261 procedure Analyze_And_Resolve
266 Scop
: Entity_Id
:= Current_Scope
;
269 if Suppress
= All_Checks
then
271 Svg
: constant Suppress_Record
:= Scope_Suppress
;
274 Scope_Suppress
:= (others => True);
275 Analyze_And_Resolve
(N
, Typ
);
276 Scope_Suppress
:= Svg
;
281 Svg
: constant Boolean := Get_Scope_Suppress
(Suppress
);
284 Set_Scope_Suppress
(Suppress
, True);
285 Analyze_And_Resolve
(N
, Typ
);
286 Set_Scope_Suppress
(Suppress
, Svg
);
290 if Current_Scope
/= Scop
291 and then Scope_Is_Transient
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.
299 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Scope_Suppress
:=
302 end Analyze_And_Resolve
;
304 procedure Analyze_And_Resolve
308 Scop
: Entity_Id
:= Current_Scope
;
311 if Suppress
= All_Checks
then
313 Svg
: constant Suppress_Record
:= Scope_Suppress
;
316 Scope_Suppress
:= (others => True);
317 Analyze_And_Resolve
(N
);
318 Scope_Suppress
:= Svg
;
323 Svg
: constant Boolean := Get_Scope_Suppress
(Suppress
);
326 Set_Scope_Suppress
(Suppress
, True);
327 Analyze_And_Resolve
(N
);
328 Set_Scope_Suppress
(Suppress
, Svg
);
332 if Current_Scope
/= Scop
333 and then Scope_Is_Transient
335 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Scope_Suppress
:=
338 end Analyze_And_Resolve
;
340 ----------------------------
341 -- Check_Discriminant_Use --
342 ----------------------------
344 procedure Check_Discriminant_Use
(N
: Node_Id
) is
345 PN
: constant Node_Id
:= Parent
(N
);
346 Disc
: constant Entity_Id
:= Entity
(N
);
351 -- Any use in a default expression is legal.
353 if In_Default_Expression
then
356 elsif Nkind
(PN
) = N_Range
then
358 -- Discriminant cannot be used to constrain a scalar type.
362 if Nkind
(P
) = N_Range_Constraint
363 and then Nkind
(Parent
(P
)) = N_Subtype_Indication
364 and then Nkind
(Parent
(Parent
(P
))) = N_Component_Declaration
366 Error_Msg_N
("discriminant cannot constrain scalar type", N
);
368 elsif Nkind
(P
) = N_Index_Or_Discriminant_Constraint
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
386 if Ekind
(Current_Scope
) = E_Record_Type
387 and then Scope
(Disc
) = Current_Scope
389 (Nkind
(Parent
(P
)) = N_Subtype_Indication
391 (Nkind
(Parent
(Parent
(P
))) = N_Component_Declaration
392 or else Nkind
(Parent
(Parent
(P
))) = N_Subtype_Declaration
)
393 and then Paren_Count
(N
) = 0)
396 ("discriminant must appear alone in component constraint", N
);
400 -- Detect a common beginner error:
401 -- type R (D : Positive := 100) is record
402 -- Name: String (1 .. D);
405 -- The default value causes an object of type R to be
406 -- allocated with room for Positive'Last characters.
414 function Large_Storage_Type
(T
: Entity_Id
) return Boolean;
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.
419 function Large_Storage_Type
(T
: Entity_Id
) return Boolean is
424 T
= Standard_Positive
426 T
= Standard_Natural
;
427 end Large_Storage_Type
;
430 -- Check that the Disc has a large range
432 if not Large_Storage_Type
(Etype
(Disc
)) then
436 -- If the enclosing type is limited, we allocate only the
437 -- default value, not the maximum, and there is no need for
440 if Is_Limited_Type
(Scope
(Disc
)) then
444 -- Check that it is the high bound
446 if N
/= High_Bound
(PN
)
447 or else not Present
(Discriminant_Default_Value
(Disc
))
452 -- Check the array allows a large range at this bound.
453 -- First find the array
457 if Nkind
(SI
) /= N_Subtype_Indication
then
461 T
:= Entity
(Subtype_Mark
(SI
));
463 if not Is_Array_Type
(T
) then
467 -- Next, find the dimension
469 TB
:= First_Index
(T
);
470 CB
:= First
(Constraints
(P
));
472 and then Present
(TB
)
473 and then Present
(CB
)
484 -- Now, check the dimension has a large range
486 if not Large_Storage_Type
(Etype
(TB
)) then
490 -- Warn about the danger
493 ("creation of object of this type may raise Storage_Error?",
502 -- Legal case is in index or discriminant constraint
504 elsif Nkind
(PN
) = N_Index_Or_Discriminant_Constraint
505 or else Nkind
(PN
) = N_Discriminant_Association
507 if Paren_Count
(N
) > 0 then
509 ("discriminant in constraint must appear alone", N
);
514 -- Otherwise, context is an expression. It should not be within
515 -- (i.e. a subexpression of) a constraint for a component.
521 while Nkind
(P
) /= N_Component_Declaration
522 and then Nkind
(P
) /= N_Subtype_Indication
523 and then Nkind
(P
) /= N_Entry_Declaration
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.
535 if (Nkind
(P
) = N_Subtype_Indication
537 (Nkind
(Parent
(P
)) = N_Component_Declaration
538 or else Nkind
(Parent
(P
)) = N_Derived_Type_Definition
)
539 and then D
= Constraint
(P
))
541 -- The constraint itself may be given by a subtype indication,
542 -- rather than by a more common discrete range.
544 or else (Nkind
(P
) = N_Subtype_Indication
545 and then Nkind
(Parent
(P
)) = N_Index_Or_Discriminant_Constraint
)
547 or else Nkind
(P
) = N_Entry_Declaration
548 or else Nkind
(D
) = N_Defining_Identifier
551 ("discriminant in constraint must appear alone", N
);
554 end Check_Discriminant_Use
;
556 --------------------------------
557 -- Check_For_Visible_Operator --
558 --------------------------------
560 procedure Check_For_Visible_Operator
(N
: Node_Id
; T
: Entity_Id
) is
561 Orig_Node
: Node_Id
:= Original_Node
(N
);
564 if Comes_From_Source
(Orig_Node
)
565 and then not In_Open_Scopes
(Scope
(T
))
566 and then not Is_Potentially_Use_Visible
(T
)
567 and then not In_Use
(T
)
568 and then not In_Use
(Scope
(T
))
569 and then (not Present
(Entity
(N
))
570 or else Ekind
(Entity
(N
)) /= E_Function
)
571 and then (Nkind
(Orig_Node
) /= N_Function_Call
572 or else Nkind
(Name
(Orig_Node
)) /= N_Expanded_Name
573 or else Entity
(Prefix
(Name
(Orig_Node
))) /= Scope
(T
))
574 and then not In_Instance
577 ("operator for} is not directly visible!", N
, First_Subtype
(T
));
578 Error_Msg_N
("use clause would make operation legal!", N
);
580 end Check_For_Visible_Operator
;
582 ------------------------------
583 -- Check_Infinite_Recursion --
584 ------------------------------
586 function Check_Infinite_Recursion
(N
: Node_Id
) return Boolean is
590 function Same_Argument_List
return Boolean;
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 ------------------------
598 function Same_Argument_List
return Boolean is
604 if not Is_Entity_Name
(Name
(N
)) then
607 Subp
:= Entity
(Name
(N
));
610 F
:= First_Formal
(Subp
);
611 A
:= First_Actual
(N
);
613 while Present
(F
) and then Present
(A
) loop
614 if not Is_Entity_Name
(A
)
615 or else Entity
(A
) /= F
625 end Same_Argument_List
;
627 -- Start of processing for Check_Infinite_Recursion
630 -- Loop moving up tree, quitting if something tells us we are
631 -- definitely not in an infinite recursion situation.
636 exit when Nkind
(P
) = N_Subprogram_Body
;
638 if Nkind
(P
) = N_Or_Else
or else
639 Nkind
(P
) = N_And_Then
or else
640 Nkind
(P
) = N_If_Statement
or else
641 Nkind
(P
) = N_Case_Statement
645 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
646 and then C
/= First
(Statements
(P
))
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
657 -- raise Program_Error;
661 -- for generating a stub function
663 if Nkind
(Parent
(N
)) = N_Return_Statement
664 and then Same_Argument_List
666 exit when not Is_List_Member
(Parent
(N
))
667 or else (Nkind
(Prev
(Parent
(N
))) /= N_Raise_Statement
669 (Nkind
(Prev
(Parent
(N
))) not in N_Raise_xxx_Error
671 Present
(Condition
(Prev
(Parent
(N
))))));
681 Warn_On_Instance
:= True;
682 Error_Msg_N
("possible infinite recursion?", N
);
683 Error_Msg_N
("\Storage_Error may be raised at run time?", N
);
684 Warn_On_Instance
:= False;
687 end Check_Infinite_Recursion
;
689 -------------------------------
690 -- Check_Initialization_Call --
691 -------------------------------
693 procedure Check_Initialization_Call
(N
: Entity_Id
; Nam
: Entity_Id
) is
694 Typ
: Entity_Id
:= Etype
(First_Formal
(Nam
));
696 function Uses_SS
(T
: Entity_Id
) return Boolean;
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.
707 function Uses_SS
(T
: Entity_Id
) return Boolean is
712 if Is_Controlled
(T
) then
715 elsif Is_Array_Type
(T
) then
716 return Uses_SS
(Component_Type
(T
));
718 elsif Is_Record_Type
(T
) then
719 Comp
:= First_Component
(T
);
721 while Present
(Comp
) loop
723 if Ekind
(Comp
) = E_Component
724 and then Nkind
(Parent
(Comp
)) = N_Component_Declaration
726 Expr
:= Expression
(Parent
(Comp
));
728 if Nkind
(Expr
) = N_Function_Call
729 and then Requires_Transient_Scope
(Etype
(Expr
))
733 elsif Uses_SS
(Etype
(Comp
)) then
738 Next_Component
(Comp
);
748 -- Start of processing for Check_Initialization_Call
751 -- Nothing to do if functions do not use the secondary stack for
752 -- returns (i.e. they use a depressed stack pointer instead).
754 if Functions_Return_By_DSP_On_Target
then
757 -- Otherwise establish a transient scope if the type needs it
759 elsif Uses_SS
(Typ
) then
760 Establish_Transient_Scope
(First_Actual
(N
), Sec_Stack
=> True);
762 end Check_Initialization_Call
;
764 ------------------------------
765 -- Check_Parameterless_Call --
766 ------------------------------
768 procedure Check_Parameterless_Call
(N
: Node_Id
) is
772 -- Defend against junk stuff if errors already detected
774 if Total_Errors_Detected
/= 0 then
775 if Nkind
(N
) in N_Has_Etype
and then Etype
(N
) = Any_Type
then
777 elsif Nkind
(N
) in N_Has_Chars
778 and then Chars
(N
) in Error_Name_Or_No_Name
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.
788 if (Is_Entity_Name
(N
)
789 and then Is_Overloadable
(Entity
(N
))
790 and then (Ekind
(Entity
(N
)) /= E_Enumeration_Literal
791 or else Is_Overloaded
(N
)))
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.
798 (Nkind
(N
) = N_Explicit_Dereference
799 and then Ekind
(Etype
(N
)) = E_Subprogram_Type
800 and then Base_Type
(Etype
(Etype
(N
))) /= Standard_Void_Type
)
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).
807 (Nkind
(N
) = N_Selected_Component
808 and then (Ekind
(Entity
(Selector_Name
(N
))) = E_Function
809 or else ((Ekind
(Entity
(Selector_Name
(N
))) = E_Entry
811 Ekind
(Entity
(Selector_Name
(N
))) = E_Procedure
)
812 and then Is_Overloaded
(Selector_Name
(N
)))))
814 -- If one of the above three conditions is met, rewrite as call.
815 -- Apply the rewriting only once.
818 if Nkind
(Parent
(N
)) /= N_Function_Call
819 or else N
/= Name
(Parent
(N
))
823 -- If overloaded, overload set belongs to new copy.
825 Save_Interps
(N
, Nam
);
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)
831 Change_Node
(N
, N_Function_Call
);
833 Set_Sloc
(N
, Sloc
(Nam
));
837 elsif Nkind
(N
) = N_Parameter_Association
then
838 Check_Parameterless_Call
(Explicit_Actual_Parameter
(N
));
840 end Check_Parameterless_Call
;
842 ----------------------
843 -- Is_Predefined_Op --
844 ----------------------
846 function Is_Predefined_Op
(Nam
: Entity_Id
) return Boolean is
848 return Is_Intrinsic_Subprogram
(Nam
)
849 and then not Is_Generic_Instance
(Nam
)
850 and then Chars
(Nam
) in Any_Operator_Name
851 and then (No
(Alias
(Nam
))
852 or else Is_Predefined_Op
(Alias
(Nam
)));
853 end Is_Predefined_Op
;
855 -----------------------------
856 -- Make_Call_Into_Operator --
857 -----------------------------
859 procedure Make_Call_Into_Operator
864 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
865 Act1
: Node_Id
:= First_Actual
(N
);
866 Act2
: Node_Id
:= Next_Actual
(Act1
);
867 Error
: Boolean := False;
868 Is_Binary
: constant Boolean := Present
(Act2
);
870 Opnd_Type
: Entity_Id
;
871 Orig_Type
: Entity_Id
:= Empty
;
874 type Kind_Test
is access function (E
: Entity_Id
) return Boolean;
876 function Is_Definite_Access_Type
(E
: Entity_Id
) return Boolean;
877 -- Determine whether E is an access type declared by an access decla-
878 -- ration, and not an (anonymous) allocator type.
880 function Operand_Type_In_Scope
(S
: Entity_Id
) return Boolean;
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.
885 function Type_In_P
(Test
: Kind_Test
) return Entity_Id
;
886 -- Find a type of the given class in the package Pack that contains
889 -----------------------------
890 -- Is_Definite_Access_Type --
891 -----------------------------
893 function Is_Definite_Access_Type
(E
: Entity_Id
) return Boolean is
894 Btyp
: constant Entity_Id
:= Base_Type
(E
);
896 return Ekind
(Btyp
) = E_Access_Type
897 or else (Ekind
(Btyp
) = E_Access_Subprogram_Type
898 and then Comes_From_Source
(Btyp
));
899 end Is_Definite_Access_Type
;
901 ---------------------------
902 -- Operand_Type_In_Scope --
903 ---------------------------
905 function Operand_Type_In_Scope
(S
: Entity_Id
) return Boolean is
906 Nod
: constant Node_Id
:= Right_Opnd
(Op_Node
);
911 if not Is_Overloaded
(Nod
) then
912 return Scope
(Base_Type
(Etype
(Nod
))) = S
;
915 Get_First_Interp
(Nod
, I
, It
);
917 while Present
(It
.Typ
) loop
919 if Scope
(Base_Type
(It
.Typ
)) = S
then
923 Get_Next_Interp
(I
, It
);
928 end Operand_Type_In_Scope
;
934 function Type_In_P
(Test
: Kind_Test
) return Entity_Id
is
937 function In_Decl
return Boolean;
938 -- Verify that node is not part of the type declaration for the
939 -- candidate type, which would otherwise be invisible.
945 function In_Decl
return Boolean is
946 Decl_Node
: constant Node_Id
:= Parent
(E
);
952 if Etype
(E
) = Any_Type
then
955 elsif No
(Decl_Node
) then
960 and then Nkind
(N2
) /= N_Compilation_Unit
962 if N2
= Decl_Node
then
973 -- Start of processing for Type_In_P
976 -- If the context type is declared in the prefix package, this
977 -- is the desired base type.
979 if Scope
(Base_Type
(Typ
)) = Pack
982 return Base_Type
(Typ
);
985 E
:= First_Entity
(Pack
);
987 while Present
(E
) loop
1002 ---------------------------
1003 -- Operand_Type_In_Scope --
1004 ---------------------------
1006 -- Start of processing for Make_Call_Into_Operator
1009 Op_Node
:= New_Node
(Operator_Kind
(Op_Name
, Is_Binary
), Sloc
(N
));
1014 Set_Left_Opnd
(Op_Node
, Relocate_Node
(Act1
));
1015 Set_Right_Opnd
(Op_Node
, Relocate_Node
(Act2
));
1016 Save_Interps
(Act1
, Left_Opnd
(Op_Node
));
1017 Save_Interps
(Act2
, Right_Opnd
(Op_Node
));
1018 Act1
:= Left_Opnd
(Op_Node
);
1019 Act2
:= Right_Opnd
(Op_Node
);
1024 Set_Right_Opnd
(Op_Node
, Relocate_Node
(Act1
));
1025 Save_Interps
(Act1
, Right_Opnd
(Op_Node
));
1026 Act1
:= Right_Opnd
(Op_Node
);
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.
1047 if Nkind
(Name
(N
)) = N_Expanded_Name
then
1048 Pack
:= Entity
(Prefix
(Name
(N
)));
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
1054 if Scope
(Entity
(Name
(N
))) = Pack
1055 and then Pack
/= Standard_Standard
1059 elsif (Op_Name
= Name_Op_Multiply
1060 or else Op_Name
= Name_Op_Divide
)
1061 and then Is_Fixed_Point_Type
(Etype
(Left_Opnd
(Op_Node
)))
1062 and then Is_Fixed_Point_Type
(Etype
(Right_Opnd
(Op_Node
)))
1064 if Pack
/= Standard_Standard
then
1069 Opnd_Type
:= Base_Type
(Etype
(Right_Opnd
(Op_Node
)));
1071 if Op_Name
= Name_Op_Concat
then
1072 Opnd_Type
:= Base_Type
(Typ
);
1074 elsif (Scope
(Opnd_Type
) = Standard_Standard
1076 or else (Nkind
(Right_Opnd
(Op_Node
)) = N_Attribute_Reference
1078 and then not Comes_From_Source
(Opnd_Type
))
1080 Opnd_Type
:= Base_Type
(Etype
(Left_Opnd
(Op_Node
)));
1083 if Scope
(Opnd_Type
) = Standard_Standard
then
1085 -- Verify that the scope contains a type that corresponds to
1086 -- the given literal. Optimize the case where Pack is Standard.
1088 if Pack
/= Standard_Standard
then
1090 if Opnd_Type
= Universal_Integer
then
1091 Orig_Type
:= Type_In_P
(Is_Integer_Type
'Access);
1093 elsif Opnd_Type
= Universal_Real
then
1094 Orig_Type
:= Type_In_P
(Is_Real_Type
'Access);
1096 elsif Opnd_Type
= Any_String
then
1097 Orig_Type
:= Type_In_P
(Is_String_Type
'Access);
1099 elsif Opnd_Type
= Any_Access
then
1100 Orig_Type
:= Type_In_P
(Is_Definite_Access_Type
'Access);
1102 elsif Opnd_Type
= Any_Composite
then
1103 Orig_Type
:= Type_In_P
(Is_Composite_Type
'Access);
1105 if Present
(Orig_Type
) then
1106 if Has_Private_Component
(Orig_Type
) then
1109 Set_Etype
(Act1
, Orig_Type
);
1112 Set_Etype
(Act2
, Orig_Type
);
1121 Error
:= No
(Orig_Type
);
1124 elsif Ekind
(Opnd_Type
) = E_Allocator_Type
1125 and then No
(Type_In_P
(Is_Definite_Access_Type
'Access))
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
1135 elsif Scope
(Opnd_Type
) /= Pack
1136 and then Scope
(Op_Id
) /= Pack
1137 and then (No
(System_Aux_Id
)
1138 or else Scope
(Opnd_Type
) /= System_Aux_Id
1139 or else Pack
/= Scope
(System_Aux_Id
))
1143 elsif Pack
= Standard_Standard
1144 and then not Operand_Type_In_Scope
(Standard_Standard
)
1151 Error_Msg_Node_2
:= Pack
;
1153 ("& not declared in&", N
, Selector_Name
(Name
(N
)));
1154 Set_Etype
(N
, Any_Type
);
1159 Set_Chars
(Op_Node
, Op_Name
);
1160 Set_Etype
(Op_Node
, Base_Type
(Etype
(N
)));
1161 Set_Entity
(Op_Node
, Op_Id
);
1162 Generate_Reference
(Op_Id
, N
, ' ');
1163 Rewrite
(N
, Op_Node
);
1166 -- For predefined operators on literals, the operation freezes
1169 if Present
(Orig_Type
) then
1170 Set_Etype
(Act1
, Orig_Type
);
1171 Freeze_Expression
(Act1
);
1173 end Make_Call_Into_Operator
;
1179 function Operator_Kind
1181 Is_Binary
: Boolean)
1188 if Op_Name
= Name_Op_And
then Kind
:= N_Op_And
;
1189 elsif Op_Name
= Name_Op_Or
then Kind
:= N_Op_Or
;
1190 elsif Op_Name
= Name_Op_Xor
then Kind
:= N_Op_Xor
;
1191 elsif Op_Name
= Name_Op_Eq
then Kind
:= N_Op_Eq
;
1192 elsif Op_Name
= Name_Op_Ne
then Kind
:= N_Op_Ne
;
1193 elsif Op_Name
= Name_Op_Lt
then Kind
:= N_Op_Lt
;
1194 elsif Op_Name
= Name_Op_Le
then Kind
:= N_Op_Le
;
1195 elsif Op_Name
= Name_Op_Gt
then Kind
:= N_Op_Gt
;
1196 elsif Op_Name
= Name_Op_Ge
then Kind
:= N_Op_Ge
;
1197 elsif Op_Name
= Name_Op_Add
then Kind
:= N_Op_Add
;
1198 elsif Op_Name
= Name_Op_Subtract
then Kind
:= N_Op_Subtract
;
1199 elsif Op_Name
= Name_Op_Concat
then Kind
:= N_Op_Concat
;
1200 elsif Op_Name
= Name_Op_Multiply
then Kind
:= N_Op_Multiply
;
1201 elsif Op_Name
= Name_Op_Divide
then Kind
:= N_Op_Divide
;
1202 elsif Op_Name
= Name_Op_Mod
then Kind
:= N_Op_Mod
;
1203 elsif Op_Name
= Name_Op_Rem
then Kind
:= N_Op_Rem
;
1204 elsif Op_Name
= Name_Op_Expon
then Kind
:= N_Op_Expon
;
1206 raise Program_Error
;
1212 if Op_Name
= Name_Op_Add
then Kind
:= N_Op_Plus
;
1213 elsif Op_Name
= Name_Op_Subtract
then Kind
:= N_Op_Minus
;
1214 elsif Op_Name
= Name_Op_Abs
then Kind
:= N_Op_Abs
;
1215 elsif Op_Name
= Name_Op_Not
then Kind
:= N_Op_Not
;
1217 raise Program_Error
;
1224 -----------------------------
1225 -- Pre_Analyze_And_Resolve --
1226 -----------------------------
1228 procedure Pre_Analyze_And_Resolve
(N
: Node_Id
; T
: Entity_Id
) is
1229 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1232 Full_Analysis
:= False;
1233 Expander_Mode_Save_And_Set
(False);
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.
1239 Analyze_And_Resolve
(N
, T
, Suppress
=> All_Checks
);
1241 Expander_Mode_Restore
;
1242 Full_Analysis
:= Save_Full_Analysis
;
1243 end Pre_Analyze_And_Resolve
;
1245 -- Version without context type.
1247 procedure Pre_Analyze_And_Resolve
(N
: Node_Id
) is
1248 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1251 Full_Analysis
:= False;
1252 Expander_Mode_Save_And_Set
(False);
1255 Resolve
(N
, Etype
(N
), Suppress
=> All_Checks
);
1257 Expander_Mode_Restore
;
1258 Full_Analysis
:= Save_Full_Analysis
;
1259 end Pre_Analyze_And_Resolve
;
1261 ----------------------------------
1262 -- Replace_Actual_Discriminants --
1263 ----------------------------------
1265 procedure Replace_Actual_Discriminants
(N
: Node_Id
; Default
: Node_Id
) is
1266 Loc
: constant Source_Ptr
:= Sloc
(N
);
1267 Tsk
: Node_Id
:= Empty
;
1269 function Process_Discr
(Nod
: Node_Id
) return Traverse_Result
;
1275 function Process_Discr
(Nod
: Node_Id
) return Traverse_Result
is
1279 if Nkind
(Nod
) = N_Identifier
then
1280 Ent
:= Entity
(Nod
);
1283 and then Ekind
(Ent
) = E_Discriminant
1286 Make_Selected_Component
(Loc
,
1287 Prefix
=> New_Copy_Tree
(Tsk
, New_Sloc
=> Loc
),
1288 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Ent
))));
1290 Set_Etype
(Nod
, Etype
(Ent
));
1298 procedure Replace_Discrs
is new Traverse_Proc
(Process_Discr
);
1300 -- Start of processing for Replace_Actual_Discriminants
1303 if not Expander_Active
then
1307 if Nkind
(Name
(N
)) = N_Selected_Component
then
1308 Tsk
:= Prefix
(Name
(N
));
1310 elsif Nkind
(Name
(N
)) = N_Indexed_Component
then
1311 Tsk
:= Prefix
(Prefix
(Name
(N
)));
1317 Replace_Discrs
(Default
);
1319 end Replace_Actual_Discriminants
;
1325 procedure Resolve
(N
: Node_Id
; Typ
: Entity_Id
) is
1327 I1
: Interp_Index
:= 0; -- prevent junk warning
1330 Found
: Boolean := False;
1331 Seen
: Entity_Id
:= Empty
; -- prevent junk warning
1332 Ctx_Type
: Entity_Id
:= Typ
;
1333 Expr_Type
: Entity_Id
:= Empty
; -- prevent junk warning
1334 Ambiguous
: Boolean := False;
1336 procedure Patch_Up_Value
(N
: Node_Id
; Typ
: Entity_Id
);
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.
1340 procedure Resolution_Failed
;
1341 -- Called when attempt at resolving current expression fails
1343 --------------------
1344 -- Patch_Up_Value --
1345 --------------------
1347 procedure Patch_Up_Value
(N
: Node_Id
; Typ
: Entity_Id
) is
1349 if Nkind
(N
) = N_Integer_Literal
1350 and then Is_Real_Type
(Typ
)
1353 Make_Real_Literal
(Sloc
(N
),
1354 Realval
=> UR_From_Uint
(Intval
(N
))));
1355 Set_Etype
(N
, Universal_Real
);
1356 Set_Is_Static_Expression
(N
);
1358 elsif Nkind
(N
) = N_Real_Literal
1359 and then Is_Integer_Type
(Typ
)
1362 Make_Integer_Literal
(Sloc
(N
),
1363 Intval
=> UR_To_Uint
(Realval
(N
))));
1364 Set_Etype
(N
, Universal_Integer
);
1365 Set_Is_Static_Expression
(N
);
1366 elsif Nkind
(N
) = N_String_Literal
1367 and then Is_Character_Type
(Typ
)
1369 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('A')));
1371 Make_Character_Literal
(Sloc
(N
),
1373 Char_Literal_Value
=> Char_Code
(Character'Pos ('A'))));
1374 Set_Etype
(N
, Any_Character
);
1375 Set_Is_Static_Expression
(N
);
1377 elsif Nkind
(N
) /= N_String_Literal
1378 and then Is_String_Type
(Typ
)
1381 Make_String_Literal
(Sloc
(N
),
1382 Strval
=> End_String
));
1384 elsif Nkind
(N
) = N_Range
then
1385 Patch_Up_Value
(Low_Bound
(N
), Typ
);
1386 Patch_Up_Value
(High_Bound
(N
), Typ
);
1390 -----------------------
1391 -- Resolution_Failed --
1392 -----------------------
1394 procedure Resolution_Failed
is
1396 Patch_Up_Value
(N
, Typ
);
1398 Debug_A_Exit
("resolving ", N
, " (done, resolution failed)");
1399 Set_Is_Overloaded
(N
, False);
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
1410 Set_Analyzed
(N
, True);
1412 end Resolution_Failed
;
1414 -- Start of processing for Resolve
1421 -- Access attribute on remote subprogram cannot be used for
1422 -- a non-remote access-to-subprogram type.
1424 if Nkind
(N
) = N_Attribute_Reference
1425 and then (Attribute_Name
(N
) = Name_Access
1426 or else Attribute_Name
(N
) = Name_Unrestricted_Access
1427 or else Attribute_Name
(N
) = Name_Unchecked_Access
)
1428 and then Comes_From_Source
(N
)
1429 and then Is_Entity_Name
(Prefix
(N
))
1430 and then Is_Subprogram
(Entity
(Prefix
(N
)))
1431 and then Is_Remote_Call_Interface
(Entity
(Prefix
(N
)))
1432 and then not Is_Remote_Access_To_Subprogram_Type
(Typ
)
1435 ("prefix must statically denote a non-remote subprogram", 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.
1443 if Nkind
(N
) = N_Attribute_Reference
1444 and then Comes_From_Source
(N
)
1445 and then (Is_Remote_Call_Interface
(Typ
)
1446 or else Is_Remote_Types
(Typ
))
1449 Attr
: constant Attribute_Id
:=
1450 Get_Attribute_Id
(Attribute_Name
(N
));
1451 Pref
: constant Node_Id
:= Prefix
(N
);
1454 Is_Remote
: Boolean := True;
1457 -- Check that Typ is a fat pointer with a reference to a RAS as
1458 -- original access type.
1461 (Ekind
(Typ
) = E_Access_Subprogram_Type
1462 and then Present
(Equivalent_Type
(Typ
)))
1464 (Ekind
(Typ
) = E_Record_Type
1465 and then Present
(Corresponding_Remote_Type
(Typ
)))
1468 -- Prefix (N) must statically denote a remote subprogram
1469 -- declared in a package specification.
1471 if Attr
= Attribute_Access
then
1472 Decl
:= Unit_Declaration_Node
(Entity
(Pref
));
1474 if Nkind
(Decl
) = N_Subprogram_Body
then
1475 Spec
:= Corresponding_Spec
(Decl
);
1477 if not No
(Spec
) then
1478 Decl
:= Unit_Declaration_Node
(Spec
);
1482 Spec
:= Parent
(Decl
);
1484 if not Is_Entity_Name
(Prefix
(N
))
1485 or else Nkind
(Spec
) /= N_Package_Specification
1487 not Is_Remote_Call_Interface
(Defining_Entity
(Spec
))
1491 ("prefix must statically denote a remote subprogram ",
1496 if Attr
= Attribute_Access
1497 or else Attr
= Attribute_Unchecked_Access
1498 or else Attr
= Attribute_Unrestricted_Access
1500 Check_Subtype_Conformant
1501 (New_Id
=> Entity
(Prefix
(N
)),
1502 Old_Id
=> Designated_Type
1503 (Corresponding_Remote_Type
(Typ
)),
1506 Process_Remote_AST_Attribute
(N
, Typ
);
1513 Debug_A_Entry
("resolving ", N
);
1515 if Comes_From_Source
(N
) then
1516 if Is_Fixed_Point_Type
(Typ
) then
1517 Check_Restriction
(No_Fixed_Point
, N
);
1519 elsif Is_Floating_Point_Type
(Typ
)
1520 and then Typ
/= Universal_Real
1521 and then Typ
/= Any_Real
1523 Check_Restriction
(No_Floating_Point
, N
);
1527 -- Return if already analyzed
1529 if Analyzed
(N
) then
1530 Debug_A_Exit
("resolving ", N
, " (done, already analyzed)");
1533 -- Return if type = Any_Type (previous error encountered)
1535 elsif Etype
(N
) = Any_Type
then
1536 Debug_A_Exit
("resolving ", N
, " (done, Etype = Any_Type)");
1540 Check_Parameterless_Call
(N
);
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.
1545 if not Is_Overloaded
(N
) then
1546 Found
:= Covers
(Typ
, Etype
(N
));
1547 Expr_Type
:= Etype
(N
);
1549 -- In the overloaded case, we must select the interpretation that
1550 -- is compatible with the context (i.e. the type passed to Resolve)
1553 Get_First_Interp
(N
, I
, It
);
1555 -- Loop through possible interpretations
1557 Interp_Loop
: while Present
(It
.Typ
) loop
1559 -- We are only interested in interpretations that are compatible
1560 -- with the expected type, any other interpretations are ignored
1562 if Covers
(Typ
, It
.Typ
) then
1564 -- First matching interpretation
1570 Expr_Type
:= It
.Typ
;
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.
1578 Error_Msg_Sloc
:= Sloc
(Seen
);
1579 It1
:= Disambiguate
(N
, I1
, I
, Typ
);
1581 if It1
= No_Interp
then
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.
1588 if Nkind
(N
) = N_Function_Call
1589 or else Nkind
(N
) = N_Procedure_Call_Statement
1592 A
: Node_Id
:= First_Actual
(N
);
1596 while Present
(A
) loop
1599 if Nkind
(E
) = N_Parameter_Association
then
1600 E
:= Explicit_Actual_Parameter
(E
);
1603 if Etype
(E
) = Any_Type
then
1604 if Debug_Flag_V
then
1605 Write_Str
("Any_Type in call");
1616 elsif Nkind
(N
) in N_Binary_Op
1617 and then (Etype
(Left_Opnd
(N
)) = Any_Type
1618 or else Etype
(Right_Opnd
(N
)) = Any_Type
)
1622 elsif Nkind
(N
) in N_Unary_Op
1623 and then Etype
(Right_Opnd
(N
)) = Any_Type
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.
1632 if not Ambiguous
then
1634 ("ambiguous expression (cannot resolve&)!",
1637 ("possible interpretation#!", N
);
1641 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
1642 Error_Msg_N
("possible interpretation#!", N
);
1644 -- Disambiguation has succeeded. Skip the remaining
1648 Expr_Type
:= It1
.Typ
;
1650 while Present
(It
.Typ
) loop
1651 Get_Next_Interp
(I
, It
);
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.
1662 if Nkind
(N
) in N_Op
then
1663 Set_Entity
(N
, Seen
);
1664 Generate_Reference
(Seen
, N
);
1666 elsif Nkind
(N
) = N_Character_Literal
then
1667 Set_Etype
(N
, Expr_Type
);
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.
1674 elsif Nkind
(N
) = N_Explicit_Dereference
1675 or else Nkind
(N
) = N_Attribute_Reference
1676 or else Nkind
(N
) = N_And_Then
1677 or else Nkind
(N
) = N_Indexed_Component
1678 or else Nkind
(N
) = N_Or_Else
1679 or else Nkind
(N
) = N_Range
1680 or else Nkind
(N
) = N_Selected_Component
1681 or else Nkind
(N
) = N_Slice
1682 or else Nkind
(Name
(N
)) = N_Explicit_Dereference
1686 -- For procedure or function calls, set the type of the
1687 -- name, and also the entity pointer for the prefix
1689 elsif (Nkind
(N
) = N_Procedure_Call_Statement
1690 or else Nkind
(N
) = N_Function_Call
)
1691 and then (Is_Entity_Name
(Name
(N
))
1692 or else Nkind
(Name
(N
)) = N_Operator_Symbol
)
1694 Set_Etype
(Name
(N
), Expr_Type
);
1695 Set_Entity
(Name
(N
), Seen
);
1696 Generate_Reference
(Seen
, Name
(N
));
1698 elsif Nkind
(N
) = N_Function_Call
1699 and then Nkind
(Name
(N
)) = N_Selected_Component
1701 Set_Etype
(Name
(N
), Expr_Type
);
1702 Set_Entity
(Selector_Name
(Name
(N
)), Seen
);
1703 Generate_Reference
(Seen
, Selector_Name
(Name
(N
)));
1705 -- For all other cases, just set the type of the Name
1708 Set_Etype
(Name
(N
), Expr_Type
);
1711 -- Here if interpetation is incompatible with context type
1714 if Debug_Flag_V
then
1715 Write_Str
(" intepretation incompatible with context");
1720 -- Move to next interpretation
1722 exit Interp_Loop
when not Present
(It
.Typ
);
1724 Get_Next_Interp
(I
, It
);
1725 end loop Interp_Loop
;
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.
1734 if Typ
/= Any_Type
then
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!)
1742 if Typ
= Standard_Void_Type
then
1743 Error_Msg_N
("expect procedure name in procedure call", N
);
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.
1754 elsif Nkind
(N
) = N_Allocator
1755 and then Ekind
(Typ
) in Access_Kind
1756 and then Ekind
(Etype
(N
)) in Access_Kind
1757 and then Designated_Type
(Etype
(N
)) = Typ
1759 Wrong_Type
(Expression
(N
), Designated_Type
(Typ
));
1762 -- Check for view mismatch on Null in instances, for
1763 -- which the view-swapping mechanism has no identifier.
1765 elsif (In_Instance
or else In_Inlined_Body
)
1766 and then (Nkind
(N
) = N_Null
)
1767 and then Is_Private_Type
(Typ
)
1768 and then Is_Access_Type
(Full_View
(Typ
))
1770 Resolve
(N
, Full_View
(Typ
));
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).
1785 elsif Nkind
(N
) = N_Aggregate
1786 and then Etype
(N
) = Any_Composite
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.
1793 Expander_Active
:= False;
1796 procedure Check_Aggr
(Aggr
: Node_Id
);
1797 -- Check one aggregate, and set Found to True if we
1798 -- have a definite error in any of its elements
1800 procedure Check_Elmt
(Aelmt
: Node_Id
);
1801 -- Check one element of aggregate and set Found to
1802 -- True if we definitely have an error in the element.
1804 procedure Check_Aggr
(Aggr
: Node_Id
) is
1808 if Present
(Expressions
(Aggr
)) then
1809 Elmt
:= First
(Expressions
(Aggr
));
1810 while Present
(Elmt
) loop
1816 if Present
(Component_Associations
(Aggr
)) then
1817 Elmt
:= First
(Component_Associations
(Aggr
));
1818 while Present
(Elmt
) loop
1819 Check_Elmt
(Expression
(Elmt
));
1825 procedure Check_Elmt
(Aelmt
: Node_Id
) is
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.
1833 if Nkind
(Aelmt
) = N_Aggregate
then
1839 if not Is_Overloaded
(Aelmt
)
1840 and then Etype
(Aelmt
) /= Any_Fixed
1842 Resolve
(Aelmt
, Etype
(Aelmt
));
1845 if Etype
(Aelmt
) = Any_Type
then
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.
1861 if Is_Overloaded
(N
)
1862 and then Nkind
(N
) = N_Function_Call
1864 Error_Msg_Node_2
:= Typ
;
1865 Error_Msg_NE
("no visible interpretation of&" &
1866 " matches expected type&", N
, Name
(N
));
1868 if All_Errors_Mode
then
1870 Index
: Interp_Index
;
1874 Error_Msg_N
("\possible interpretations:", N
);
1875 Get_First_Interp
(Name
(N
), Index
, It
);
1877 while Present
(It
.Nam
) loop
1879 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
1880 Error_Msg_Node_2
:= It
.Typ
;
1881 Error_Msg_NE
("\& declared#, type&",
1884 Get_Next_Interp
(Index
, It
);
1888 Error_Msg_N
("\use -gnatf for details", N
);
1891 Wrong_Type
(N
, Typ
);
1899 -- Test if we have more than one interpretation for the context
1901 elsif Ambiguous
then
1905 -- Here we have an acceptable interpretation for the context
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.
1917 if Nkind
(N
) in N_Op
1918 and then Present
(Entity
(N
))
1919 and then Ekind
(Entity
(N
)) /= E_Operator
1922 if not Is_Predefined_Op
(Entity
(N
)) then
1923 Rewrite_Operator_As_Call
(N
, Entity
(N
));
1925 elsif Present
(Alias
(Entity
(N
))) then
1926 Rewrite_Renamed_Operator
(N
, Alias
(Entity
(N
)));
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
1935 if Typ
= Any_Integer
1936 or else Typ
= Any_Boolean
1937 or else Typ
= Any_Modular
1938 or else Typ
= Any_Real
1939 or else Typ
= Any_Discrete
1941 Ctx_Type
:= Expr_Type
;
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.
1948 and then Expr_Type
= Any_Fixed
1950 Error_Msg_N
("Illegal context for mixed mode operation", N
);
1951 Set_Etype
(N
, Universal_Real
);
1952 Ctx_Type
:= Universal_Real
;
1956 case N_Subexpr
'(Nkind (N)) is
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);
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);
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);
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)");
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
2106 -- Version with check(s) suppressed
2108 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
2110 if Suppress = All_Checks then
2112 Svg : constant Suppress_Record := Scope_Suppress;
2115 Scope_Suppress := (others => True);
2117 Scope_Suppress := Svg;
2122 Svg : constant Boolean := Get_Scope_Suppress (Suppress);
2125 Set_Scope_Suppress (Suppress, True);
2127 Set_Scope_Suppress (Suppress, Svg);
2132 ---------------------
2133 -- Resolve_Actuals --
2134 ---------------------
2136 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
2137 Loc : constant Source_Ptr := Sloc (N);
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
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))
2172 Replace_Actual_Discriminants (N, Actval);
2175 if Is_Overloadable (Nam)
2176 and then Present (Alias (Nam))
2178 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
2179 and then not Is_Tagged_Type (Etype (F))
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)));
2188 Actval := Unchecked_Convert_To (Etype (F), Actval);
2192 if Is_Scalar_Type (Etype (F)) then
2193 Enable_Range_Check (Actval);
2196 Set_Parent (Actval, N);
2197 Analyze_And_Resolve (Actval, Etype (Actval));
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))
2208 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
2210 Analyze_And_Resolve (Actval, Etype (Actval));
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
2220 Set_Is_Controlling_Actual (Actval);
2224 -- Missing argument in call, nothing to insert.
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
2234 Make_Raise_Constraint_Error (Loc,
2235 Reason => CE_Range_Check_Failed));
2236 Set_Raises_Constraint_Error (Actval);
2237 Set_Etype (Actval, Etype (F));
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
2250 Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
2251 Set_First_Named_Actual (N, Actval);
2254 if not Present (Parameter_Associations (N)) then
2255 Set_Parameter_Associations (N, New_List (Assoc));
2257 Append (Assoc, Parameter_Associations (N));
2261 Insert_After (Prev, Assoc);
2264 -- Case of insertion is not first named actual
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));
2273 Mark_Rewrite_Insertion (Assoc);
2274 Mark_Rewrite_Insertion (Actval);
2279 -- Start of processing for Resolve_Actuals
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
2294 Set_Etype (N, Any_Type);
2299 and then (Nkind (Parent (A)) /= N_Parameter_Association
2301 Chars (Selector_Name (Parent (A))) = Chars (F))
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)))
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))
2323 ("both component types in a view conversion must be"
2324 & " aliased, or neither", A);
2327 if Conversion_OK (A)
2328 or else Valid_Conversion (A, Etype (A), Expression (A))
2330 Resolve (Expression (A), Etype (Expression (A)));
2334 Resolve (A, Etype (F));
2340 if Ekind (F) /= E_In_Parameter
2341 and then not Is_OK_Variable_For_Out_Formal (A)
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
2352 Error_Msg_N ("within protected function, protected " &
2353 "object is constant", A);
2354 Error_Msg_N ("\cannot call operation that may modify it", A);
2356 Error_Msg_NE ("actual for& must be a variable", A, F);
2360 if Etype (A) = Any_Type then
2361 Set_Etype (N, Any_Type);
2365 if Ekind (F) /= E_Out_Parameter then
2366 Check_Unset_Reference (A);
2369 and then Is_Entity_Name (A)
2370 and then Ekind (Entity (A)) = E_Out_Parameter
2372 Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
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
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
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))
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))
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))
2414 Apply_Discriminant_Check (A, F_Typ);
2417 Apply_Range_Check (A, F_Typ);
2421 if Ekind (F) = E_Out_Parameter
2422 or else Ekind (F) = E_In_Out_Parameter
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);
2431 (Expression (A), Etype (Expression (A)), A_Typ);
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
2441 Apply_Length_Check (A, F_Typ);
2444 Apply_Range_Check (A, A_Typ, F_Typ);
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
2456 ("invalid implicit conversion for access parameter", A);
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)
2465 if Is_Atomic_Object (A)
2466 and then not Is_Atomic (Etype (F))
2469 ("cannot pass atomic argument to non-atomic formal",
2472 elsif Is_Volatile_Object (A)
2473 and then not Is_Volatile (Etype (F))
2476 ("cannot pass volatile argument to non-volatile formal",
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);
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)
2494 Error_Msg_N ("class-wide argument not allowed here!", A);
2496 if Is_Subprogram (Nam)
2497 and then Comes_From_Source (Nam)
2499 Error_Msg_Node_2 := F_Typ;
2501 ("& is not a primitive operation of &!", A, Nam);
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
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)
2515 ("access to class-wide argument not allowed here!", A);
2517 if Is_Subprogram (Nam)
2518 and then Comes_From_Source (Nam)
2520 Error_Msg_Node_2 := Designated_Type (F_Typ);
2522 ("& is not a primitive operation of &!", A, Nam);
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);
2535 Generate_Reference (F_Typ, N, ' ');
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);
2557 Discrim : Entity_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
2566 ----------------------------
2567 -- In_Dispatching_Context --
2568 ----------------------------
2570 function In_Dispatching_Context return Boolean is
2571 Par : constant Node_Id := Parent (N);
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
2583 -- Replace general access with specific type
2585 if Ekind (Etype (N)) = E_Allocator_Type then
2586 Set_Etype (N, Base_Type (Typ));
2589 if Is_Abstract (Typ) then
2590 Error_Msg_N ("type of allocator cannot be abstract", N);
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
2602 ("class-wide allocator not allowed for this access type", N);
2605 Resolve (Expression (E), Etype (E));
2606 Check_Unset_Reference (Expression (E));
2608 -- For a subtype mark or subtype indication, freeze the subtype
2611 Freeze_Expression (E);
2613 if Is_Access_Constant (Typ) and then not No_Initialization (N) then
2615 ("initialization required for access-to-constant allocator", N);
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
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));
2643 Disc_Exp := Original_Node (Constr);
2646 if Type_Access_Level (Etype (Disc_Exp))
2647 > Type_Access_Level (Typ)
2650 ("operand type has deeper level than allocator type",
2653 elsif Nkind (Disc_Exp) = N_Attribute_Reference
2654 and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
2656 and then Object_Access_Level (Prefix (Disc_Exp))
2657 > Type_Access_Level (Typ)
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)
2672 ("access discriminant has deeper level than"
2673 & " allocator type", Disc_Exp);
2676 Next_Discriminant (Discrim);
2683 -- Check for allocation from an empty storage pool
2685 if No_Pool_Assigned (Typ) then
2687 Loc : constant Source_Ptr := Sloc (N);
2690 Error_Msg_N ("?allocation from empty storage pool!", N);
2691 Error_Msg_N ("?Storage_Error will be raised at run time!", N);
2693 Make_Raise_Storage_Error (Loc,
2694 Reason => SE_Empty_Storage_Pool));
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);
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
2736 Index : Interp_Index;
2740 if not Is_Overloaded (N) then
2742 return Base_Type (T) = Base_Type (Standard_Integer)
2743 or else T = Universal_Integer
2744 or else T = Universal_Real;
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
2757 Get_Next_Interp (Index, It);
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;
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);
2782 Resolve (N, Standard_Integer);
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)
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).
2796 elsif Etype (N) = Base_Type (Standard_Integer)
2797 and then T = Universal_Real
2798 and then Is_Overloaded (N)
2800 -- Integer arg in mixed-mode operation. Resolve with universal
2801 -- type, in case preference rule must be applied.
2803 Resolve (N, Universal_Integer);
2806 and then B_Typ /= Universal_Fixed
2808 -- Not a mixed-mode operation. Resolve with context.
2812 elsif Etype (N) = Any_Fixed then
2814 -- N may itself be a mixed-mode operation, so use context type.
2818 elsif Is_Fixed_Point_Type (T)
2819 and then B_Typ = Universal_Fixed
2820 and then Is_Overloaded (N)
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)
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);
2845 Resolve (N, Standard_Integer);
2848 elsif Is_Fixed_Point_Type (It.Typ) then
2850 if Analyzed (N) then
2851 Error_Msg_N ("ambiguous operand in fixed operation", N);
2853 Resolve (N, It.Typ);
2857 Get_Next_Interp (Index, It);
2860 -- Reanalyze the literal with the fixed type of the context.
2863 Set_Analyzed (R, False);
2866 Set_Analyzed (L, False);
2871 Resolve (N, Etype (N));
2873 end Set_Mixed_Mode_Operand;
2875 ----------------------
2876 -- Set_Operand_Type --
2877 ----------------------
2879 procedure Set_Operand_Type (N : Node_Id) is
2881 if Etype (N) = Universal_Integer
2882 or else Etype (N) = Universal_Real
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;
2897 if not Is_Overloaded (N) then
2899 if Etype (N) = Universal_Integer
2900 or else Etype (N) = Universal_Real
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
2918 Get_Next_Interp (Index, It);
2923 end Universal_Interpretation;
2925 -- Start of processing for Resolve_Arithmetic_Op
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)))
2933 Resolve_Intrinsic_Operator (N, Typ);
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))
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)
2959 Is_Integer_Or_Universal (R))))
2960 and then (Nkind (N) = N_Op_Multiply or else
2961 Nkind (N) = N_Op_Divide)
2963 if TL = Universal_Integer or else TR = Universal_Integer then
2964 Check_For_Visible_Operator (N, B_Typ);
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)
2977 elsif Is_Fixed_Point_Type (B_Typ)
2978 and then (Base_Type (TR) = Base_Type (Standard_Integer)
2979 or else TR = Universal_Integer)
2985 Set_Mixed_Mode_Operand (L, TR);
2986 Set_Mixed_Mode_Operand (R, TL);
2989 if Etype (N) = Universal_Fixed
2990 or else Etype (N) = Any_Fixed
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
2997 ("type cannot be determined from context!", N);
2999 ("\explicit conversion to result type required", N);
3001 Set_Etype (L, Any_Type);
3002 Set_Etype (R, Any_Type);
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
3011 ("(Ada 83) fixed-point operation " &
3012 "needs explicit conversion",
3016 Set_Etype (N, B_Typ);
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
3024 Is_Integer_Or_Universal (R))
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);
3037 if (TL = Universal_Integer or else TL = Universal_Real)
3038 and then (TR = Universal_Integer or else TR = Universal_Real)
3040 Check_For_Visible_Operator (N, B_Typ);
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
3050 T := Unique_Fixed_Point_Type (N);
3052 if T = Any_Type then
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);
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);
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))
3093 Set_Do_Division_Check (N);
3097 Check_Unset_Reference (L);
3098 Check_Unset_Reference (R);
3100 end Resolve_Arithmetic_Op;
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);
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);
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);
3138 while Present (It.Typ) loop
3140 if Covers (Typ, Etype (It.Typ)) then
3145 Get_Next_Interp (I, It);
3149 raise Program_Error;
3153 -- If the prefix is not an entity, then resolve it
3155 if not Is_Entity_Name (Subp) then
3156 Resolve (Subp, Nam);
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)
3169 Resolve_Entry_Call (N, Typ);
3170 Check_Elab_Call (N);
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
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
3191 Set_Entity_With_Style_Check (Subp, Nam);
3192 Generate_Reference (Nam, Subp);
3196 Get_Next_Interp (I, It);
3200 -- Check that a call to Current_Task does not occur in an entry body
3202 if Is_RTE (Nam, RE_Current_Task) then
3212 if Nkind (P) = N_Entry_Body then
3214 ("& should not be used in entry body ('R
'M C
.7(17))",
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
3235 Error_Msg_N ("entry call required
in select statement
", N);
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);
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
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)
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)))
3273 Component_Type (Designated_Type (Etype (Nam))))))
3276 Index_Node : Node_Id;
3280 if Component_Type (Etype (Nam)) /= Any_Type then
3282 Make_Indexed_Component (Loc,
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));
3294 Resolve_Indexed_Component (N, Typ);
3295 Check_Elab_Call (Prefix (N));
3302 Set_Etype (N, Etype (Nam));
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);
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;
3331 and then not Restrictions (No_Recursion)
3332 and then Check_Infinite_Recursion (N)
3334 -- Here we detected and flagged an infinite recursion, so we do
3335 -- not need to test the case below for further warnings.
3339 -- If call is to immediately containing subprogram, then check for
3340 -- the case of a possible run-time detectable infinite recursion.
3343 while Scop /= Standard_Standard loop
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
3366 Set_Has_Recursive_Call (Nam);
3367 Error_Msg_N ("possible infinite recursion?
", N);
3368 Error_Msg_N ("Storage_Error may be raised
at run time?
", N);
3374 Scop := Scope (Scop);
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)));
3386 elsif Present (Alias (Nam))
3387 and then Is_Predefined_Op (Alias (Nam))
3389 Resolve_Actuals (N, Nam);
3390 Make_Call_Into_Operator (N, Typ, Alias (Nam));
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
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)
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
3420 Check_Initialization_Call (N, Nam);
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))
3431 ("& cannot be called before
end of protected definition
", N, Nam);
3434 -- Propagate interpretation to actuals, and add default expressions
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.
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)
3459 Check_Dispatching_Call (N);
3461 elsif Is_Abstract (Nam)
3462 and then not In_Instance
3464 Error_Msg_NE ("cannot call
abstract subprogram
&!", N, Nam);
3467 if Is_Intrinsic_Subprogram (Nam) then
3468 Check_Intrinsic_Call (N);
3471 -- If we fall through we definitely have a non-static call
3473 Check_Elab_Call (N);
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);
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
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
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
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
3519 -- Otherwise we have a user defined character type, and we can use
3520 -- the standard visibility mechanisms to locate the referenced entity
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);
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).
3541 ("character not defined
for }", N, First_Subtype (B_Typ));
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);
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)));
3566 T := Find_Unique_Type (L, R);
3568 if T = Any_Fixed then
3569 T := Unique_Fixed_Point_Type (L);
3574 Generate_Reference (T, N, ' ');
3576 if T /= Any_Type then
3579 or else T = Any_Composite
3580 or else T = Any_Character
3582 if T = Any_Character then
3583 Ambiguous_Character (L);
3585 Error_Msg_N ("ambiguous operands
for comparison
", N);
3588 Set_Etype (N, Any_Type);
3592 if Comes_From_Source (N)
3593 and then Has_Unchecked_Union (T)
3596 ("cannot compare Unchecked_Union values
", N);
3601 Check_Unset_Reference (L);
3602 Check_Unset_Reference (R);
3603 Generate_Operator_Reference (N);
3604 Eval_Relational_Op (N);
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);
3620 Resolve (Condition, Standard_Boolean);
3621 Resolve (Then_Expr, Typ);
3622 Resolve (Else_Expr, Typ);
3625 Eval_Conditional_Expression (N);
3626 end Resolve_Conditional_Expression;
3628 -----------------------------------------
3629 -- Resolve_Discrete_Subtype_Indication --
3630 -----------------------------------------
3632 procedure Resolve_Discrete_Subtype_Indication
3640 Analyze (Subtype_Mark (N));
3641 S := Entity (Subtype_Mark (N));
3643 if Nkind (Constraint (N)) /= N_Range_Constraint then
3644 Error_Msg_N ("expect
range constraint
for discrete
type", N);
3645 Set_Etype (N, Any_Type);
3648 R := Range_Expression (Constraint (N));
3656 if Base_Type (S) /= Base_Type (Typ) then
3658 ("expect
subtype of }", N, First_Subtype (Typ));
3660 -- Rewrite the constraint as a range of Typ
3661 -- to allow compilation to proceed further.
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));
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.
3700 L : Node_Id := Low_Bound (R);
3701 H : Node_Id := High_Bound (R);
3704 if Nkind (L) = N_Raise_Constraint_Error then
3705 Remove_Side_Effects (L);
3708 if Nkind (H) = N_Raise_Constraint_Error then
3709 Remove_Side_Effects (H);
3713 Check_Unset_Reference (Low_Bound (R));
3714 Check_Unset_Reference (High_Bound (R));
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);
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);
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
3742 Eval_Named_Integer (N);
3744 elsif Ekind (E) = E_Named_Real then
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)
3760 ("Invalid
use of subtype mark
in expression
or call
", N);
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)
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
3777 Error_Msg_N ("illegal
use of generic function", N);
3779 elsif Ekind (E) = E_Out_Parameter
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)
3786 Error_Msg_N ("(Ada
83) illegal reading
of out parameter
", N);
3788 -- In all other cases, just do the possible static evaluation
3791 -- A deferred constant that appears in an expression must have
3792 -- a completion, unless it has been removed by in-place expansion
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)
3803 if No_Initialization (Parent (E))
3804 or else (Present (Full_View (E))
3805 and then No_Initialization (Parent (Full_View (E))))
3810 "deferred
constant is frozen before completion
", N);
3814 Eval_Entity_Name (N);
3816 end Resolve_Entity_Name;
3822 procedure Resolve_Entry (Entry_Name : Node_Id) is
3823 Loc : constant Source_Ptr := Sloc (Entry_Name);
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);
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);
3865 Remove_Side_Effects (Bound);
3867 if not Is_Entity_Name (Bound)
3868 or else Ekind (Entity (Bound)) /= E_Discriminant
3872 elsif Is_Protected_Type (Tsk)
3873 and then In_Open_Scopes (Tsk)
3874 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
3876 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
3880 Make_Selected_Component (Loc,
3881 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
3882 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
3887 end Actual_Discriminant_Ref;
3889 -- Start of processing for Actual_Index_Type
3892 if not Has_Discriminants (Tsk)
3893 or else (not Is_Entity_Name (Lo)
3894 and then not Is_Entity_Name (Hi))
3896 return Entry_Index_Type (E);
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)));
3910 end Actual_Index_Type;
3912 -- Start of processing of Resolve_Entry
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);
3926 E_Name := Entry_Name;
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)
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
3964 elsif S = Scope_Stack.Table (J).Entity then
3966 -- Call to current task. Will be transformed into call to Self
3974 Make_Selected_Component (Loc,
3975 Prefix => New_Occurrence_Of (S, Loc),
3977 New_Occurrence_Of (Entity (E_Name), Loc));
3978 Rewrite (E_Name, New_N);
3981 elsif Nkind (Entry_Name) = N_Selected_Component
3982 and then Is_Overloaded (Prefix (Entry_Name))
3984 -- Use the entry name (which must be unique at this point) to
3985 -- find the prefix that returns the corresponding task type or
3989 Pref : Node_Id := Prefix (Entry_Name);
3992 Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
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);
4004 Get_Next_Interp (I, It);
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
4024 Error_Msg_N ("expect expression
for entry index
", Index);
4026 Apply_Range_Check (Index, Actual_Index_Type (Nam));
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);
4040 First_Named : Node_Id;
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
4055 if Nkind (Entry_Name) = N_Selected_Component
4056 and then Is_Overloaded (Selector_Name (Entry_Name))
4057 and then Typ /= Standard_Void_Type
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, ' ');
4075 Get_Next_Interp (I, It);
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)));
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))
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))))))
4116 Index_Node : Node_Id;
4120 Make_Indexed_Component (Loc,
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));
4132 Resolve_Indexed_Component (N, Typ);
4137 -- The operation name may have been overloaded. Order the actuals
4138 -- according to the formals of the resolved entity.
4141 Normalize_Actuals (N, Nam, False, Norm_OK);
4142 pragma Assert (Norm_OK);
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
4151 Check_Potentially_Blocking_Operation (N);
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))
4162 Error_Msg_N ("entry call required
in select statement
", N);
4164 elsif Nkind (Parent (N)) = N_Triggering_Alternative
4165 and then N = Triggering_Statement (Parent (N))
4167 Error_Msg_N ("triggering statement cannot be
procedure call
", N);
4169 elsif Ekind (Scope (Nam)) = E_Task_Type
4170 and then not In_Open_Scopes (Scope (Nam))
4172 Error_Msg_N ("Task has no
entry with this name
", Entry_Name);
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)))
4194 ("prefix
of protected procedure or entry call must be variable
",
4198 Actuals := Parameter_Associations (N);
4199 First_Named := First_Named_Actual (N);
4202 Make_Entry_Call_Statement (Loc,
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))
4215 Establish_Transient_Scope (N,
4216 Sec_Stack => not Functions_Return_By_DSP_On_Target);
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
4244 -----------------------------
4245 -- Find_Unique_Access_Type --
4246 -----------------------------
4248 function Find_Unique_Access_Type return Entity_Id is
4251 S : Entity_Id := Current_Scope;
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));
4264 while S /= Standard_Standard loop
4265 E := First_Entity (S);
4267 while Present (E) loop
4270 and then Is_Access_Type (E)
4271 and then Ekind (E) /= E_Allocator_Type
4272 and then Designated_Type (E) = Base_Type (Acc)
4284 end Find_Unique_Access_Type;
4286 -- Start of processing for Resolve_Equality_Op
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);
4296 if T /= Any_Type then
4299 or else T = Any_Composite
4300 or else T = Any_Character
4303 if T = Any_Character then
4304 Ambiguous_Character (L);
4306 Error_Msg_N ("ambiguous operands
for equality
", N);
4309 Set_Etype (N, Any_Type);
4312 elsif T = Any_Access
4313 or else Ekind (T) = E_Allocator_Type
4315 T := Find_Unique_Access_Type;
4318 Error_Msg_N ("ambiguous operands
for equality
", N);
4319 Set_Etype (N, Any_Type);
4324 if Comes_From_Source (N)
4325 and then Has_Unchecked_Union (T)
4328 ("cannot compare Unchecked_Union values
", N);
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)))
4348 Eval_Relational_Op (N);
4349 elsif Nkind (N) = N_Op_Ne
4350 and then Is_Abstract (Entity (N))
4352 Error_Msg_NE ("cannot call
abstract subprogram
&!", N, Entity (N));
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);
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
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);
4390 Resolve (P, It.Typ);
4391 Set_Etype (N, Designated_Type (It.Typ));
4394 Resolve (P, Etype (P));
4397 if Is_Access_Type (Etype (P)) then
4398 Apply_Access_Check (N);
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)
4416 Set_Etype (N, Get_Actual_Subtype (N));
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);
4432 Array_Type : Entity_Id := Empty; -- to prevent junk warning
4436 if Is_Overloaded (Name) then
4438 -- Use the context type to select the prefix that yields the
4439 -- correct component type.
4444 I1 : Interp_Index := 0;
4445 P : constant Node_Id := Prefix (N);
4446 Found : Boolean := False;
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))
4458 (Typ, Component_Type (Designated_Type (It.Typ))))
4461 It := Disambiguate (P, I1, I, Any_Type);
4463 if It = No_Interp then
4464 Error_Msg_N ("ambiguous prefix
for indexing
", N);
4470 Array_Type := It.Typ;
4476 Array_Type := It.Typ;
4481 Get_Next_Interp (I, It);
4486 Array_Type := Etype (Name);
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);
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);
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));
4523 Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
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
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
4551 Arg1 : Node_Id := Left_Opnd (N);
4552 Arg2 : Node_Id := Right_Opnd (N);
4557 while Scope (Op) /= Standard_Standard loop
4559 pragma Assert (Present (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));
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
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
4590 B_Typ := Base_Type (Typ);
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
4600 Error_Msg_N ("invalid context
for logical operation
", N);
4601 Set_Etype (N, Any_Type);
4604 elsif Typ = Any_Modular then
4606 ("no modular
type available
in this context
", N);
4607 Set_Etype (N, Any_Type);
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
4613 Check_For_Visible_Operator (N, B_Typ);
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);
4643 if L = Error or else R = Error then
4647 if not Is_Overloaded (R)
4649 (Etype (R) = Universal_Integer or else
4650 Etype (R) = Universal_Real)
4651 and then Is_Overloaded (L)
4655 T := Intersect_Types (L, R);
4659 Check_Unset_Reference (L);
4661 if Nkind (R) = N_Range
4662 and then not Is_Scalar_Type (T)
4664 Error_Msg_N ("scalar
type required
for range", R);
4667 if Is_Entity_Name (R) then
4668 Freeze_Expression (R);
4671 Check_Unset_Reference (R);
4674 Eval_Membership_Op (N);
4675 end Resolve_Membership_Op;
4681 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
4683 -- For now allow circumvention of the restriction against
4684 -- anonymous null access values via a debug switch to allow
4685 -- for easier transition.
4688 and then Ekind (Typ) = E_Anonymous_Access_Type
4689 and then Comes_From_Source (N)
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
4696 Nkind (Parent (N)) = N_Function_Call
4699 ("null is not allowed as argument
for an
access parameter
", N);
4701 -- Standard message for all other cases (are there any?)
4705 ("null cannot be
of an anonymous
access type", N);
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)
4720 -- The null literal takes its type from the context.
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
4748 or else (not Is_Overloaded (Arg)
4749 and then Etype (Arg) /= Any_Composite
4750 and then Covers (Component_Type (Typ), Etype (Arg)))
4752 Resolve (Arg, Component_Type (Typ));
4754 Resolve (Arg, Btyp);
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))
4762 if Is_Private_Type (Component_Type (Typ)) then
4763 Resolve (Arg, Btyp);
4766 Error_Msg_N ("ambiguous aggregate must be qualified
", Arg);
4767 Set_Etype (Arg, Any_Type);
4771 if Is_Overloaded (Arg)
4772 and then Has_Compatible_Type (Arg, Typ)
4773 and then Etype (Arg) /= Any_Type
4775 Error_Msg_N ("ambiguous operand
for concatenation
!", Arg);
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))
4790 Error_Msg_Sloc := Sloc (It.Nam);
4791 Error_Msg_N ("\possible interpretation#
", Arg);
4794 Get_Next_Interp (I, It);
4799 Resolve (Arg, Component_Type (Typ));
4801 if Arg = Left_Opnd (N) then
4802 Set_Is_Component_Left_Opnd (N);
4804 Set_Is_Component_Right_Opnd (N);
4809 Resolve (Arg, Btyp);
4812 Check_Unset_Reference (Arg);
4813 end Resolve_Concatenation_Arg;
4815 -- Start of processing for Resolve_Op_Concat
4818 Set_Etype (N, Btyp);
4820 if Is_Limited_Composite (Btyp) then
4821 Error_Msg_N ("concatenation
not available
for limited array", N);
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)
4832 Resolve_Op_Concat (Op1, Typ);
4834 Resolve_Concatenation_Arg
4835 (Op1, Is_Component_Left_Opnd (N));
4838 if Nkind (Op2) = N_Op_Concat
4839 and then not Is_Array_Type (Component_Type (Typ))
4840 and then Entity (Op2) = Entity (N)
4842 Resolve_Op_Concat (Op2, Typ);
4844 Resolve_Concatenation_Arg
4845 (Op2, Is_Component_Right_Opnd (N));
4848 Generate_Operator_Reference (N);
4850 if Is_String_Type (Typ) then
4851 Eval_Concatenation (N);
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))
4861 Set_String_Literal_Subtype (Op1, Typ);
4862 Set_String_Literal_Subtype (Op2, Typ);
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);
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
4879 Error_Msg_N ("exponentiation
not available
for fixed point
", N);
4883 if Etype (Left_Opnd (N)) = Universal_Integer
4884 or else Etype (Left_Opnd (N)) = Universal_Real
4886 Check_For_Visible_Operator (N, B_Typ);
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);
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);
4912 end Resolve_Op_Expon;
4914 --------------------
4915 -- Resolve_Op_Not --
4916 --------------------
4918 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
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
4929 if Paren_Count (N) /= 0 then
4933 case Nkind (Parent (N)) is
4948 return Left_Opnd (Parent (N)) = N;
4954 end Parent_Is_Boolean;
4956 -- Start of processing for Resolve_Op_Not
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
4966 B_Typ := Base_Type (Typ);
4969 if not Valid_Boolean_Arg (Typ) then
4970 Error_Msg_N ("invalid operand
type for operator
&", N);
4971 Set_Etype (N, Any_Type);
4974 elsif (Typ = Universal_Integer
4975 or else Typ = Any_Modular)
4977 if Parent_Is_Boolean then
4979 ("operand
of not must be enclosed
in parentheses
",
4983 ("no modular
type available
in this context
", N);
4986 Set_Etype (N, Any_Type);
4990 if not Is_Boolean_Type (Typ)
4991 and then Parent_Is_Boolean
4993 Error_Msg_N ("?
not expression should be parenthesized here
", N);
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);
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);
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);
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)
5037 Wrong_Type (Expr, Target_Typ);
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)
5047 Set_Etype (N, Etype (Expr));
5050 Eval_Qualified_Expression (N);
5051 end Resolve_Qualified_Expression;
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);
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);
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);
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)
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);
5107 -- Case of literal is not an exact multiple of the Small
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)
5118 Error_Msg_N ("value has extraneous low order
digits", N);
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);
5128 Make_Real_Literal (Sloc (N),
5129 Realval => Small_Value (Typ) * Cint));
5131 Set_Is_Static_Expression (N, Stat);
5134 -- In all cases, set the corresponding integer field
5136 Set_Corresponding_Integer_Value (N, Cint);
5140 -- Now replace the actual type by the expected type as usual
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);
5154 -- Replace general access with specific type
5156 if Ekind (Etype (N)) = E_Allocator_Type then
5157 Set_Etype (N, Base_Type (Typ));
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);
5171 end Resolve_Reference;
5173 --------------------------------
5174 -- Resolve_Selected_Component --
5175 --------------------------------
5177 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
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);
5184 I1 : Interp_Index := 0; -- prevent junk warning
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
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;
5206 -- Start of processing for Resolve_Selected_Component
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.
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);
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)
5239 It := Disambiguate (P, I1, I, Any_Type);
5241 if It = No_Interp then
5243 ("ambiguous prefix
for selected component
", N);
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)
5260 Comp1 := Next_Entity (Comp1);
5269 Comp := Next_Entity (Comp);
5274 Get_Next_Interp (I, It);
5278 Resolve (P, It1.Typ);
5280 Set_Entity (S, Comp1);
5283 -- Resolve prefix with its type.
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));
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
5305 Set_Do_Discriminant_Check (N);
5308 if Ekind (Entity (S)) = E_Void then
5309 Error_Msg_N ("premature
use of component
", S);
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
5319 Set_Etype (N, Base_Type (Typ));
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;
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);
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.
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);
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);
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;
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;
5382 if Is_Overloaded (Name) then
5384 -- Use the context type to select the prefix that yields the
5385 -- correct array type.
5389 I1 : Interp_Index := 0;
5391 P : constant Node_Id := Prefix (N);
5392 Found : Boolean := False;
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)))
5406 It := Disambiguate (P, I1, I, Any_Type);
5408 if It = No_Interp then
5409 Error_Msg_N ("ambiguous prefix
for slicing
", N);
5414 Array_Type := It.Typ;
5419 Array_Type := It.Typ;
5424 Get_Next_Interp (I, It);
5429 Array_Type := Etype (Name);
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)))
5442 Array_Type := Get_Actual_Subtype (Name);
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
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));
5461 Set_Slice_Subtype (N);
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;
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.
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
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
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.
5521 Set_String_Literal_Subtype (N, Typ);
5522 Subtype_Id := Etype (N);
5525 if Nkind (Parent (N)) /= N_Op_Concat
5528 Set_Etype (N, Subtype_Id);
5529 Eval_String_Literal (N);
5532 if Is_Limited_Composite (Typ)
5533 or else Is_Private_Composite (Typ)
5535 Error_Msg_N ("string literal
not available
for private array", N);
5536 Set_Etype (N, Any_Type);
5540 -- The validity of a null string has been checked in the
5541 -- call to Eval_String_Literal.
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
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
5559 -- Deal with cases of Wide_String and String
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
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
5579 elsif R_Typ = Standard_Character
5580 and then Nkind (Original_Node (N)) /= N_Op_Concat
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.
5590 ("literal
out of range of type Character",
5591 Source_Ptr (Int (Loc) + J));
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
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
5615 -- Check for the case of full range, where we are definitely OK
5617 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
5621 -- Here the range is not the complete base type range, so check
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));
5632 if Compile_Time_Known_Value (Comp_Typ_Lo)
5633 and then Compile_Time_Known_Value (Comp_Typ_Hi)
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)
5641 Apply_Compile_Time_Constraint_Error
5642 (N, "character out of range?
", CE_Range_Check_Failed,
5643 Loc => Source_Ptr (Int (Loc) + J));
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.
5658 Lits : List_Id := New_List;
5659 P : Source_Ptr := Loc + 1;
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);
5672 Make_Character_Literal (P, Name_Find, C));
5674 if In_Character_Range (C) then
5677 -- Should we have a call to Skip_Wide here ???
5685 Make_Qualified_Expression (Loc,
5686 Subtype_Mark => New_Reference_To (Typ, Loc),
5688 Make_Aggregate (Loc, Expressions => Lits)));
5690 Analyze_And_Resolve (N, Typ);
5692 end Resolve_String_Literal;
5694 -----------------------------
5695 -- Resolve_Subprogram_Info --
5696 -----------------------------
5698 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
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);
5711 Opnd_Type : Entity_Id;
5715 Operand := Expression (N);
5718 and then not Valid_Conversion (N, Target_Type, Operand)
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)
5737 if Unique_Fixed_Point_Type (N) = Any_Type then
5738 return; -- expression is ambiguous.
5740 Set_Etype (Operand, Standard_Duration);
5743 if Etype (Right_Opnd (Operand)) = Universal_Real then
5744 Rop := New_Copy_Tree (Right_Opnd (Operand));
5746 Rop := New_Copy_Tree (Left_Opnd (Operand));
5749 Resolve (Rop, Standard_Long_Long_Float);
5751 if Realval (Rop) /= Ureal_0
5752 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
5754 Error_Msg_N ("universal real operand can only be interpreted?
",
5756 Error_Msg_N ("\as
Duration, and will lose precision?
", Rop);
5760 Error_Msg_N ("invalid context
for mixed mode operation
", N);
5761 Set_Etype (Operand, Any_Type);
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
5791 Apply_Type_Conversion_Checks (N);
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
5803 ("?useless conversion
, & has this
type",
5804 N, Entity (Expression (N)));
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);
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
5824 ("?unary minus expression should be parenthesized here
", N);
5827 if Etype (R) = Universal_Integer
5828 or else Etype (R) = Universal_Real
5830 Check_For_Visible_Operator (N, B_Typ);
5833 Set_Etype (N, B_Typ);
5835 Check_Unset_Reference (R);
5836 Generate_Operator_Reference (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);
5849 end Resolve_Unary_Op;
5851 ----------------------------------
5852 -- Resolve_Unchecked_Expression --
5853 ----------------------------------
5855 procedure Resolve_Unchecked_Expression
5860 Resolve (Expression (N), Typ, Suppress => All_Checks);
5862 end Resolve_Unchecked_Expression;
5864 ---------------------------------------
5865 -- Resolve_Unchecked_Type_Conversion --
5866 ---------------------------------------
5868 procedure Resolve_Unchecked_Type_Conversion
5872 pragma Warnings (Off, Typ);
5874 Operand : constant Node_Id := Expression (N);
5875 Opnd_Type : constant Entity_Id := Etype (Operand);
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;
5895 if Nkind (N) in N_Binary_Op then
5896 Append (Left_Opnd (N), Actuals);
5899 Append (Right_Opnd (N), Actuals);
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);
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;
5922 if Chars (N) /= Nam then
5924 -- Rewrite the operator node using the real operator, not its
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);
5936 Set_Left_Opnd (Op_Node, Left_Opnd (N));
5939 Rewrite (N, Op_Node);
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);
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);
5964 if Is_Entity_Name (Drange) then
5965 Index_Subtype := Entity (Drange);
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));
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));
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);
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;
6027 if Nkind (N) /= N_String_Literal then
6030 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
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;
6059 procedure Fixed_Point_Error;
6060 -- If true ambiguity, give details.
6062 procedure Fixed_Point_Error is
6064 Error_Msg_N ("ambiguous universal_fixed_expression
", N);
6065 Error_Msg_NE ("\possible interpretation as
}", N, T1);
6066 Error_Msg_NE ("\possible interpretation as
}", N, T2);
6067 end Fixed_Point_Error;
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
6087 if Present (T1) then
6098 Scop := Scope (Scop);
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))
6117 if Present (T1) then
6132 if Nkind (N) = N_Real_Literal then
6133 Error_Msg_NE ("real literal interpreted as
}?
", N, T1);
6136 Error_Msg_NE ("universal_fixed expression interpreted as
}?
", N, T1);
6140 end Unique_Fixed_Point_Type;
6142 ----------------------
6143 -- Valid_Conversion --
6144 ----------------------
6146 function Valid_Conversion
6152 Target_Type : Entity_Id := Base_Type (Target);
6153 Opnd_Type : Entity_Id := Etype (Operand);
6155 function Conversion_Check
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)
6165 -- Specifically test for validity of tagged conversions
6167 ----------------------
6168 -- Conversion_Check --
6169 ----------------------
6171 function Conversion_Check
6178 Error_Msg_N (Msg, Operand);
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)
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)
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)
6209 elsif Covers (Opnd_Type, Target_Type)
6210 or else Is_Ancestor (Opnd_Type, Target_Type)
6213 Conversion_Check (False,
6214 "downward conversion
of tagged objects
not allowed
");
6217 ("invalid
tagged conversion
, not compatible
with}",
6218 N, First_Subtype (Opnd_Type));
6221 end Valid_Tagged_Conversion;
6223 -- Start of processing for Valid_Conversion
6226 Check_Parameterless_Call (Operand);
6228 if Is_Overloaded (Operand) then
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
6249 Get_Next_Interp (I, It);
6252 Get_First_Interp (Operand, I, It);
6257 Error_Msg_N ("illegal operand
in conversion
", Operand);
6261 Get_Next_Interp (I, It);
6263 if Present (It.Typ) then
6265 It1 := Disambiguate (Operand, I1, I, Any_Type);
6267 if It1 = No_Interp then
6268 Error_Msg_N ("ambiguous operand
in conversion
", Operand);
6270 Error_Msg_Sloc := Sloc (It.Nam);
6271 Error_Msg_N ("possible interpretation#
!", Operand);
6273 Error_Msg_Sloc := Sloc (N1);
6274 Error_Msg_N ("possible interpretation#
!", Operand);
6280 Set_Etype (Operand, It1.Typ);
6281 Opnd_Type := It1.Typ;
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 ???
6292 elsif Is_Numeric_Type (Target_Type) then
6293 if Opnd_Type = Universal_Fixed then
6296 return Conversion_Check (Is_Numeric_Type (Opnd_Type),
6297 "illegal operand
for numeric conversion
");
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
6306 ("illegal operand
for array conversion
", Operand);
6309 elsif Number_Dimensions (Target_Type) /=
6310 Number_Dimensions (Opnd_Type)
6313 ("incompatible number
of dimensions
for conversion
", Operand);
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);
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))
6338 ("incompatible index types
for array conversion
",
6343 Next_Index (Target_Index);
6344 Next_Index (Opnd_Index);
6347 if Base_Type (Target_Comp_Type) /=
6348 Base_Type (Opnd_Comp_Type)
6351 ("incompatible component types
for array conversion
",
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)
6362 ("component subtypes must statically match
", Operand);
6371 elsif (Ekind (Target_Type) = E_General_Access_Type
6372 or else Ekind (Target_Type) = E_Anonymous_Access_Type)
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,
6380 "must be an
access-to
-object
type")
6382 if Is_Access_Constant (Opnd_Type)
6383 and then not Is_Access_Constant (Target_Type)
6386 ("access-to
-constant operand
type not allowed
", Operand);
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)
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
6404 ("?cannot convert local pointer to non
-local
access type",
6407 ("?Program_Error will be raised
at run time
", Operand);
6411 ("cannot convert local pointer to non
-local
access type",
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)
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
6434 ("?cannot convert
access discriminant to non
-local
" &
6435 " access type", Operand);
6437 ("?Program_Error will be raised
at run time
", Operand);
6441 ("cannot convert
access discriminant to non
-local
" &
6442 " access type", Operand);
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)))
6459 ("discriminant has deeper accessibility level than target
",
6467 Target : constant Entity_Id := Designated_Type (Target_Type);
6468 Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
6471 if Is_Tagged_Type (Target) then
6472 return Valid_Tagged_Conversion (Target, Opnd);
6475 if Base_Type (Target) /= Base_Type (Opnd) then
6477 ("target designated
type not compatible
with }",
6478 N, Base_Type (Opnd));
6481 elsif not Subtypes_Statically_Match (Target, Opnd)
6482 and then (not Has_Discriminants (Target)
6483 or else Is_Constrained (Target))
6486 ("target designated
subtype not compatible
with }",
6496 elsif Ekind (Target_Type) = E_Access_Subprogram_Type
6497 and then Conversion_Check
6498 (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
6499 "illegal operand
for access subprogram conversion
")
6501 -- Check that the designated types are subtype conformant
6503 if not Subtype_Conformant (Designated_Type (Opnd_Type),
6504 Designated_Type (Target_Type))
6507 ("operand
type is not subtype conformant
with target
type",
6511 -- Check the static accessibility rule of 4.6(20)
6513 if Type_Access_Level (Opnd_Type) >
6514 Type_Access_Level (Target_Type)
6517 ("operand
type has deeper accessibility level than target
",
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
6526 O_Gen : constant Node_Id :=
6527 Enclosing_Generic_Body (Opnd_Type);
6530 Enclosing_Generic_Body (Target_Type);
6533 while Present (T_Gen) and then T_Gen /= O_Gen loop
6534 T_Gen := Enclosing_Generic_Body (T_Gen);
6537 if T_Gen /= O_Gen then
6539 ("target
type must be declared
in same
generic body"
6540 & " as operand
type", N);
6547 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
6548 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
6550 -- It is valid to convert from one RAS type to another provided
6551 -- that their specification statically match.
6553 Check_Subtype_Conformant
6555 Designated_Type (Corresponding_Remote_Type (Target_Type)),
6557 Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
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
6570 -- In an instance, there may be inconsistent views of the same
6571 -- type, or types derived from the same type.
6574 and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
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)
6583 Error_Msg_N ("target
type must be general
access type!", N);
6584 Error_Msg_NE ("add
ALL to
}!", N, Target_Type);
6589 Error_Msg_NE ("invalid conversion
, not compatible
with }",
6594 end Valid_Conversion;