1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Util
; use Exp_Util
;
32 with Fname
; use Fname
;
33 with Itypes
; use Itypes
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Namet
; use Namet
;
37 with Namet
.Sp
; use Namet
.Sp
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Output
; use Output
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
45 with Sem_Aux
; use Sem_Aux
;
46 with Sem_Cat
; use Sem_Cat
;
47 with Sem_Ch3
; use Sem_Ch3
;
48 with Sem_Ch6
; use Sem_Ch6
;
49 with Sem_Ch8
; use Sem_Ch8
;
50 with Sem_SCIL
; use Sem_SCIL
;
51 with Sem_Disp
; use Sem_Disp
;
52 with Sem_Dist
; use Sem_Dist
;
53 with Sem_Eval
; use Sem_Eval
;
54 with Sem_Res
; use Sem_Res
;
55 with Sem_Util
; use Sem_Util
;
56 with Sem_Type
; use Sem_Type
;
57 with Stand
; use Stand
;
58 with Sinfo
; use Sinfo
;
59 with Snames
; use Snames
;
60 with Tbuild
; use Tbuild
;
62 package body Sem_Ch4
is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 procedure Analyze_Concatenation_Rest
(N
: Node_Id
);
69 -- Does the "rest" of the work of Analyze_Concatenation, after the left
70 -- operand has been analyzed. See Analyze_Concatenation for details.
72 procedure Analyze_Expression
(N
: Node_Id
);
73 -- For expressions that are not names, this is just a call to analyze.
74 -- If the expression is a name, it may be a call to a parameterless
75 -- function, and if so must be converted into an explicit call node
76 -- and analyzed as such. This deproceduring must be done during the first
77 -- pass of overload resolution, because otherwise a procedure call with
78 -- overloaded actuals may fail to resolve.
80 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
);
81 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call
82 -- is an operator name or an expanded name whose selector is an operator
83 -- name, and one possible interpretation is as a predefined operator.
85 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
);
86 -- If the prefix of a selected_component is overloaded, the proper
87 -- interpretation that yields a record type with the proper selector
88 -- name must be selected.
90 procedure Analyze_User_Defined_Binary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
91 -- Procedure to analyze a user defined binary operator, which is resolved
92 -- like a function, but instead of a list of actuals it is presented
93 -- with the left and right operands of an operator node.
95 procedure Analyze_User_Defined_Unary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
96 -- Procedure to analyze a user defined unary operator, which is resolved
97 -- like a function, but instead of a list of actuals, it is presented with
98 -- the operand of the operator node.
100 procedure Ambiguous_Operands
(N
: Node_Id
);
101 -- for equality, membership, and comparison operators with overloaded
102 -- arguments, list possible interpretations.
104 procedure Analyze_One_Call
108 Success
: out Boolean;
109 Skip_First
: Boolean := False);
110 -- Check one interpretation of an overloaded subprogram name for
111 -- compatibility with the types of the actuals in a call. If there is a
112 -- single interpretation which does not match, post error if Report is
115 -- Nam is the entity that provides the formals against which the actuals
116 -- are checked. Nam is either the name of a subprogram, or the internal
117 -- subprogram type constructed for an access_to_subprogram. If the actuals
118 -- are compatible with Nam, then Nam is added to the list of candidate
119 -- interpretations for N, and Success is set to True.
121 -- The flag Skip_First is used when analyzing a call that was rewritten
122 -- from object notation. In this case the first actual may have to receive
123 -- an explicit dereference, depending on the first formal of the operation
124 -- being called. The caller will have verified that the object is legal
125 -- for the call. If the remaining parameters match, the first parameter
126 -- will rewritten as a dereference if needed, prior to completing analysis.
128 procedure Check_Misspelled_Selector
131 -- Give possible misspelling diagnostic if Sel is likely to be a mis-
132 -- spelling of one of the selectors of the Prefix. This is called by
133 -- Analyze_Selected_Component after producing an invalid selector error
136 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean;
137 -- Verify that type T is declared in scope S. Used to find interpretations
138 -- for operators given by expanded names. This is abstracted as a separate
139 -- function to handle extensions to System, where S is System, but T is
140 -- declared in the extension.
142 procedure Find_Arithmetic_Types
146 -- L and R are the operands of an arithmetic operator. Find
147 -- consistent pairs of interpretations for L and R that have a
148 -- numeric type consistent with the semantics of the operator.
150 procedure Find_Comparison_Types
154 -- L and R are operands of a comparison operator. Find consistent
155 -- pairs of interpretations for L and R.
157 procedure Find_Concatenation_Types
161 -- For the four varieties of concatenation
163 procedure Find_Equality_Types
167 -- Ditto for equality operators
169 procedure Find_Boolean_Types
173 -- Ditto for binary logical operations
175 procedure Find_Negation_Types
179 -- Find consistent interpretation for operand of negation operator
181 procedure Find_Non_Universal_Interpretations
186 -- For equality and comparison operators, the result is always boolean,
187 -- and the legality of the operation is determined from the visibility
188 -- of the operand types. If one of the operands has a universal interpre-
189 -- tation, the legality check uses some compatible non-universal
190 -- interpretation of the other operand. N can be an operator node, or
191 -- a function call whose name is an operator designator.
193 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean;
194 -- Find candidate interpretations for the name Obj.Proc when it appears
195 -- in a subprogram renaming declaration.
197 procedure Find_Unary_Types
201 -- Unary arithmetic types: plus, minus, abs
203 procedure Check_Arithmetic_Pair
207 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
208 -- types for left and right operand. Determine whether they constitute
209 -- a valid pair for the given operator, and record the corresponding
210 -- interpretation of the operator node. The node N may be an operator
211 -- node (the usual case) or a function call whose prefix is an operator
212 -- designator. In both cases Op_Id is the operator name itself.
214 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
);
215 -- Give detailed information on overloaded call where none of the
216 -- interpretations match. N is the call node, Nam the designator for
217 -- the overloaded entity being called.
219 function Junk_Operand
(N
: Node_Id
) return Boolean;
220 -- Test for an operand that is an inappropriate entity (e.g. a package
221 -- name or a label). If so, issue an error message and return True. If
222 -- the operand is not an inappropriate entity kind, return False.
224 procedure Operator_Check
(N
: Node_Id
);
225 -- Verify that an operator has received some valid interpretation. If none
226 -- was found, determine whether a use clause would make the operation
227 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
228 -- every type compatible with the operator, even if the operator for the
229 -- type is not directly visible. The routine uses this type to emit a more
230 -- informative message.
232 function Process_Implicit_Dereference_Prefix
234 P
: Node_Id
) return Entity_Id
;
235 -- Called when P is the prefix of an implicit dereference, denoting an
236 -- object E. The function returns the designated type of the prefix, taking
237 -- into account that the designated type of an anonymous access type may be
238 -- a limited view, when the non-limited view is visible.
239 -- If in semantics only mode (-gnatc or generic), the function also records
240 -- that the prefix is a reference to E, if any. Normally, such a reference
241 -- is generated only when the implicit dereference is expanded into an
242 -- explicit one, but for consistency we must generate the reference when
243 -- expansion is disabled as well.
245 procedure Remove_Abstract_Operations
(N
: Node_Id
);
246 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
247 -- operation is not a candidate interpretation.
249 function Try_Indexed_Call
253 Skip_First
: Boolean) return Boolean;
254 -- If a function has defaults for all its actuals, a call to it may in fact
255 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
256 -- interpretation as an indexing, prior to analysis as a call. If both are
257 -- possible, the node is overloaded with both interpretations (same symbol
258 -- but two different types). If the call is written in prefix form, the
259 -- prefix becomes the first parameter in the call, and only the remaining
260 -- actuals must be checked for the presence of defaults.
262 function Try_Indirect_Call
265 Typ
: Entity_Id
) return Boolean;
266 -- Similarly, a function F that needs no actuals can return an access to a
267 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
268 -- the call may be overloaded with both interpretations.
270 function Try_Object_Operation
(N
: Node_Id
) return Boolean;
271 -- Ada 2005 (AI-252): Support the object.operation notation
273 procedure wpo
(T
: Entity_Id
);
274 pragma Warnings
(Off
, wpo
);
275 -- Used for debugging: obtain list of primitive operations even if
276 -- type is not frozen and dispatch table is not built yet.
278 ------------------------
279 -- Ambiguous_Operands --
280 ------------------------
282 procedure Ambiguous_Operands
(N
: Node_Id
) is
283 procedure List_Operand_Interps
(Opnd
: Node_Id
);
285 --------------------------
286 -- List_Operand_Interps --
287 --------------------------
289 procedure List_Operand_Interps
(Opnd
: Node_Id
) is
294 if Is_Overloaded
(Opnd
) then
295 if Nkind
(Opnd
) in N_Op
then
297 elsif Nkind
(Opnd
) = N_Function_Call
then
307 if Opnd
= Left_Opnd
(N
) then
309 ("\left operand has the following interpretations", N
);
312 ("\right operand has the following interpretations", N
);
316 List_Interps
(Nam
, Err
);
317 end List_Operand_Interps
;
319 -- Start of processing for Ambiguous_Operands
322 if Nkind
(N
) in N_Membership_Test
then
323 Error_Msg_N
("ambiguous operands for membership", N
);
325 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
) then
326 Error_Msg_N
("ambiguous operands for equality", N
);
329 Error_Msg_N
("ambiguous operands for comparison", N
);
332 if All_Errors_Mode
then
333 List_Operand_Interps
(Left_Opnd
(N
));
334 List_Operand_Interps
(Right_Opnd
(N
));
336 Error_Msg_N
("\use -gnatf switch for details", N
);
338 end Ambiguous_Operands
;
340 -----------------------
341 -- Analyze_Aggregate --
342 -----------------------
344 -- Most of the analysis of Aggregates requires that the type be known,
345 -- and is therefore put off until resolution.
347 procedure Analyze_Aggregate
(N
: Node_Id
) is
349 if No
(Etype
(N
)) then
350 Set_Etype
(N
, Any_Composite
);
352 end Analyze_Aggregate
;
354 -----------------------
355 -- Analyze_Allocator --
356 -----------------------
358 procedure Analyze_Allocator
(N
: Node_Id
) is
359 Loc
: constant Source_Ptr
:= Sloc
(N
);
360 Sav_Errs
: constant Nat
:= Serious_Errors_Detected
;
361 E
: Node_Id
:= Expression
(N
);
362 Acc_Type
: Entity_Id
;
366 -- In accordance with H.4(7), the No_Allocators restriction only applies
367 -- to user-written allocators.
369 if Comes_From_Source
(N
) then
370 Check_Restriction
(No_Allocators
, N
);
373 if Nkind
(E
) = N_Qualified_Expression
then
374 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
375 Set_Etype
(Acc_Type
, Acc_Type
);
376 Find_Type
(Subtype_Mark
(E
));
378 -- Analyze the qualified expression, and apply the name resolution
379 -- rule given in 4.7 (3).
382 Type_Id
:= Etype
(E
);
383 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
385 Resolve
(Expression
(E
), Type_Id
);
387 if Is_Limited_Type
(Type_Id
)
388 and then Comes_From_Source
(N
)
389 and then not In_Instance_Body
391 if not OK_For_Limited_Init
(Type_Id
, Expression
(E
)) then
392 Error_Msg_N
("initialization not allowed for limited types", N
);
393 Explain_Limited_Type
(Type_Id
, N
);
397 -- A qualified expression requires an exact match of the type,
398 -- class-wide matching is not allowed.
400 -- if Is_Class_Wide_Type (Type_Id)
401 -- and then Base_Type
402 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
404 -- Wrong_Type (Expression (E), Type_Id);
407 Check_Non_Static_Context
(Expression
(E
));
409 -- We don't analyze the qualified expression itself because it's
410 -- part of the allocator
412 Set_Etype
(E
, Type_Id
);
414 -- Case where allocator has a subtype indication
419 Base_Typ
: Entity_Id
;
422 -- If the allocator includes a N_Subtype_Indication then a
423 -- constraint is present, otherwise the node is a subtype mark.
424 -- Introduce an explicit subtype declaration into the tree
425 -- defining some anonymous subtype and rewrite the allocator to
426 -- use this subtype rather than the subtype indication.
428 -- It is important to introduce the explicit subtype declaration
429 -- so that the bounds of the subtype indication are attached to
430 -- the tree in case the allocator is inside a generic unit.
432 if Nkind
(E
) = N_Subtype_Indication
then
434 -- A constraint is only allowed for a composite type in Ada
435 -- 95. In Ada 83, a constraint is also allowed for an
436 -- access-to-composite type, but the constraint is ignored.
438 Find_Type
(Subtype_Mark
(E
));
439 Base_Typ
:= Entity
(Subtype_Mark
(E
));
441 if Is_Elementary_Type
(Base_Typ
) then
442 if not (Ada_Version
= Ada_83
443 and then Is_Access_Type
(Base_Typ
))
445 Error_Msg_N
("constraint not allowed here", E
);
447 if Nkind
(Constraint
(E
)) =
448 N_Index_Or_Discriminant_Constraint
450 Error_Msg_N
-- CODEFIX
451 ("\if qualified expression was meant, " &
452 "use apostrophe", Constraint
(E
));
456 -- Get rid of the bogus constraint:
458 Rewrite
(E
, New_Copy_Tree
(Subtype_Mark
(E
)));
459 Analyze_Allocator
(N
);
462 -- Ada 2005, AI-363: if the designated type has a constrained
463 -- partial view, it cannot receive a discriminant constraint,
464 -- and the allocated object is unconstrained.
466 elsif Ada_Version
>= Ada_05
467 and then Has_Constrained_Partial_View
(Base_Typ
)
470 ("constraint no allowed when type " &
471 "has a constrained partial view", Constraint
(E
));
474 if Expander_Active
then
476 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
479 Make_Subtype_Declaration
(Loc
,
480 Defining_Identifier
=> Def_Id
,
481 Subtype_Indication
=> Relocate_Node
(E
)));
483 if Sav_Errs
/= Serious_Errors_Detected
484 and then Nkind
(Constraint
(E
)) =
485 N_Index_Or_Discriminant_Constraint
487 Error_Msg_N
-- CODEFIX
488 ("if qualified expression was meant, " &
489 "use apostrophe!", Constraint
(E
));
492 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
493 Rewrite
(Expression
(N
), E
);
497 Type_Id
:= Process_Subtype
(E
, N
);
498 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
499 Set_Etype
(Acc_Type
, Acc_Type
);
500 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
501 Check_Fully_Declared
(Type_Id
, N
);
503 -- Ada 2005 (AI-231): If the designated type is itself an access
504 -- type that excludes null, its default initialization will
505 -- be a null object, and we can insert an unconditional raise
506 -- before the allocator.
508 if Can_Never_Be_Null
(Type_Id
) then
510 Not_Null_Check
: constant Node_Id
:=
511 Make_Raise_Constraint_Error
(Sloc
(E
),
512 Reason
=> CE_Null_Not_Allowed
);
514 if Expander_Active
then
515 Insert_Action
(N
, Not_Null_Check
);
516 Analyze
(Not_Null_Check
);
518 Error_Msg_N
("null value not allowed here?", E
);
523 -- Check restriction against dynamically allocated protected
524 -- objects. Note that when limited aggregates are supported,
525 -- a similar test should be applied to an allocator with a
526 -- qualified expression ???
528 if Is_Protected_Type
(Type_Id
) then
529 Check_Restriction
(No_Protected_Type_Allocators
, N
);
532 -- Check for missing initialization. Skip this check if we already
533 -- had errors on analyzing the allocator, since in that case these
534 -- are probably cascaded errors.
536 if Is_Indefinite_Subtype
(Type_Id
)
537 and then Serious_Errors_Detected
= Sav_Errs
539 if Is_Class_Wide_Type
(Type_Id
) then
541 ("initialization required in class-wide allocation", N
);
543 if Ada_Version
< Ada_05
544 and then Is_Limited_Type
(Type_Id
)
546 Error_Msg_N
("unconstrained allocation not allowed", N
);
548 if Is_Array_Type
(Type_Id
) then
550 ("\constraint with array bounds required", N
);
552 elsif Has_Unknown_Discriminants
(Type_Id
) then
555 else pragma Assert
(Has_Discriminants
(Type_Id
));
557 ("\constraint with discriminant values required", N
);
560 -- Limited Ada 2005 and general non-limited case
564 ("uninitialized unconstrained allocation not allowed",
567 if Is_Array_Type
(Type_Id
) then
569 ("\qualified expression or constraint with " &
570 "array bounds required", N
);
572 elsif Has_Unknown_Discriminants
(Type_Id
) then
573 Error_Msg_N
("\qualified expression required", N
);
575 else pragma Assert
(Has_Discriminants
(Type_Id
));
577 ("\qualified expression or constraint with " &
578 "discriminant values required", N
);
586 if Is_Abstract_Type
(Type_Id
) then
587 Error_Msg_N
("cannot allocate abstract object", E
);
590 if Has_Task
(Designated_Type
(Acc_Type
)) then
591 Check_Restriction
(No_Tasking
, N
);
592 Check_Restriction
(Max_Tasks
, N
);
593 Check_Restriction
(No_Task_Allocators
, N
);
596 -- If the No_Streams restriction is set, check that the type of the
597 -- object is not, and does not contain, any subtype derived from
598 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
599 -- Has_Stream just for efficiency reasons. There is no point in
600 -- spending time on a Has_Stream check if the restriction is not set.
602 if Restrictions
.Set
(No_Streams
) then
603 if Has_Stream
(Designated_Type
(Acc_Type
)) then
604 Check_Restriction
(No_Streams
, N
);
608 Set_Etype
(N
, Acc_Type
);
610 if not Is_Library_Level_Entity
(Acc_Type
) then
611 Check_Restriction
(No_Local_Allocators
, N
);
614 if Serious_Errors_Detected
> Sav_Errs
then
615 Set_Error_Posted
(N
);
616 Set_Etype
(N
, Any_Type
);
618 end Analyze_Allocator
;
620 ---------------------------
621 -- Analyze_Arithmetic_Op --
622 ---------------------------
624 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
625 L
: constant Node_Id
:= Left_Opnd
(N
);
626 R
: constant Node_Id
:= Right_Opnd
(N
);
630 Candidate_Type
:= Empty
;
631 Analyze_Expression
(L
);
632 Analyze_Expression
(R
);
634 -- If the entity is already set, the node is the instantiation of a
635 -- generic node with a non-local reference, or was manufactured by a
636 -- call to Make_Op_xxx. In either case the entity is known to be valid,
637 -- and we do not need to collect interpretations, instead we just get
638 -- the single possible interpretation.
642 if Present
(Op_Id
) then
643 if Ekind
(Op_Id
) = E_Operator
then
645 if Nkind_In
(N
, N_Op_Divide
, N_Op_Mod
, N_Op_Multiply
, N_Op_Rem
)
646 and then Treat_Fixed_As_Integer
(N
)
650 Set_Etype
(N
, Any_Type
);
651 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
655 Set_Etype
(N
, Any_Type
);
656 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
659 -- Entity is not already set, so we do need to collect interpretations
662 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
663 Set_Etype
(N
, Any_Type
);
665 while Present
(Op_Id
) loop
666 if Ekind
(Op_Id
) = E_Operator
667 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
669 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
671 -- The following may seem superfluous, because an operator cannot
672 -- be generic, but this ignores the cleverness of the author of
675 elsif Is_Overloadable
(Op_Id
) then
676 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
679 Op_Id
:= Homonym
(Op_Id
);
684 end Analyze_Arithmetic_Op
;
690 -- Function, procedure, and entry calls are checked here. The Name in
691 -- the call may be overloaded. The actuals have been analyzed and may
692 -- themselves be overloaded. On exit from this procedure, the node N
693 -- may have zero, one or more interpretations. In the first case an
694 -- error message is produced. In the last case, the node is flagged
695 -- as overloaded and the interpretations are collected in All_Interp.
697 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
698 -- the type-checking is similar to that of other calls.
700 procedure Analyze_Call
(N
: Node_Id
) is
701 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
706 Success
: Boolean := False;
708 Deref
: Boolean := False;
709 -- Flag indicates whether an interpretation of the prefix is a
710 -- parameterless call that returns an access_to_subprogram.
712 function Name_Denotes_Function
return Boolean;
713 -- If the type of the name is an access to subprogram, this may be the
714 -- type of a name, or the return type of the function being called. If
715 -- the name is not an entity then it can denote a protected function.
716 -- Until we distinguish Etype from Return_Type, we must use this routine
717 -- to resolve the meaning of the name in the call.
719 procedure No_Interpretation
;
720 -- Output error message when no valid interpretation exists
722 ---------------------------
723 -- Name_Denotes_Function --
724 ---------------------------
726 function Name_Denotes_Function
return Boolean is
728 if Is_Entity_Name
(Nam
) then
729 return Ekind
(Entity
(Nam
)) = E_Function
;
731 elsif Nkind
(Nam
) = N_Selected_Component
then
732 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
737 end Name_Denotes_Function
;
739 -----------------------
740 -- No_Interpretation --
741 -----------------------
743 procedure No_Interpretation
is
744 L
: constant Boolean := Is_List_Member
(N
);
745 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
748 -- If the node is in a list whose parent is not an expression then it
749 -- must be an attempted procedure call.
751 if L
and then K
not in N_Subexpr
then
752 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
754 ("must instantiate generic procedure& before call",
758 ("procedure or entry name expected", Nam
);
761 -- Check for tasking cases where only an entry call will do
764 and then Nkind_In
(K
, N_Entry_Call_Alternative
,
765 N_Triggering_Alternative
)
767 Error_Msg_N
("entry name expected", Nam
);
769 -- Otherwise give general error message
772 Error_Msg_N
("invalid prefix in call", Nam
);
774 end No_Interpretation
;
776 -- Start of processing for Analyze_Call
779 -- Initialize the type of the result of the call to the error type,
780 -- which will be reset if the type is successfully resolved.
782 Set_Etype
(N
, Any_Type
);
786 if not Is_Overloaded
(Nam
) then
788 -- Only one interpretation to check
790 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
791 Nam_Ent
:= Etype
(Nam
);
793 -- If the prefix is an access_to_subprogram, this may be an indirect
794 -- call. This is the case if the name in the call is not an entity
795 -- name, or if it is a function name in the context of a procedure
796 -- call. In this latter case, we have a call to a parameterless
797 -- function that returns a pointer_to_procedure which is the entity
798 -- being called. Finally, F (X) may be a call to a parameterless
799 -- function that returns a pointer to a function with parameters.
801 elsif Is_Access_Type
(Etype
(Nam
))
802 and then Ekind
(Designated_Type
(Etype
(Nam
))) = E_Subprogram_Type
804 (not Name_Denotes_Function
805 or else Nkind
(N
) = N_Procedure_Call_Statement
807 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
808 and then Is_Entity_Name
(Nam
)
809 and then No
(First_Formal
(Entity
(Nam
)))
810 and then Present
(Actuals
)))
812 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
813 Insert_Explicit_Dereference
(Nam
);
815 -- Selected component case. Simple entry or protected operation,
816 -- where the entry name is given by the selector name.
818 elsif Nkind
(Nam
) = N_Selected_Component
then
819 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
821 if Ekind
(Nam_Ent
) /= E_Entry
822 and then Ekind
(Nam_Ent
) /= E_Entry_Family
823 and then Ekind
(Nam_Ent
) /= E_Function
824 and then Ekind
(Nam_Ent
) /= E_Procedure
826 Error_Msg_N
("name in call is not a callable entity", Nam
);
827 Set_Etype
(N
, Any_Type
);
831 -- If the name is an Indexed component, it can be a call to a member
832 -- of an entry family. The prefix must be a selected component whose
833 -- selector is the entry. Analyze_Procedure_Call normalizes several
834 -- kinds of call into this form.
836 elsif Nkind
(Nam
) = N_Indexed_Component
then
837 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
838 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
840 Error_Msg_N
("name in call is not a callable entity", Nam
);
841 Set_Etype
(N
, Any_Type
);
845 elsif not Is_Entity_Name
(Nam
) then
846 Error_Msg_N
("name in call is not a callable entity", Nam
);
847 Set_Etype
(N
, Any_Type
);
851 Nam_Ent
:= Entity
(Nam
);
853 -- If no interpretations, give error message
855 if not Is_Overloadable
(Nam_Ent
) then
861 -- Operations generated for RACW stub types are called only through
862 -- dispatching, and can never be the static interpretation of a call.
864 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
869 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
871 -- If this is an indirect call, the return type of the access_to
872 -- subprogram may be an incomplete type. At the point of the call,
873 -- use the full type if available, and at the same time update
874 -- the return type of the access_to_subprogram.
877 and then Nkind
(Nam
) = N_Explicit_Dereference
878 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
879 and then Present
(Full_View
(Etype
(N
)))
881 Set_Etype
(N
, Full_View
(Etype
(N
)));
882 Set_Etype
(Nam_Ent
, Etype
(N
));
886 -- An overloaded selected component must denote overloaded operations
887 -- of a concurrent type. The interpretations are attached to the
888 -- simple name of those operations.
890 if Nkind
(Nam
) = N_Selected_Component
then
891 Nam
:= Selector_Name
(Nam
);
894 Get_First_Interp
(Nam
, X
, It
);
896 while Present
(It
.Nam
) loop
900 -- Name may be call that returns an access to subprogram, or more
901 -- generally an overloaded expression one of whose interpretations
902 -- yields an access to subprogram. If the name is an entity, we
903 -- do not dereference, because the node is a call that returns
904 -- the access type: note difference between f(x), where the call
905 -- may return an access subprogram type, and f(x)(y), where the
906 -- type returned by the call to f is implicitly dereferenced to
907 -- analyze the outer call.
909 if Is_Access_Type
(Nam_Ent
) then
910 Nam_Ent
:= Designated_Type
(Nam_Ent
);
912 elsif Is_Access_Type
(Etype
(Nam_Ent
))
914 (not Is_Entity_Name
(Nam
)
915 or else Nkind
(N
) = N_Procedure_Call_Statement
)
916 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
919 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
921 if Is_Entity_Name
(Nam
) then
926 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
928 -- If the interpretation succeeds, mark the proper type of the
929 -- prefix (any valid candidate will do). If not, remove the
930 -- candidate interpretation. This only needs to be done for
931 -- overloaded protected operations, for other entities disambi-
932 -- guation is done directly in Resolve.
936 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
938 Set_Entity
(Nam
, It
.Nam
);
939 Insert_Explicit_Dereference
(Nam
);
940 Set_Etype
(Nam
, Nam_Ent
);
943 Set_Etype
(Nam
, It
.Typ
);
946 elsif Nkind_In
(Name
(N
), N_Selected_Component
,
952 Get_Next_Interp
(X
, It
);
955 -- If the name is the result of a function call, it can only
956 -- be a call to a function returning an access to subprogram.
957 -- Insert explicit dereference.
959 if Nkind
(Nam
) = N_Function_Call
then
960 Insert_Explicit_Dereference
(Nam
);
963 if Etype
(N
) = Any_Type
then
965 -- None of the interpretations is compatible with the actuals
967 Diagnose_Call
(N
, Nam
);
969 -- Special checks for uninstantiated put routines
971 if Nkind
(N
) = N_Procedure_Call_Statement
972 and then Is_Entity_Name
(Nam
)
973 and then Chars
(Nam
) = Name_Put
974 and then List_Length
(Actuals
) = 1
977 Arg
: constant Node_Id
:= First
(Actuals
);
981 if Nkind
(Arg
) = N_Parameter_Association
then
982 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
987 if Is_Signed_Integer_Type
(Typ
) then
989 ("possible missing instantiation of " &
990 "'Text_'I'O.'Integer_'I'O!", Nam
);
992 elsif Is_Modular_Integer_Type
(Typ
) then
994 ("possible missing instantiation of " &
995 "'Text_'I'O.'Modular_'I'O!", Nam
);
997 elsif Is_Floating_Point_Type
(Typ
) then
999 ("possible missing instantiation of " &
1000 "'Text_'I'O.'Float_'I'O!", Nam
);
1002 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1004 ("possible missing instantiation of " &
1005 "'Text_'I'O.'Fixed_'I'O!", Nam
);
1007 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1009 ("possible missing instantiation of " &
1010 "'Text_'I'O.'Decimal_'I'O!", Nam
);
1012 elsif Is_Enumeration_Type
(Typ
) then
1014 ("possible missing instantiation of " &
1015 "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1020 elsif not Is_Overloaded
(N
)
1021 and then Is_Entity_Name
(Nam
)
1023 -- Resolution yields a single interpretation. Verify that the
1024 -- reference has capitalization consistent with the declaration.
1026 Set_Entity_With_Style_Check
(Nam
, Entity
(Nam
));
1027 Generate_Reference
(Entity
(Nam
), Nam
);
1029 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1031 Remove_Abstract_Operations
(N
);
1038 ---------------------------
1039 -- Analyze_Comparison_Op --
1040 ---------------------------
1042 procedure Analyze_Comparison_Op
(N
: Node_Id
) is
1043 L
: constant Node_Id
:= Left_Opnd
(N
);
1044 R
: constant Node_Id
:= Right_Opnd
(N
);
1045 Op_Id
: Entity_Id
:= Entity
(N
);
1048 Set_Etype
(N
, Any_Type
);
1049 Candidate_Type
:= Empty
;
1051 Analyze_Expression
(L
);
1052 Analyze_Expression
(R
);
1054 if Present
(Op_Id
) then
1055 if Ekind
(Op_Id
) = E_Operator
then
1056 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1058 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1061 if Is_Overloaded
(L
) then
1062 Set_Etype
(L
, Intersect_Types
(L
, R
));
1066 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1067 while Present
(Op_Id
) loop
1068 if Ekind
(Op_Id
) = E_Operator
then
1069 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1071 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1074 Op_Id
:= Homonym
(Op_Id
);
1079 end Analyze_Comparison_Op
;
1081 ---------------------------
1082 -- Analyze_Concatenation --
1083 ---------------------------
1085 procedure Analyze_Concatenation
(N
: Node_Id
) is
1087 -- We wish to avoid deep recursion, because concatenations are often
1088 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1089 -- operands nonrecursively until we find something that is not a
1090 -- concatenation (A in this case), or has already been analyzed. We
1091 -- analyze that, and then walk back up the tree following Parent
1092 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1093 -- work at each level. The Parent pointers allow us to avoid recursion,
1094 -- and thus avoid running out of memory.
1100 Candidate_Type
:= Empty
;
1102 -- The following code is equivalent to:
1104 -- Set_Etype (N, Any_Type);
1105 -- Analyze_Expression (Left_Opnd (N));
1106 -- Analyze_Concatenation_Rest (N);
1108 -- where the Analyze_Expression call recurses back here if the left
1109 -- operand is a concatenation.
1111 -- Walk down left operands
1114 Set_Etype
(NN
, Any_Type
);
1115 L
:= Left_Opnd
(NN
);
1116 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1120 -- Now (given the above example) NN is A&B and L is A
1122 -- First analyze L ...
1124 Analyze_Expression
(L
);
1126 -- ... then walk NN back up until we reach N (where we started), calling
1127 -- Analyze_Concatenation_Rest along the way.
1130 Analyze_Concatenation_Rest
(NN
);
1134 end Analyze_Concatenation
;
1136 --------------------------------
1137 -- Analyze_Concatenation_Rest --
1138 --------------------------------
1140 -- If the only one-dimensional array type in scope is String,
1141 -- this is the resulting type of the operation. Otherwise there
1142 -- will be a concatenation operation defined for each user-defined
1143 -- one-dimensional array.
1145 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1146 L
: constant Node_Id
:= Left_Opnd
(N
);
1147 R
: constant Node_Id
:= Right_Opnd
(N
);
1148 Op_Id
: Entity_Id
:= Entity
(N
);
1153 Analyze_Expression
(R
);
1155 -- If the entity is present, the node appears in an instance, and
1156 -- denotes a predefined concatenation operation. The resulting type is
1157 -- obtained from the arguments when possible. If the arguments are
1158 -- aggregates, the array type and the concatenation type must be
1161 if Present
(Op_Id
) then
1162 if Ekind
(Op_Id
) = E_Operator
then
1164 LT
:= Base_Type
(Etype
(L
));
1165 RT
:= Base_Type
(Etype
(R
));
1167 if Is_Array_Type
(LT
)
1168 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1170 Add_One_Interp
(N
, Op_Id
, LT
);
1172 elsif Is_Array_Type
(RT
)
1173 and then LT
= Base_Type
(Component_Type
(RT
))
1175 Add_One_Interp
(N
, Op_Id
, RT
);
1177 -- If one operand is a string type or a user-defined array type,
1178 -- and the other is a literal, result is of the specific type.
1181 (Root_Type
(LT
) = Standard_String
1182 or else Scope
(LT
) /= Standard_Standard
)
1183 and then Etype
(R
) = Any_String
1185 Add_One_Interp
(N
, Op_Id
, LT
);
1188 (Root_Type
(RT
) = Standard_String
1189 or else Scope
(RT
) /= Standard_Standard
)
1190 and then Etype
(L
) = Any_String
1192 Add_One_Interp
(N
, Op_Id
, RT
);
1194 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
1195 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1198 -- Type and its operations must be visible
1200 Set_Entity
(N
, Empty
);
1201 Analyze_Concatenation
(N
);
1205 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1209 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
1210 while Present
(Op_Id
) loop
1211 if Ekind
(Op_Id
) = E_Operator
then
1213 -- Do not consider operators declared in dead code, they can
1214 -- not be part of the resolution.
1216 if Is_Eliminated
(Op_Id
) then
1219 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
1223 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1226 Op_Id
:= Homonym
(Op_Id
);
1231 end Analyze_Concatenation_Rest
;
1233 ------------------------------------
1234 -- Analyze_Conditional_Expression --
1235 ------------------------------------
1237 procedure Analyze_Conditional_Expression
(N
: Node_Id
) is
1238 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1239 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1240 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1243 if Comes_From_Source
(N
) then
1244 Check_Compiler_Unit
(N
);
1247 Analyze_Expression
(Condition
);
1248 Analyze_Expression
(Then_Expr
);
1250 if Present
(Else_Expr
) then
1251 Analyze_Expression
(Else_Expr
);
1254 if not Is_Overloaded
(Then_Expr
) then
1255 Set_Etype
(N
, Etype
(Then_Expr
));
1262 Set_Etype
(N
, Any_Type
);
1263 Get_First_Interp
(Then_Expr
, I
, It
);
1264 while Present
(It
.Nam
) loop
1265 if Has_Compatible_Type
(Else_Expr
, It
.Typ
) then
1266 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1269 Get_Next_Interp
(I
, It
);
1273 end Analyze_Conditional_Expression
;
1275 -------------------------
1276 -- Analyze_Equality_Op --
1277 -------------------------
1279 procedure Analyze_Equality_Op
(N
: Node_Id
) is
1280 Loc
: constant Source_Ptr
:= Sloc
(N
);
1281 L
: constant Node_Id
:= Left_Opnd
(N
);
1282 R
: constant Node_Id
:= Right_Opnd
(N
);
1286 Set_Etype
(N
, Any_Type
);
1287 Candidate_Type
:= Empty
;
1289 Analyze_Expression
(L
);
1290 Analyze_Expression
(R
);
1292 -- If the entity is set, the node is a generic instance with a non-local
1293 -- reference to the predefined operator or to a user-defined function.
1294 -- It can also be an inequality that is expanded into the negation of a
1295 -- call to a user-defined equality operator.
1297 -- For the predefined case, the result is Boolean, regardless of the
1298 -- type of the operands. The operands may even be limited, if they are
1299 -- generic actuals. If they are overloaded, label the left argument with
1300 -- the common type that must be present, or with the type of the formal
1301 -- of the user-defined function.
1303 if Present
(Entity
(N
)) then
1304 Op_Id
:= Entity
(N
);
1306 if Ekind
(Op_Id
) = E_Operator
then
1307 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
1309 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1312 if Is_Overloaded
(L
) then
1313 if Ekind
(Op_Id
) = E_Operator
then
1314 Set_Etype
(L
, Intersect_Types
(L
, R
));
1316 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
1321 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1322 while Present
(Op_Id
) loop
1323 if Ekind
(Op_Id
) = E_Operator
then
1324 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1326 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1329 Op_Id
:= Homonym
(Op_Id
);
1333 -- If there was no match, and the operator is inequality, this may
1334 -- be a case where inequality has not been made explicit, as for
1335 -- tagged types. Analyze the node as the negation of an equality
1336 -- operation. This cannot be done earlier, because before analysis
1337 -- we cannot rule out the presence of an explicit inequality.
1339 if Etype
(N
) = Any_Type
1340 and then Nkind
(N
) = N_Op_Ne
1342 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
1343 while Present
(Op_Id
) loop
1344 if Ekind
(Op_Id
) = E_Operator
then
1345 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1347 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1350 Op_Id
:= Homonym
(Op_Id
);
1353 if Etype
(N
) /= Any_Type
then
1354 Op_Id
:= Entity
(N
);
1360 Left_Opnd
=> Left_Opnd
(N
),
1361 Right_Opnd
=> Right_Opnd
(N
))));
1363 Set_Entity
(Right_Opnd
(N
), Op_Id
);
1369 end Analyze_Equality_Op
;
1371 ----------------------------------
1372 -- Analyze_Explicit_Dereference --
1373 ----------------------------------
1375 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
1376 Loc
: constant Source_Ptr
:= Sloc
(N
);
1377 P
: constant Node_Id
:= Prefix
(N
);
1383 function Is_Function_Type
return Boolean;
1384 -- Check whether node may be interpreted as an implicit function call
1386 ----------------------
1387 -- Is_Function_Type --
1388 ----------------------
1390 function Is_Function_Type
return Boolean is
1395 if not Is_Overloaded
(N
) then
1396 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
1397 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
1400 Get_First_Interp
(N
, I
, It
);
1401 while Present
(It
.Nam
) loop
1402 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
1403 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
1408 Get_Next_Interp
(I
, It
);
1413 end Is_Function_Type
;
1415 -- Start of processing for Analyze_Explicit_Dereference
1419 Set_Etype
(N
, Any_Type
);
1421 -- Test for remote access to subprogram type, and if so return
1422 -- after rewriting the original tree.
1424 if Remote_AST_E_Dereference
(P
) then
1428 -- Normal processing for other than remote access to subprogram type
1430 if not Is_Overloaded
(P
) then
1431 if Is_Access_Type
(Etype
(P
)) then
1433 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
1434 -- avoid other problems caused by the Private_Subtype and it is
1435 -- safe to go to the Base_Type because this is the same as
1436 -- converting the access value to its Base_Type.
1439 DT
: Entity_Id
:= Designated_Type
(Etype
(P
));
1442 if Ekind
(DT
) = E_Private_Subtype
1443 and then Is_For_Access_Subtype
(DT
)
1445 DT
:= Base_Type
(DT
);
1448 -- An explicit dereference is a legal occurrence of an
1449 -- incomplete type imported through a limited_with clause,
1450 -- if the full view is visible.
1452 if From_With_Type
(DT
)
1453 and then not From_With_Type
(Scope
(DT
))
1455 (Is_Immediately_Visible
(Scope
(DT
))
1457 (Is_Child_Unit
(Scope
(DT
))
1458 and then Is_Visible_Child_Unit
(Scope
(DT
))))
1460 Set_Etype
(N
, Available_View
(DT
));
1467 elsif Etype
(P
) /= Any_Type
then
1468 Error_Msg_N
("prefix of dereference must be an access type", N
);
1473 Get_First_Interp
(P
, I
, It
);
1474 while Present
(It
.Nam
) loop
1477 if Is_Access_Type
(T
) then
1478 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
1481 Get_Next_Interp
(I
, It
);
1484 -- Error if no interpretation of the prefix has an access type
1486 if Etype
(N
) = Any_Type
then
1488 ("access type required in prefix of explicit dereference", P
);
1489 Set_Etype
(N
, Any_Type
);
1495 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
1497 and then (Nkind
(Parent
(N
)) /= N_Function_Call
1498 or else N
/= Name
(Parent
(N
)))
1500 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1501 or else N
/= Name
(Parent
(N
)))
1503 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
1504 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
1506 (Attribute_Name
(Parent
(N
)) /= Name_Address
1508 Attribute_Name
(Parent
(N
)) /= Name_Access
))
1510 -- Name is a function call with no actuals, in a context that
1511 -- requires deproceduring (including as an actual in an enclosing
1512 -- function or procedure call). There are some pathological cases
1513 -- where the prefix might include functions that return access to
1514 -- subprograms and others that return a regular type. Disambiguation
1515 -- of those has to take place in Resolve.
1518 Make_Function_Call
(Loc
,
1519 Name
=> Make_Explicit_Dereference
(Loc
, P
),
1520 Parameter_Associations
=> New_List
);
1522 -- If the prefix is overloaded, remove operations that have formals,
1523 -- we know that this is a parameterless call.
1525 if Is_Overloaded
(P
) then
1526 Get_First_Interp
(P
, I
, It
);
1527 while Present
(It
.Nam
) loop
1530 if No
(First_Formal
(Base_Type
(Designated_Type
(T
)))) then
1536 Get_Next_Interp
(I
, It
);
1543 elsif not Is_Function_Type
1544 and then Is_Overloaded
(N
)
1546 -- The prefix may include access to subprograms and other access
1547 -- types. If the context selects the interpretation that is a
1548 -- function call (not a procedure call) we cannot rewrite the node
1549 -- yet, but we include the result of the call interpretation.
1551 Get_First_Interp
(N
, I
, It
);
1552 while Present
(It
.Nam
) loop
1553 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
1554 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
1555 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1557 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
1560 Get_Next_Interp
(I
, It
);
1564 -- A value of remote access-to-class-wide must not be dereferenced
1567 Validate_Remote_Access_To_Class_Wide_Type
(N
);
1568 end Analyze_Explicit_Dereference
;
1570 ------------------------
1571 -- Analyze_Expression --
1572 ------------------------
1574 procedure Analyze_Expression
(N
: Node_Id
) is
1577 Check_Parameterless_Call
(N
);
1578 end Analyze_Expression
;
1580 ------------------------------------
1581 -- Analyze_Indexed_Component_Form --
1582 ------------------------------------
1584 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
1585 P
: constant Node_Id
:= Prefix
(N
);
1586 Exprs
: constant List_Id
:= Expressions
(N
);
1592 procedure Process_Function_Call
;
1593 -- Prefix in indexed component form is an overloadable entity,
1594 -- so the node is a function call. Reformat it as such.
1596 procedure Process_Indexed_Component
;
1597 -- Prefix in indexed component form is actually an indexed component.
1598 -- This routine processes it, knowing that the prefix is already
1601 procedure Process_Indexed_Component_Or_Slice
;
1602 -- An indexed component with a single index may designate a slice if
1603 -- the index is a subtype mark. This routine disambiguates these two
1604 -- cases by resolving the prefix to see if it is a subtype mark.
1606 procedure Process_Overloaded_Indexed_Component
;
1607 -- If the prefix of an indexed component is overloaded, the proper
1608 -- interpretation is selected by the index types and the context.
1610 ---------------------------
1611 -- Process_Function_Call --
1612 ---------------------------
1614 procedure Process_Function_Call
is
1618 Change_Node
(N
, N_Function_Call
);
1620 Set_Parameter_Associations
(N
, Exprs
);
1622 -- Analyze actuals prior to analyzing the call itself
1624 Actual
:= First
(Parameter_Associations
(N
));
1625 while Present
(Actual
) loop
1627 Check_Parameterless_Call
(Actual
);
1629 -- Move to next actual. Note that we use Next, not Next_Actual
1630 -- here. The reason for this is a bit subtle. If a function call
1631 -- includes named associations, the parser recognizes the node as
1632 -- a call, and it is analyzed as such. If all associations are
1633 -- positional, the parser builds an indexed_component node, and
1634 -- it is only after analysis of the prefix that the construct
1635 -- is recognized as a call, in which case Process_Function_Call
1636 -- rewrites the node and analyzes the actuals. If the list of
1637 -- actuals is malformed, the parser may leave the node as an
1638 -- indexed component (despite the presence of named associations).
1639 -- The iterator Next_Actual is equivalent to Next if the list is
1640 -- positional, but follows the normalized chain of actuals when
1641 -- named associations are present. In this case normalization has
1642 -- not taken place, and actuals remain unanalyzed, which leads to
1643 -- subsequent crashes or loops if there is an attempt to continue
1644 -- analysis of the program.
1650 end Process_Function_Call
;
1652 -------------------------------
1653 -- Process_Indexed_Component --
1654 -------------------------------
1656 procedure Process_Indexed_Component
is
1658 Array_Type
: Entity_Id
;
1660 Pent
: Entity_Id
:= Empty
;
1663 Exp
:= First
(Exprs
);
1665 if Is_Overloaded
(P
) then
1666 Process_Overloaded_Indexed_Component
;
1669 Array_Type
:= Etype
(P
);
1671 if Is_Entity_Name
(P
) then
1673 elsif Nkind
(P
) = N_Selected_Component
1674 and then Is_Entity_Name
(Selector_Name
(P
))
1676 Pent
:= Entity
(Selector_Name
(P
));
1679 -- Prefix must be appropriate for an array type, taking into
1680 -- account a possible implicit dereference.
1682 if Is_Access_Type
(Array_Type
) then
1683 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
1684 Array_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, P
);
1687 if Is_Array_Type
(Array_Type
) then
1690 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
1692 Set_Etype
(N
, Any_Type
);
1694 if not Has_Compatible_Type
1695 (Exp
, Entry_Index_Type
(Pent
))
1697 Error_Msg_N
("invalid index type in entry name", N
);
1699 elsif Present
(Next
(Exp
)) then
1700 Error_Msg_N
("too many subscripts in entry reference", N
);
1703 Set_Etype
(N
, Etype
(P
));
1708 elsif Is_Record_Type
(Array_Type
)
1709 and then Remote_AST_I_Dereference
(P
)
1713 elsif Array_Type
= Any_Type
then
1714 Set_Etype
(N
, Any_Type
);
1716 -- In most cases the analysis of the prefix will have emitted
1717 -- an error already, but if the prefix may be interpreted as a
1718 -- call in prefixed notation, the report is left to the caller.
1719 -- To prevent cascaded errors, report only if no previous ones.
1721 if Serious_Errors_Detected
= 0 then
1722 Error_Msg_N
("invalid prefix in indexed component", P
);
1724 if Nkind
(P
) = N_Expanded_Name
then
1725 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
1731 -- Here we definitely have a bad indexing
1734 if Nkind
(Parent
(N
)) = N_Requeue_Statement
1735 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
1738 ("REQUEUE does not permit parameters", First
(Exprs
));
1740 elsif Is_Entity_Name
(P
)
1741 and then Etype
(P
) = Standard_Void_Type
1743 Error_Msg_NE
("incorrect use of&", P
, Entity
(P
));
1746 Error_Msg_N
("array type required in indexed component", P
);
1749 Set_Etype
(N
, Any_Type
);
1753 Index
:= First_Index
(Array_Type
);
1754 while Present
(Index
) and then Present
(Exp
) loop
1755 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
1756 Wrong_Type
(Exp
, Etype
(Index
));
1757 Set_Etype
(N
, Any_Type
);
1765 Set_Etype
(N
, Component_Type
(Array_Type
));
1767 if Present
(Index
) then
1769 ("too few subscripts in array reference", First
(Exprs
));
1771 elsif Present
(Exp
) then
1772 Error_Msg_N
("too many subscripts in array reference", Exp
);
1775 end Process_Indexed_Component
;
1777 ----------------------------------------
1778 -- Process_Indexed_Component_Or_Slice --
1779 ----------------------------------------
1781 procedure Process_Indexed_Component_Or_Slice
is
1783 Exp
:= First
(Exprs
);
1784 while Present
(Exp
) loop
1785 Analyze_Expression
(Exp
);
1789 Exp
:= First
(Exprs
);
1791 -- If one index is present, and it is a subtype name, then the
1792 -- node denotes a slice (note that the case of an explicit range
1793 -- for a slice was already built as an N_Slice node in the first
1794 -- place, so that case is not handled here).
1796 -- We use a replace rather than a rewrite here because this is one
1797 -- of the cases in which the tree built by the parser is plain wrong.
1800 and then Is_Entity_Name
(Exp
)
1801 and then Is_Type
(Entity
(Exp
))
1804 Make_Slice
(Sloc
(N
),
1806 Discrete_Range
=> New_Copy
(Exp
)));
1809 -- Otherwise (more than one index present, or single index is not
1810 -- a subtype name), then we have the indexed component case.
1813 Process_Indexed_Component
;
1815 end Process_Indexed_Component_Or_Slice
;
1817 ------------------------------------------
1818 -- Process_Overloaded_Indexed_Component --
1819 ------------------------------------------
1821 procedure Process_Overloaded_Indexed_Component
is
1830 Set_Etype
(N
, Any_Type
);
1832 Get_First_Interp
(P
, I
, It
);
1833 while Present
(It
.Nam
) loop
1836 if Is_Access_Type
(Typ
) then
1837 Typ
:= Designated_Type
(Typ
);
1838 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
1841 if Is_Array_Type
(Typ
) then
1843 -- Got a candidate: verify that index types are compatible
1845 Index
:= First_Index
(Typ
);
1847 Exp
:= First
(Exprs
);
1848 while Present
(Index
) and then Present
(Exp
) loop
1849 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
1861 if Found
and then No
(Index
) and then No
(Exp
) then
1863 Etype
(Component_Type
(Typ
)),
1864 Etype
(Component_Type
(Typ
)));
1868 Get_Next_Interp
(I
, It
);
1871 if Etype
(N
) = Any_Type
then
1872 Error_Msg_N
("no legal interpretation for indexed component", N
);
1873 Set_Is_Overloaded
(N
, False);
1877 end Process_Overloaded_Indexed_Component
;
1879 -- Start of processing for Analyze_Indexed_Component_Form
1882 -- Get name of array, function or type
1886 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
) then
1888 -- If P is an explicit dereference whose prefix is of a
1889 -- remote access-to-subprogram type, then N has already
1890 -- been rewritten as a subprogram call and analyzed.
1895 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
1897 P_T
:= Base_Type
(Etype
(P
));
1899 if Is_Entity_Name
(P
)
1900 or else Nkind
(P
) = N_Operator_Symbol
1904 if Is_Type
(U_N
) then
1906 -- Reformat node as a type conversion
1908 E
:= Remove_Head
(Exprs
);
1910 if Present
(First
(Exprs
)) then
1912 ("argument of type conversion must be single expression", N
);
1915 Change_Node
(N
, N_Type_Conversion
);
1916 Set_Subtype_Mark
(N
, P
);
1918 Set_Expression
(N
, E
);
1920 -- After changing the node, call for the specific Analysis
1921 -- routine directly, to avoid a double call to the expander.
1923 Analyze_Type_Conversion
(N
);
1927 if Is_Overloadable
(U_N
) then
1928 Process_Function_Call
;
1930 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
1931 or else (Is_Access_Type
(Etype
(P
))
1933 Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
)
1935 -- Call to access_to-subprogram with possible implicit dereference
1937 Process_Function_Call
;
1939 elsif Is_Generic_Subprogram
(U_N
) then
1941 -- A common beginner's (or C++ templates fan) error
1943 Error_Msg_N
("generic subprogram cannot be called", N
);
1944 Set_Etype
(N
, Any_Type
);
1948 Process_Indexed_Component_Or_Slice
;
1951 -- If not an entity name, prefix is an expression that may denote
1952 -- an array or an access-to-subprogram.
1955 if Ekind
(P_T
) = E_Subprogram_Type
1956 or else (Is_Access_Type
(P_T
)
1958 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
1960 Process_Function_Call
;
1962 elsif Nkind
(P
) = N_Selected_Component
1963 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
1965 Process_Function_Call
;
1968 -- Indexed component, slice, or a call to a member of a family
1969 -- entry, which will be converted to an entry call later.
1971 Process_Indexed_Component_Or_Slice
;
1974 end Analyze_Indexed_Component_Form
;
1976 ------------------------
1977 -- Analyze_Logical_Op --
1978 ------------------------
1980 procedure Analyze_Logical_Op
(N
: Node_Id
) is
1981 L
: constant Node_Id
:= Left_Opnd
(N
);
1982 R
: constant Node_Id
:= Right_Opnd
(N
);
1983 Op_Id
: Entity_Id
:= Entity
(N
);
1986 Set_Etype
(N
, Any_Type
);
1987 Candidate_Type
:= Empty
;
1989 Analyze_Expression
(L
);
1990 Analyze_Expression
(R
);
1992 if Present
(Op_Id
) then
1994 if Ekind
(Op_Id
) = E_Operator
then
1995 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
1997 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2001 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2002 while Present
(Op_Id
) loop
2003 if Ekind
(Op_Id
) = E_Operator
then
2004 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2006 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2009 Op_Id
:= Homonym
(Op_Id
);
2014 end Analyze_Logical_Op
;
2016 ---------------------------
2017 -- Analyze_Membership_Op --
2018 ---------------------------
2020 procedure Analyze_Membership_Op
(N
: Node_Id
) is
2021 L
: constant Node_Id
:= Left_Opnd
(N
);
2022 R
: constant Node_Id
:= Right_Opnd
(N
);
2024 Index
: Interp_Index
;
2026 Found
: Boolean := False;
2030 procedure Try_One_Interp
(T1
: Entity_Id
);
2031 -- Routine to try one proposed interpretation. Note that the context
2032 -- of the operation plays no role in resolving the arguments, so that
2033 -- if there is more than one interpretation of the operands that is
2034 -- compatible with a membership test, the operation is ambiguous.
2036 --------------------
2037 -- Try_One_Interp --
2038 --------------------
2040 procedure Try_One_Interp
(T1
: Entity_Id
) is
2042 if Has_Compatible_Type
(R
, T1
) then
2044 and then Base_Type
(T1
) /= Base_Type
(T_F
)
2046 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
2048 if It
= No_Interp
then
2049 Ambiguous_Operands
(N
);
2050 Set_Etype
(L
, Any_Type
);
2067 procedure Analyze_Set_Membership
;
2068 -- If a set of alternatives is present, analyze each and find the
2069 -- common type to which they must all resolve.
2071 ----------------------------
2072 -- Analyze_Set_Membership --
2073 ----------------------------
2075 procedure Analyze_Set_Membership
is
2077 Index
: Interp_Index
;
2079 Candidate_Interps
: Node_Id
;
2080 Common_Type
: Entity_Id
:= Empty
;
2084 Candidate_Interps
:= L
;
2086 if not Is_Overloaded
(L
) then
2087 Common_Type
:= Etype
(L
);
2089 Alt
:= First
(Alternatives
(N
));
2090 while Present
(Alt
) loop
2093 if not Has_Compatible_Type
(Alt
, Common_Type
) then
2094 Wrong_Type
(Alt
, Common_Type
);
2101 Alt
:= First
(Alternatives
(N
));
2102 while Present
(Alt
) loop
2104 if not Is_Overloaded
(Alt
) then
2105 Common_Type
:= Etype
(Alt
);
2108 Get_First_Interp
(Alt
, Index
, It
);
2109 while Present
(It
.Typ
) loop
2111 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
2113 Remove_Interp
(Index
);
2116 Get_Next_Interp
(Index
, It
);
2119 Get_First_Interp
(Alt
, Index
, It
);
2122 Error_Msg_N
("alternative has no legal type", Alt
);
2126 -- If alternative is not overloaded, we have a unique type
2129 Set_Etype
(Alt
, It
.Typ
);
2130 Get_Next_Interp
(Index
, It
);
2133 Set_Is_Overloaded
(Alt
, False);
2134 Common_Type
:= Etype
(Alt
);
2137 Candidate_Interps
:= Alt
;
2144 Set_Etype
(N
, Standard_Boolean
);
2146 if Present
(Common_Type
) then
2147 Set_Etype
(L
, Common_Type
);
2148 Set_Is_Overloaded
(L
, False);
2151 Error_Msg_N
("cannot resolve membership operation", N
);
2153 end Analyze_Set_Membership
;
2155 -- Start of processing for Analyze_Membership_Op
2158 Analyze_Expression
(L
);
2161 and then Extensions_Allowed
2163 Analyze_Set_Membership
;
2167 if Nkind
(R
) = N_Range
2168 or else (Nkind
(R
) = N_Attribute_Reference
2169 and then Attribute_Name
(R
) = Name_Range
)
2173 if not Is_Overloaded
(L
) then
2174 Try_One_Interp
(Etype
(L
));
2177 Get_First_Interp
(L
, Index
, It
);
2178 while Present
(It
.Typ
) loop
2179 Try_One_Interp
(It
.Typ
);
2180 Get_Next_Interp
(Index
, It
);
2184 -- If not a range, it can only be a subtype mark, or else there
2185 -- is a more basic error, to be diagnosed in Find_Type.
2190 if Is_Entity_Name
(R
) then
2191 Check_Fully_Declared
(Entity
(R
), R
);
2195 -- Compatibility between expression and subtype mark or range is
2196 -- checked during resolution. The result of the operation is Boolean
2199 Set_Etype
(N
, Standard_Boolean
);
2201 if Comes_From_Source
(N
)
2202 and then Present
(Right_Opnd
(N
))
2203 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
2205 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
2207 end Analyze_Membership_Op
;
2209 ----------------------
2210 -- Analyze_Negation --
2211 ----------------------
2213 procedure Analyze_Negation
(N
: Node_Id
) is
2214 R
: constant Node_Id
:= Right_Opnd
(N
);
2215 Op_Id
: Entity_Id
:= Entity
(N
);
2218 Set_Etype
(N
, Any_Type
);
2219 Candidate_Type
:= Empty
;
2221 Analyze_Expression
(R
);
2223 if Present
(Op_Id
) then
2224 if Ekind
(Op_Id
) = E_Operator
then
2225 Find_Negation_Types
(R
, Op_Id
, N
);
2227 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2231 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2232 while Present
(Op_Id
) loop
2233 if Ekind
(Op_Id
) = E_Operator
then
2234 Find_Negation_Types
(R
, Op_Id
, N
);
2236 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
2239 Op_Id
:= Homonym
(Op_Id
);
2244 end Analyze_Negation
;
2250 procedure Analyze_Null
(N
: Node_Id
) is
2252 Set_Etype
(N
, Any_Access
);
2255 ----------------------
2256 -- Analyze_One_Call --
2257 ----------------------
2259 procedure Analyze_One_Call
2263 Success
: out Boolean;
2264 Skip_First
: Boolean := False)
2266 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2267 Prev_T
: constant Entity_Id
:= Etype
(N
);
2269 Must_Skip
: constant Boolean := Skip_First
2270 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
2272 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
2273 and then Nkind
(Prefix
(Original_Node
(N
)))
2274 = N_Selected_Component
);
2275 -- The first formal must be omitted from the match when trying to find
2276 -- a primitive operation that is a possible interpretation, and also
2277 -- after the call has been rewritten, because the corresponding actual
2278 -- is already known to be compatible, and because this may be an
2279 -- indexing of a call with default parameters.
2283 Is_Indexed
: Boolean := False;
2284 Is_Indirect
: Boolean := False;
2285 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
2288 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
2289 -- There may be a user-defined operator that hides the current
2290 -- interpretation. We must check for this independently of the
2291 -- analysis of the call with the user-defined operation, because
2292 -- the parameter names may be wrong and yet the hiding takes place.
2293 -- This fixes a problem with ACATS test B34014O.
2295 -- When the type Address is a visible integer type, and the DEC
2296 -- system extension is visible, the predefined operator may be
2297 -- hidden as well, by one of the address operations in auxdec.
2298 -- Finally, The abstract operations on address do not hide the
2299 -- predefined operator (this is the purpose of making them abstract).
2301 procedure Indicate_Name_And_Type
;
2302 -- If candidate interpretation matches, indicate name and type of
2303 -- result on call node.
2305 ----------------------------
2306 -- Indicate_Name_And_Type --
2307 ----------------------------
2309 procedure Indicate_Name_And_Type
is
2311 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
2314 -- If the prefix of the call is a name, indicate the entity
2315 -- being called. If it is not a name, it is an expression that
2316 -- denotes an access to subprogram or else an entry or family. In
2317 -- the latter case, the name is a selected component, and the entity
2318 -- being called is noted on the selector.
2320 if not Is_Type
(Nam
) then
2321 if Is_Entity_Name
(Name
(N
))
2322 or else Nkind
(Name
(N
)) = N_Operator_Symbol
2324 Set_Entity
(Name
(N
), Nam
);
2326 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
2327 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
2331 if Debug_Flag_E
and not Report
then
2332 Write_Str
(" Overloaded call ");
2333 Write_Int
(Int
(N
));
2334 Write_Str
(" compatible with ");
2335 Write_Int
(Int
(Nam
));
2338 end Indicate_Name_And_Type
;
2340 ------------------------
2341 -- Operator_Hidden_By --
2342 ------------------------
2344 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
2345 Act1
: constant Node_Id
:= First_Actual
(N
);
2346 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2347 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
2348 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
2351 if Ekind
(Fun
) /= E_Function
2352 or else Is_Abstract_Subprogram
(Fun
)
2356 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
2359 elsif Present
(Form2
) then
2361 No
(Act2
) or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
2366 elsif Present
(Act2
) then
2370 -- Now we know that the arity of the operator matches the function,
2371 -- and the function call is a valid interpretation. The function
2372 -- hides the operator if it has the right signature, or if one of
2373 -- its operands is a non-abstract operation on Address when this is
2374 -- a visible integer type.
2376 return Hides_Op
(Fun
, Nam
)
2377 or else Is_Descendent_Of_Address
(Etype
(Form1
))
2380 and then Is_Descendent_Of_Address
(Etype
(Form2
)));
2381 end Operator_Hidden_By
;
2383 -- Start of processing for Analyze_One_Call
2388 -- If the subprogram has no formals or if all the formals have defaults,
2389 -- and the return type is an array type, the node may denote an indexing
2390 -- of the result of a parameterless call. In Ada 2005, the subprogram
2391 -- may have one non-defaulted formal, and the call may have been written
2392 -- in prefix notation, so that the rebuilt parameter list has more than
2395 if not Is_Overloadable
(Nam
)
2396 and then Ekind
(Nam
) /= E_Subprogram_Type
2397 and then Ekind
(Nam
) /= E_Entry_Family
2402 -- An indexing requires at least one actual
2404 if not Is_Empty_List
(Actuals
)
2406 (Needs_No_Actuals
(Nam
)
2408 (Needs_One_Actual
(Nam
)
2409 and then Present
(Next_Actual
(First
(Actuals
)))))
2411 if Is_Array_Type
(Subp_Type
) then
2412 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
2414 elsif Is_Access_Type
(Subp_Type
)
2415 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
2419 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
2421 -- The prefix can also be a parameterless function that returns an
2422 -- access to subprogram, in which case this is an indirect call.
2423 -- If this succeeds, an explicit dereference is added later on,
2424 -- in Analyze_Call or Resolve_Call.
2426 elsif Is_Access_Type
(Subp_Type
)
2427 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
2429 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
2434 -- If the call has been transformed into a slice, it is of the form
2435 -- F (Subtype) where F is parameterless. The node has been rewritten in
2436 -- Try_Indexed_Call and there is nothing else to do.
2439 and then Nkind
(N
) = N_Slice
2445 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
2449 -- If an indirect call is a possible interpretation, indicate
2450 -- success to the caller.
2456 -- Mismatch in number or names of parameters
2458 elsif Debug_Flag_E
then
2459 Write_Str
(" normalization fails in call ");
2460 Write_Int
(Int
(N
));
2461 Write_Str
(" with subprogram ");
2462 Write_Int
(Int
(Nam
));
2466 -- If the context expects a function call, discard any interpretation
2467 -- that is a procedure. If the node is not overloaded, leave as is for
2468 -- better error reporting when type mismatch is found.
2470 elsif Nkind
(N
) = N_Function_Call
2471 and then Is_Overloaded
(Name
(N
))
2472 and then Ekind
(Nam
) = E_Procedure
2476 -- Ditto for function calls in a procedure context
2478 elsif Nkind
(N
) = N_Procedure_Call_Statement
2479 and then Is_Overloaded
(Name
(N
))
2480 and then Etype
(Nam
) /= Standard_Void_Type
2484 elsif No
(Actuals
) then
2486 -- If Normalize succeeds, then there are default parameters for
2489 Indicate_Name_And_Type
;
2491 elsif Ekind
(Nam
) = E_Operator
then
2492 if Nkind
(N
) = N_Procedure_Call_Statement
then
2496 -- This can occur when the prefix of the call is an operator
2497 -- name or an expanded name whose selector is an operator name.
2499 Analyze_Operator_Call
(N
, Nam
);
2501 if Etype
(N
) /= Prev_T
then
2503 -- Check that operator is not hidden by a function interpretation
2505 if Is_Overloaded
(Name
(N
)) then
2511 Get_First_Interp
(Name
(N
), I
, It
);
2512 while Present
(It
.Nam
) loop
2513 if Operator_Hidden_By
(It
.Nam
) then
2514 Set_Etype
(N
, Prev_T
);
2518 Get_Next_Interp
(I
, It
);
2523 -- If operator matches formals, record its name on the call.
2524 -- If the operator is overloaded, Resolve will select the
2525 -- correct one from the list of interpretations. The call
2526 -- node itself carries the first candidate.
2528 Set_Entity
(Name
(N
), Nam
);
2531 elsif Report
and then Etype
(N
) = Any_Type
then
2532 Error_Msg_N
("incompatible arguments for operator", N
);
2536 -- Normalize_Actuals has chained the named associations in the
2537 -- correct order of the formals.
2539 Actual
:= First_Actual
(N
);
2540 Formal
:= First_Formal
(Nam
);
2542 -- If we are analyzing a call rewritten from object notation,
2543 -- skip first actual, which may be rewritten later as an
2544 -- explicit dereference.
2547 Next_Actual
(Actual
);
2548 Next_Formal
(Formal
);
2551 while Present
(Actual
) and then Present
(Formal
) loop
2552 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
2553 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
2555 -- The actual can be compatible with the formal, but we must
2556 -- also check that the context is not an address type that is
2557 -- visibly an integer type, as is the case in VMS_64. In this
2558 -- case the use of literals is illegal, except in the body of
2559 -- descendents of system, where arithmetic operations on
2560 -- address are of course used.
2562 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
2564 (Etype
(Actual
) /= Universal_Integer
2565 or else not Is_Descendent_Of_Address
(Etype
(Formal
))
2567 Is_Predefined_File_Name
2568 (Unit_File_Name
(Get_Source_Unit
(N
))))
2570 Next_Actual
(Actual
);
2571 Next_Formal
(Formal
);
2574 if Debug_Flag_E
then
2575 Write_Str
(" type checking fails in call ");
2576 Write_Int
(Int
(N
));
2577 Write_Str
(" with formal ");
2578 Write_Int
(Int
(Formal
));
2579 Write_Str
(" in subprogram ");
2580 Write_Int
(Int
(Nam
));
2584 if Report
and not Is_Indexed
and not Is_Indirect
then
2586 -- Ada 2005 (AI-251): Complete the error notification
2587 -- to help new Ada 2005 users.
2589 if Is_Class_Wide_Type
(Etype
(Formal
))
2590 and then Is_Interface
(Etype
(Etype
(Formal
)))
2591 and then not Interface_Present_In_Ancestor
2592 (Typ
=> Etype
(Actual
),
2593 Iface
=> Etype
(Etype
(Formal
)))
2596 ("(Ada 2005) does not implement interface }",
2597 Actual
, Etype
(Etype
(Formal
)));
2600 Wrong_Type
(Actual
, Etype
(Formal
));
2602 if Nkind
(Actual
) = N_Op_Eq
2603 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
2605 Formal
:= First_Formal
(Nam
);
2606 while Present
(Formal
) loop
2607 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
2608 Error_Msg_N
-- CODEFIX
2609 ("possible misspelling of `='>`!", Actual
);
2613 Next_Formal
(Formal
);
2617 if All_Errors_Mode
then
2618 Error_Msg_Sloc
:= Sloc
(Nam
);
2620 if Is_Overloadable
(Nam
)
2621 and then Present
(Alias
(Nam
))
2622 and then not Comes_From_Source
(Nam
)
2625 ("\\ =='> in call to inherited operation & #!",
2628 elsif Ekind
(Nam
) = E_Subprogram_Type
then
2630 Access_To_Subprogram_Typ
:
2631 constant Entity_Id
:=
2633 (Associated_Node_For_Itype
(Nam
));
2636 "\\ =='> in call to dereference of &#!",
2637 Actual
, Access_To_Subprogram_Typ
);
2642 ("\\ =='> in call to &#!", Actual
, Nam
);
2652 -- Normalize_Actuals has verified that a default value exists
2653 -- for this formal. Current actual names a subsequent formal.
2655 Next_Formal
(Formal
);
2659 -- On exit, all actuals match
2661 Indicate_Name_And_Type
;
2663 end Analyze_One_Call
;
2665 ---------------------------
2666 -- Analyze_Operator_Call --
2667 ---------------------------
2669 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
2670 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
2671 Act1
: constant Node_Id
:= First_Actual
(N
);
2672 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2675 -- Binary operator case
2677 if Present
(Act2
) then
2679 -- If more than two operands, then not binary operator after all
2681 if Present
(Next_Actual
(Act2
)) then
2684 elsif Op_Name
= Name_Op_Add
2685 or else Op_Name
= Name_Op_Subtract
2686 or else Op_Name
= Name_Op_Multiply
2687 or else Op_Name
= Name_Op_Divide
2688 or else Op_Name
= Name_Op_Mod
2689 or else Op_Name
= Name_Op_Rem
2690 or else Op_Name
= Name_Op_Expon
2692 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
2694 elsif Op_Name
= Name_Op_And
2695 or else Op_Name
= Name_Op_Or
2696 or else Op_Name
= Name_Op_Xor
2698 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
2700 elsif Op_Name
= Name_Op_Lt
2701 or else Op_Name
= Name_Op_Le
2702 or else Op_Name
= Name_Op_Gt
2703 or else Op_Name
= Name_Op_Ge
2705 Find_Comparison_Types
(Act1
, Act2
, Op_Id
, N
);
2707 elsif Op_Name
= Name_Op_Eq
2708 or else Op_Name
= Name_Op_Ne
2710 Find_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
2712 elsif Op_Name
= Name_Op_Concat
then
2713 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
2715 -- Is this else null correct, or should it be an abort???
2721 -- Unary operator case
2724 if Op_Name
= Name_Op_Subtract
or else
2725 Op_Name
= Name_Op_Add
or else
2726 Op_Name
= Name_Op_Abs
2728 Find_Unary_Types
(Act1
, Op_Id
, N
);
2731 Op_Name
= Name_Op_Not
2733 Find_Negation_Types
(Act1
, Op_Id
, N
);
2735 -- Is this else null correct, or should it be an abort???
2741 end Analyze_Operator_Call
;
2743 -------------------------------------------
2744 -- Analyze_Overloaded_Selected_Component --
2745 -------------------------------------------
2747 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
2748 Nam
: constant Node_Id
:= Prefix
(N
);
2749 Sel
: constant Node_Id
:= Selector_Name
(N
);
2756 Set_Etype
(Sel
, Any_Type
);
2758 Get_First_Interp
(Nam
, I
, It
);
2759 while Present
(It
.Typ
) loop
2760 if Is_Access_Type
(It
.Typ
) then
2761 T
:= Designated_Type
(It
.Typ
);
2762 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
2767 if Is_Record_Type
(T
) then
2769 -- If the prefix is a class-wide type, the visible components are
2770 -- those of the base type.
2772 if Is_Class_Wide_Type
(T
) then
2776 Comp
:= First_Entity
(T
);
2777 while Present
(Comp
) loop
2778 if Chars
(Comp
) = Chars
(Sel
)
2779 and then Is_Visible_Component
(Comp
)
2782 -- AI05-105: if the context is an object renaming with
2783 -- an anonymous access type, the expected type of the
2784 -- object must be anonymous. This is a name resolution rule.
2786 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
2787 or else No
(Access_Definition
(Parent
(N
)))
2788 or else Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Type
2790 Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Subprogram_Type
2792 Set_Entity
(Sel
, Comp
);
2793 Set_Etype
(Sel
, Etype
(Comp
));
2794 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
2796 -- This also specifies a candidate to resolve the name.
2797 -- Further overloading will be resolved from context.
2798 -- The selector name itself does not carry overloading
2801 Set_Etype
(Nam
, It
.Typ
);
2804 -- Named access type in the context of a renaming
2805 -- declaration with an access definition. Remove
2806 -- inapplicable candidate.
2815 elsif Is_Concurrent_Type
(T
) then
2816 Comp
:= First_Entity
(T
);
2817 while Present
(Comp
)
2818 and then Comp
/= First_Private_Entity
(T
)
2820 if Chars
(Comp
) = Chars
(Sel
) then
2821 if Is_Overloadable
(Comp
) then
2822 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
2824 Set_Entity_With_Style_Check
(Sel
, Comp
);
2825 Generate_Reference
(Comp
, Sel
);
2828 Set_Etype
(Sel
, Etype
(Comp
));
2829 Set_Etype
(N
, Etype
(Comp
));
2830 Set_Etype
(Nam
, It
.Typ
);
2832 -- For access type case, introduce explicit dereference for
2833 -- more uniform treatment of entry calls. Do this only once
2834 -- if several interpretations yield an access type.
2836 if Is_Access_Type
(Etype
(Nam
))
2837 and then Nkind
(Nam
) /= N_Explicit_Dereference
2839 Insert_Explicit_Dereference
(Nam
);
2841 (Warn_On_Dereference
, "?implicit dereference", N
);
2848 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
2851 Get_Next_Interp
(I
, It
);
2854 if Etype
(N
) = Any_Type
2855 and then not Try_Object_Operation
(N
)
2857 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
2858 Set_Entity
(Sel
, Any_Id
);
2859 Set_Etype
(Sel
, Any_Type
);
2861 end Analyze_Overloaded_Selected_Component
;
2863 ----------------------------------
2864 -- Analyze_Qualified_Expression --
2865 ----------------------------------
2867 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
2868 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
2869 Expr
: constant Node_Id
:= Expression
(N
);
2875 Analyze_Expression
(Expr
);
2877 Set_Etype
(N
, Any_Type
);
2882 if T
= Any_Type
then
2886 Check_Fully_Declared
(T
, N
);
2888 -- If expected type is class-wide, check for exact match before
2889 -- expansion, because if the expression is a dispatching call it
2890 -- may be rewritten as explicit dereference with class-wide result.
2891 -- If expression is overloaded, retain only interpretations that
2892 -- will yield exact matches.
2894 if Is_Class_Wide_Type
(T
) then
2895 if not Is_Overloaded
(Expr
) then
2896 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
) then
2897 if Nkind
(Expr
) = N_Aggregate
then
2898 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
2900 Wrong_Type
(Expr
, T
);
2905 Get_First_Interp
(Expr
, I
, It
);
2907 while Present
(It
.Nam
) loop
2908 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
2912 Get_Next_Interp
(I
, It
);
2918 end Analyze_Qualified_Expression
;
2924 procedure Analyze_Range
(N
: Node_Id
) is
2925 L
: constant Node_Id
:= Low_Bound
(N
);
2926 H
: constant Node_Id
:= High_Bound
(N
);
2927 I1
, I2
: Interp_Index
;
2930 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
2931 -- Verify the compatibility of two types, and choose the
2932 -- non universal one if the other is universal.
2934 procedure Check_High_Bound
(T
: Entity_Id
);
2935 -- Test one interpretation of the low bound against all those
2936 -- of the high bound.
2938 procedure Check_Universal_Expression
(N
: Node_Id
);
2939 -- In Ada83, reject bounds of a universal range that are not
2940 -- literals or entity names.
2942 -----------------------
2943 -- Check_Common_Type --
2944 -----------------------
2946 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
2948 if Covers
(T1
=> T1
, T2
=> T2
)
2950 Covers
(T1
=> T2
, T2
=> T1
)
2952 if T1
= Universal_Integer
2953 or else T1
= Universal_Real
2954 or else T1
= Any_Character
2956 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
2959 Add_One_Interp
(N
, T1
, T1
);
2962 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
2965 end Check_Common_Type
;
2967 ----------------------
2968 -- Check_High_Bound --
2969 ----------------------
2971 procedure Check_High_Bound
(T
: Entity_Id
) is
2973 if not Is_Overloaded
(H
) then
2974 Check_Common_Type
(T
, Etype
(H
));
2976 Get_First_Interp
(H
, I2
, It2
);
2977 while Present
(It2
.Typ
) loop
2978 Check_Common_Type
(T
, It2
.Typ
);
2979 Get_Next_Interp
(I2
, It2
);
2982 end Check_High_Bound
;
2984 -----------------------------
2985 -- Is_Universal_Expression --
2986 -----------------------------
2988 procedure Check_Universal_Expression
(N
: Node_Id
) is
2990 if Etype
(N
) = Universal_Integer
2991 and then Nkind
(N
) /= N_Integer_Literal
2992 and then not Is_Entity_Name
(N
)
2993 and then Nkind
(N
) /= N_Attribute_Reference
2995 Error_Msg_N
("illegal bound in discrete range", N
);
2997 end Check_Universal_Expression
;
2999 -- Start of processing for Analyze_Range
3002 Set_Etype
(N
, Any_Type
);
3003 Analyze_Expression
(L
);
3004 Analyze_Expression
(H
);
3006 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
3010 if not Is_Overloaded
(L
) then
3011 Check_High_Bound
(Etype
(L
));
3013 Get_First_Interp
(L
, I1
, It1
);
3014 while Present
(It1
.Typ
) loop
3015 Check_High_Bound
(It1
.Typ
);
3016 Get_Next_Interp
(I1
, It1
);
3020 -- If result is Any_Type, then we did not find a compatible pair
3022 if Etype
(N
) = Any_Type
then
3023 Error_Msg_N
("incompatible types in range ", N
);
3027 if Ada_Version
= Ada_83
3029 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
3030 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
3032 Check_Universal_Expression
(L
);
3033 Check_Universal_Expression
(H
);
3037 -----------------------
3038 -- Analyze_Reference --
3039 -----------------------
3041 procedure Analyze_Reference
(N
: Node_Id
) is
3042 P
: constant Node_Id
:= Prefix
(N
);
3045 Acc_Type
: Entity_Id
;
3050 -- An interesting error check, if we take the 'Reference of an object
3051 -- for which a pragma Atomic or Volatile has been given, and the type
3052 -- of the object is not Atomic or Volatile, then we are in trouble. The
3053 -- problem is that no trace of the atomic/volatile status will remain
3054 -- for the backend to respect when it deals with the resulting pointer,
3055 -- since the pointer type will not be marked atomic (it is a pointer to
3056 -- the base type of the object).
3058 -- It is not clear if that can ever occur, but in case it does, we will
3059 -- generate an error message. Not clear if this message can ever be
3060 -- generated, and pretty clear that it represents a bug if it is, still
3061 -- seems worth checking!
3065 if Is_Entity_Name
(P
)
3066 and then Is_Object_Reference
(P
)
3071 if (Has_Atomic_Components
(E
)
3072 and then not Has_Atomic_Components
(T
))
3074 (Has_Volatile_Components
(E
)
3075 and then not Has_Volatile_Components
(T
))
3076 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
3077 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
3079 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
3083 -- Carry on with normal processing
3085 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
3086 Set_Etype
(Acc_Type
, Acc_Type
);
3087 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
3088 Set_Etype
(N
, Acc_Type
);
3089 end Analyze_Reference
;
3091 --------------------------------
3092 -- Analyze_Selected_Component --
3093 --------------------------------
3095 -- Prefix is a record type or a task or protected type. In the
3096 -- later case, the selector must denote a visible entry.
3098 procedure Analyze_Selected_Component
(N
: Node_Id
) is
3099 Name
: constant Node_Id
:= Prefix
(N
);
3100 Sel
: constant Node_Id
:= Selector_Name
(N
);
3103 Has_Candidate
: Boolean := False;
3106 Pent
: Entity_Id
:= Empty
;
3107 Prefix_Type
: Entity_Id
;
3109 Type_To_Use
: Entity_Id
;
3110 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
3111 -- a class-wide type, we use its root type, whose components are
3112 -- present in the class-wide type.
3114 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
3115 -- It is known that the parent of N denotes a subprogram call. Comp
3116 -- is an overloadable component of the concurrent type of the prefix.
3117 -- Determine whether all formals of the parent of N and Comp are mode
3118 -- conformant. If the parent node is not analyzed yet it may be an
3119 -- indexed component rather than a function call.
3121 ------------------------------
3122 -- Has_Mode_Conformant_Spec --
3123 ------------------------------
3125 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
3126 Comp_Param
: Entity_Id
;
3128 Param_Typ
: Entity_Id
;
3131 Comp_Param
:= First_Formal
(Comp
);
3133 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
3134 Param
:= First
(Expressions
(Parent
(N
)));
3136 Param
:= First
(Parameter_Associations
(Parent
(N
)));
3139 while Present
(Comp_Param
)
3140 and then Present
(Param
)
3142 Param_Typ
:= Find_Parameter_Type
(Param
);
3144 if Present
(Param_Typ
)
3146 not Conforming_Types
3147 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
3152 Next_Formal
(Comp_Param
);
3156 -- One of the specs has additional formals
3158 if Present
(Comp_Param
) or else Present
(Param
) then
3163 end Has_Mode_Conformant_Spec
;
3165 -- Start of processing for Analyze_Selected_Component
3168 Set_Etype
(N
, Any_Type
);
3170 if Is_Overloaded
(Name
) then
3171 Analyze_Overloaded_Selected_Component
(N
);
3174 elsif Etype
(Name
) = Any_Type
then
3175 Set_Entity
(Sel
, Any_Id
);
3176 Set_Etype
(Sel
, Any_Type
);
3180 Prefix_Type
:= Etype
(Name
);
3183 if Is_Access_Type
(Prefix_Type
) then
3185 -- A RACW object can never be used as prefix of a selected
3186 -- component since that means it is dereferenced without
3187 -- being a controlling operand of a dispatching operation
3188 -- (RM E.2.2(16/1)). Before reporting an error, we must check
3189 -- whether this is actually a dispatching call in prefix form.
3191 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
3192 and then Comes_From_Source
(N
)
3194 if Try_Object_Operation
(N
) then
3198 ("invalid dereference of a remote access-to-class-wide value",
3202 -- Normal case of selected component applied to access type
3205 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3207 if Is_Entity_Name
(Name
) then
3208 Pent
:= Entity
(Name
);
3209 elsif Nkind
(Name
) = N_Selected_Component
3210 and then Is_Entity_Name
(Selector_Name
(Name
))
3212 Pent
:= Entity
(Selector_Name
(Name
));
3215 Prefix_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, Name
);
3218 -- If we have an explicit dereference of a remote access-to-class-wide
3219 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
3220 -- have to check for the case of a prefix that is a controlling operand
3221 -- of a prefixed dispatching call, as the dereference is legal in that
3222 -- case. Normally this condition is checked in Validate_Remote_Access_
3223 -- To_Class_Wide_Type, but we have to defer the checking for selected
3224 -- component prefixes because of the prefixed dispatching call case.
3225 -- Note that implicit dereferences are checked for this just above.
3227 elsif Nkind
(Name
) = N_Explicit_Dereference
3228 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Name
)))
3229 and then Comes_From_Source
(N
)
3231 if Try_Object_Operation
(N
) then
3235 ("invalid dereference of a remote access-to-class-wide value",
3240 -- (Ada 2005): if the prefix is the limited view of a type, and
3241 -- the context already includes the full view, use the full view
3242 -- in what follows, either to retrieve a component of to find
3243 -- a primitive operation. If the prefix is an explicit dereference,
3244 -- set the type of the prefix to reflect this transformation.
3245 -- If the non-limited view is itself an incomplete type, get the
3246 -- full view if available.
3248 if Is_Incomplete_Type
(Prefix_Type
)
3249 and then From_With_Type
(Prefix_Type
)
3250 and then Present
(Non_Limited_View
(Prefix_Type
))
3252 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
3254 if Nkind
(N
) = N_Explicit_Dereference
then
3255 Set_Etype
(Prefix
(N
), Prefix_Type
);
3258 elsif Ekind
(Prefix_Type
) = E_Class_Wide_Type
3259 and then From_With_Type
(Prefix_Type
)
3260 and then Present
(Non_Limited_View
(Etype
(Prefix_Type
)))
3263 Class_Wide_Type
(Non_Limited_View
(Etype
(Prefix_Type
)));
3265 if Nkind
(N
) = N_Explicit_Dereference
then
3266 Set_Etype
(Prefix
(N
), Prefix_Type
);
3270 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
3271 Prefix_Type
:= Base_Type
(Prefix_Type
);
3274 Type_To_Use
:= Prefix_Type
;
3276 -- For class-wide types, use the entity list of the root type. This
3277 -- indirection is specially important for private extensions because
3278 -- only the root type get switched (not the class-wide type).
3280 if Is_Class_Wide_Type
(Prefix_Type
) then
3281 Type_To_Use
:= Root_Type
(Prefix_Type
);
3284 Comp
:= First_Entity
(Type_To_Use
);
3286 -- If the selector has an original discriminant, the node appears in
3287 -- an instance. Replace the discriminant with the corresponding one
3288 -- in the current discriminated type. For nested generics, this must
3289 -- be done transitively, so note the new original discriminant.
3291 if Nkind
(Sel
) = N_Identifier
3292 and then Present
(Original_Discriminant
(Sel
))
3294 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
3296 -- Mark entity before rewriting, for completeness and because
3297 -- subsequent semantic checks might examine the original node.
3299 Set_Entity
(Sel
, Comp
);
3300 Rewrite
(Selector_Name
(N
),
3301 New_Occurrence_Of
(Comp
, Sloc
(N
)));
3302 Set_Original_Discriminant
(Selector_Name
(N
), Comp
);
3303 Set_Etype
(N
, Etype
(Comp
));
3305 if Is_Access_Type
(Etype
(Name
)) then
3306 Insert_Explicit_Dereference
(Name
);
3307 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3310 elsif Is_Record_Type
(Prefix_Type
) then
3312 -- Find component with given name
3314 while Present
(Comp
) loop
3315 if Chars
(Comp
) = Chars
(Sel
)
3316 and then Is_Visible_Component
(Comp
)
3318 Set_Entity_With_Style_Check
(Sel
, Comp
);
3319 Set_Etype
(Sel
, Etype
(Comp
));
3321 if Ekind
(Comp
) = E_Discriminant
then
3322 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
3324 ("cannot reference discriminant of Unchecked_Union",
3328 if Is_Generic_Type
(Prefix_Type
)
3330 Is_Generic_Type
(Root_Type
(Prefix_Type
))
3332 Set_Original_Discriminant
(Sel
, Comp
);
3336 -- Resolve the prefix early otherwise it is not possible to
3337 -- build the actual subtype of the component: it may need
3338 -- to duplicate this prefix and duplication is only allowed
3339 -- on fully resolved expressions.
3343 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
3344 -- subtypes in a package specification.
3347 -- limited with Pkg;
3349 -- type Acc_Inc is access Pkg.T;
3351 -- N : Natural := X.all.Comp; -- ERROR, limited view
3352 -- end Pkg; -- Comp is not visible
3354 if Nkind
(Name
) = N_Explicit_Dereference
3355 and then From_With_Type
(Etype
(Prefix
(Name
)))
3356 and then not Is_Potentially_Use_Visible
(Etype
(Name
))
3357 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
3358 N_Package_Specification
3361 ("premature usage of incomplete}", Prefix
(Name
),
3362 Etype
(Prefix
(Name
)));
3365 -- We never need an actual subtype for the case of a selection
3366 -- for a indexed component of a non-packed array, since in
3367 -- this case gigi generates all the checks and can find the
3368 -- necessary bounds information.
3370 -- We also do not need an actual subtype for the case of
3371 -- a first, last, length, or range attribute applied to a
3372 -- non-packed array, since gigi can again get the bounds in
3373 -- these cases (gigi cannot handle the packed case, since it
3374 -- has the bounds of the packed array type, not the original
3375 -- bounds of the type). However, if the prefix is itself a
3376 -- selected component, as in a.b.c (i), gigi may regard a.b.c
3377 -- as a dynamic-sized temporary, so we do generate an actual
3378 -- subtype for this case.
3380 Parent_N
:= Parent
(N
);
3382 if not Is_Packed
(Etype
(Comp
))
3384 ((Nkind
(Parent_N
) = N_Indexed_Component
3385 and then Nkind
(Name
) /= N_Selected_Component
)
3387 (Nkind
(Parent_N
) = N_Attribute_Reference
3388 and then (Attribute_Name
(Parent_N
) = Name_First
3390 Attribute_Name
(Parent_N
) = Name_Last
3392 Attribute_Name
(Parent_N
) = Name_Length
3394 Attribute_Name
(Parent_N
) = Name_Range
)))
3396 Set_Etype
(N
, Etype
(Comp
));
3398 -- If full analysis is not enabled, we do not generate an
3399 -- actual subtype, because in the absence of expansion
3400 -- reference to a formal of a protected type, for example,
3401 -- will not be properly transformed, and will lead to
3402 -- out-of-scope references in gigi.
3404 -- In all other cases, we currently build an actual subtype.
3405 -- It seems likely that many of these cases can be avoided,
3406 -- but right now, the front end makes direct references to the
3407 -- bounds (e.g. in generating a length check), and if we do
3408 -- not make an actual subtype, we end up getting a direct
3409 -- reference to a discriminant, which will not do.
3411 elsif Full_Analysis
then
3413 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
3414 Insert_Action
(N
, Act_Decl
);
3416 if No
(Act_Decl
) then
3417 Set_Etype
(N
, Etype
(Comp
));
3420 -- Component type depends on discriminants. Enter the
3421 -- main attributes of the subtype.
3424 Subt
: constant Entity_Id
:=
3425 Defining_Identifier
(Act_Decl
);
3428 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
3429 Set_Ekind
(Subt
, Ekind
(Etype
(Comp
)));
3430 Set_Etype
(N
, Subt
);
3434 -- If Full_Analysis not enabled, just set the Etype
3437 Set_Etype
(N
, Etype
(Comp
));
3443 -- If the prefix is a private extension, check only the visible
3444 -- components of the partial view. This must include the tag,
3445 -- which can appear in expanded code in a tag check.
3447 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
3448 and then Chars
(Selector_Name
(N
)) /= Name_uTag
3450 exit when Comp
= Last_Entity
(Type_To_Use
);
3456 -- Ada 2005 (AI-252): The selected component can be interpreted as
3457 -- a prefixed view of a subprogram. Depending on the context, this is
3458 -- either a name that can appear in a renaming declaration, or part
3459 -- of an enclosing call given in prefix form.
3461 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
3462 -- selected component should resolve to a name.
3464 if Ada_Version
>= Ada_05
3465 and then Is_Tagged_Type
(Prefix_Type
)
3466 and then not Is_Concurrent_Type
(Prefix_Type
)
3468 if Nkind
(Parent
(N
)) = N_Generic_Association
3469 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
3470 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
3472 if Find_Primitive_Operation
(N
) then
3476 elsif Try_Object_Operation
(N
) then
3480 -- If the transformation fails, it will be necessary to redo the
3481 -- analysis with all errors enabled, to indicate candidate
3482 -- interpretations and reasons for each failure ???
3486 elsif Is_Private_Type
(Prefix_Type
) then
3488 -- Allow access only to discriminants of the type. If the type has
3489 -- no full view, gigi uses the parent type for the components, so we
3490 -- do the same here.
3492 if No
(Full_View
(Prefix_Type
)) then
3493 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
3494 Comp
:= First_Entity
(Type_To_Use
);
3497 while Present
(Comp
) loop
3498 if Chars
(Comp
) = Chars
(Sel
) then
3499 if Ekind
(Comp
) = E_Discriminant
then
3500 Set_Entity_With_Style_Check
(Sel
, Comp
);
3501 Generate_Reference
(Comp
, Sel
);
3503 Set_Etype
(Sel
, Etype
(Comp
));
3504 Set_Etype
(N
, Etype
(Comp
));
3506 if Is_Generic_Type
(Prefix_Type
)
3507 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
3509 Set_Original_Discriminant
(Sel
, Comp
);
3512 -- Before declaring an error, check whether this is tagged
3513 -- private type and a call to a primitive operation.
3515 elsif Ada_Version
>= Ada_05
3516 and then Is_Tagged_Type
(Prefix_Type
)
3517 and then Try_Object_Operation
(N
)
3523 ("invisible selector for }",
3524 N
, First_Subtype
(Prefix_Type
));
3525 Set_Entity
(Sel
, Any_Id
);
3526 Set_Etype
(N
, Any_Type
);
3535 elsif Is_Concurrent_Type
(Prefix_Type
) then
3537 -- Find visible operation with given name. For a protected type,
3538 -- the possible candidates are discriminants, entries or protected
3539 -- procedures. For a task type, the set can only include entries or
3540 -- discriminants if the task type is not an enclosing scope. If it
3541 -- is an enclosing scope (e.g. in an inner task) then all entities
3542 -- are visible, but the prefix must denote the enclosing scope, i.e.
3543 -- can only be a direct name or an expanded name.
3545 Set_Etype
(Sel
, Any_Type
);
3546 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
3548 while Present
(Comp
) loop
3549 if Chars
(Comp
) = Chars
(Sel
) then
3550 if Is_Overloadable
(Comp
) then
3551 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3553 -- If the prefix is tagged, the correct interpretation may
3554 -- lie in the primitive or class-wide operations of the
3555 -- type. Perform a simple conformance check to determine
3556 -- whether Try_Object_Operation should be invoked even if
3557 -- a visible entity is found.
3559 if Is_Tagged_Type
(Prefix_Type
)
3561 Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
3563 N_Indexed_Component
)
3564 and then Has_Mode_Conformant_Spec
(Comp
)
3566 Has_Candidate
:= True;
3569 elsif Ekind
(Comp
) = E_Discriminant
3570 or else Ekind
(Comp
) = E_Entry_Family
3572 and then Is_Entity_Name
(Name
))
3574 Set_Entity_With_Style_Check
(Sel
, Comp
);
3575 Generate_Reference
(Comp
, Sel
);
3581 Set_Etype
(Sel
, Etype
(Comp
));
3582 Set_Etype
(N
, Etype
(Comp
));
3584 if Ekind
(Comp
) = E_Discriminant
then
3585 Set_Original_Discriminant
(Sel
, Comp
);
3588 -- For access type case, introduce explicit dereference for
3589 -- more uniform treatment of entry calls.
3591 if Is_Access_Type
(Etype
(Name
)) then
3592 Insert_Explicit_Dereference
(Name
);
3594 (Warn_On_Dereference
, "?implicit dereference", N
);
3600 exit when not In_Scope
3602 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
3605 -- If there is no visible entity with the given name or none of the
3606 -- visible entities are plausible interpretations, check whether
3607 -- there is some other primitive operation with that name.
3609 if Ada_Version
>= Ada_05
3610 and then Is_Tagged_Type
(Prefix_Type
)
3612 if (Etype
(N
) = Any_Type
3613 or else not Has_Candidate
)
3614 and then Try_Object_Operation
(N
)
3618 -- If the context is not syntactically a procedure call, it
3619 -- may be a call to a primitive function declared outside of
3620 -- the synchronized type.
3622 -- If the context is a procedure call, there might still be
3623 -- an overloading between an entry and a primitive procedure
3624 -- declared outside of the synchronized type, called in prefix
3625 -- notation. This is harder to disambiguate because in one case
3626 -- the controlling formal is implicit ???
3628 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
3629 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
3630 and then Try_Object_Operation
(N
)
3636 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3641 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
3644 -- If N still has no type, the component is not defined in the prefix
3646 if Etype
(N
) = Any_Type
then
3648 -- If the prefix is a single concurrent object, use its name in the
3649 -- error message, rather than that of its anonymous type.
3651 if Is_Concurrent_Type
(Prefix_Type
)
3652 and then Is_Internal_Name
(Chars
(Prefix_Type
))
3653 and then not Is_Derived_Type
(Prefix_Type
)
3654 and then Is_Entity_Name
(Name
)
3657 Error_Msg_Node_2
:= Entity
(Name
);
3658 Error_Msg_NE
("no selector& for&", N
, Sel
);
3660 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
3662 elsif Is_Generic_Type
(Prefix_Type
)
3663 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
3664 and then Prefix_Type
/= Etype
(Prefix_Type
)
3665 and then Is_Record_Type
(Etype
(Prefix_Type
))
3667 -- If this is a derived formal type, the parent may have
3668 -- different visibility at this point. Try for an inherited
3669 -- component before reporting an error.
3671 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
3672 Analyze_Selected_Component
(N
);
3675 elsif Ekind
(Prefix_Type
) = E_Record_Subtype_With_Private
3676 and then Is_Generic_Actual_Type
(Prefix_Type
)
3677 and then Present
(Full_View
(Prefix_Type
))
3679 -- Similarly, if this the actual for a formal derived type, the
3680 -- component inherited from the generic parent may not be visible
3681 -- in the actual, but the selected component is legal.
3688 First_Component
(Generic_Parent_Type
(Parent
(Prefix_Type
)));
3689 while Present
(Comp
) loop
3690 if Chars
(Comp
) = Chars
(Sel
) then
3691 Set_Entity_With_Style_Check
(Sel
, Comp
);
3692 Set_Etype
(Sel
, Etype
(Comp
));
3693 Set_Etype
(N
, Etype
(Comp
));
3697 Next_Component
(Comp
);
3700 pragma Assert
(Etype
(N
) /= Any_Type
);
3704 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
3706 -- Check whether this is a component of the base type
3707 -- which is absent from a statically constrained subtype.
3708 -- This will raise constraint error at run-time, but is
3709 -- not a compile-time error. When the selector is illegal
3710 -- for base type as well fall through and generate a
3711 -- compilation error anyway.
3713 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
3714 while Present
(Comp
) loop
3715 if Chars
(Comp
) = Chars
(Sel
)
3716 and then Is_Visible_Component
(Comp
)
3718 Set_Entity_With_Style_Check
(Sel
, Comp
);
3719 Generate_Reference
(Comp
, Sel
);
3720 Set_Etype
(Sel
, Etype
(Comp
));
3721 Set_Etype
(N
, Etype
(Comp
));
3723 -- Emit appropriate message. Gigi will replace the
3724 -- node subsequently with the appropriate Raise.
3726 Apply_Compile_Time_Constraint_Error
3727 (N
, "component not present in }?",
3728 CE_Discriminant_Check_Failed
,
3729 Ent
=> Prefix_Type
, Rep
=> False);
3730 Set_Raises_Constraint_Error
(N
);
3734 Next_Component
(Comp
);
3739 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
3740 Error_Msg_NE
("no selector& for}", N
, Sel
);
3742 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
3745 Set_Entity
(Sel
, Any_Id
);
3746 Set_Etype
(Sel
, Any_Type
);
3748 end Analyze_Selected_Component
;
3750 ---------------------------
3751 -- Analyze_Short_Circuit --
3752 ---------------------------
3754 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
3755 L
: constant Node_Id
:= Left_Opnd
(N
);
3756 R
: constant Node_Id
:= Right_Opnd
(N
);
3761 Analyze_Expression
(L
);
3762 Analyze_Expression
(R
);
3763 Set_Etype
(N
, Any_Type
);
3765 if not Is_Overloaded
(L
) then
3766 if Root_Type
(Etype
(L
)) = Standard_Boolean
3767 and then Has_Compatible_Type
(R
, Etype
(L
))
3769 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
3773 Get_First_Interp
(L
, Ind
, It
);
3774 while Present
(It
.Typ
) loop
3775 if Root_Type
(It
.Typ
) = Standard_Boolean
3776 and then Has_Compatible_Type
(R
, It
.Typ
)
3778 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
3781 Get_Next_Interp
(Ind
, It
);
3785 -- Here we have failed to find an interpretation. Clearly we know that
3786 -- it is not the case that both operands can have an interpretation of
3787 -- Boolean, but this is by far the most likely intended interpretation.
3788 -- So we simply resolve both operands as Booleans, and at least one of
3789 -- these resolutions will generate an error message, and we do not need
3790 -- to give another error message on the short circuit operation itself.
3792 if Etype
(N
) = Any_Type
then
3793 Resolve
(L
, Standard_Boolean
);
3794 Resolve
(R
, Standard_Boolean
);
3795 Set_Etype
(N
, Standard_Boolean
);
3797 end Analyze_Short_Circuit
;
3803 procedure Analyze_Slice
(N
: Node_Id
) is
3804 P
: constant Node_Id
:= Prefix
(N
);
3805 D
: constant Node_Id
:= Discrete_Range
(N
);
3806 Array_Type
: Entity_Id
;
3808 procedure Analyze_Overloaded_Slice
;
3809 -- If the prefix is overloaded, select those interpretations that
3810 -- yield a one-dimensional array type.
3812 ------------------------------
3813 -- Analyze_Overloaded_Slice --
3814 ------------------------------
3816 procedure Analyze_Overloaded_Slice
is
3822 Set_Etype
(N
, Any_Type
);
3824 Get_First_Interp
(P
, I
, It
);
3825 while Present
(It
.Nam
) loop
3828 if Is_Access_Type
(Typ
) then
3829 Typ
:= Designated_Type
(Typ
);
3830 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3833 if Is_Array_Type
(Typ
)
3834 and then Number_Dimensions
(Typ
) = 1
3835 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
3837 Add_One_Interp
(N
, Typ
, Typ
);
3840 Get_Next_Interp
(I
, It
);
3843 if Etype
(N
) = Any_Type
then
3844 Error_Msg_N
("expect array type in prefix of slice", N
);
3846 end Analyze_Overloaded_Slice
;
3848 -- Start of processing for Analyze_Slice
3854 if Is_Overloaded
(P
) then
3855 Analyze_Overloaded_Slice
;
3858 Array_Type
:= Etype
(P
);
3859 Set_Etype
(N
, Any_Type
);
3861 if Is_Access_Type
(Array_Type
) then
3862 Array_Type
:= Designated_Type
(Array_Type
);
3863 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3866 if not Is_Array_Type
(Array_Type
) then
3867 Wrong_Type
(P
, Any_Array
);
3869 elsif Number_Dimensions
(Array_Type
) > 1 then
3871 ("type is not one-dimensional array in slice prefix", N
);
3874 Has_Compatible_Type
(D
, Etype
(First_Index
(Array_Type
)))
3876 Wrong_Type
(D
, Etype
(First_Index
(Array_Type
)));
3879 Set_Etype
(N
, Array_Type
);
3884 -----------------------------
3885 -- Analyze_Type_Conversion --
3886 -----------------------------
3888 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
3889 Expr
: constant Node_Id
:= Expression
(N
);
3893 -- Check if the expression is a function call for which we need to
3894 -- adjust a SCIL dispatching node.
3897 and then Nkind
(Expr
) = N_Function_Call
3899 Adjust_SCIL_Node
(N
, Expr
);
3902 -- If Conversion_OK is set, then the Etype is already set, and the
3903 -- only processing required is to analyze the expression. This is
3904 -- used to construct certain "illegal" conversions which are not
3905 -- allowed by Ada semantics, but can be handled OK by Gigi, see
3906 -- Sinfo for further details.
3908 if Conversion_OK
(N
) then
3913 -- Otherwise full type analysis is required, as well as some semantic
3914 -- checks to make sure the argument of the conversion is appropriate.
3916 Find_Type
(Subtype_Mark
(N
));
3917 T
:= Entity
(Subtype_Mark
(N
));
3919 Check_Fully_Declared
(T
, N
);
3920 Analyze_Expression
(Expr
);
3921 Validate_Remote_Type_Type_Conversion
(N
);
3923 -- Only remaining step is validity checks on the argument. These
3924 -- are skipped if the conversion does not come from the source.
3926 if not Comes_From_Source
(N
) then
3929 -- If there was an error in a generic unit, no need to replicate the
3930 -- error message. Conversely, constant-folding in the generic may
3931 -- transform the argument of a conversion into a string literal, which
3932 -- is legal. Therefore the following tests are not performed in an
3935 elsif In_Instance
then
3938 elsif Nkind
(Expr
) = N_Null
then
3939 Error_Msg_N
("argument of conversion cannot be null", N
);
3940 Error_Msg_N
("\use qualified expression instead", N
);
3941 Set_Etype
(N
, Any_Type
);
3943 elsif Nkind
(Expr
) = N_Aggregate
then
3944 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
3945 Error_Msg_N
("\use qualified expression instead", N
);
3947 elsif Nkind
(Expr
) = N_Allocator
then
3948 Error_Msg_N
("argument of conversion cannot be an allocator", N
);
3949 Error_Msg_N
("\use qualified expression instead", N
);
3951 elsif Nkind
(Expr
) = N_String_Literal
then
3952 Error_Msg_N
("argument of conversion cannot be string literal", N
);
3953 Error_Msg_N
("\use qualified expression instead", N
);
3955 elsif Nkind
(Expr
) = N_Character_Literal
then
3956 if Ada_Version
= Ada_83
then
3959 Error_Msg_N
("argument of conversion cannot be character literal",
3961 Error_Msg_N
("\use qualified expression instead", N
);
3964 elsif Nkind
(Expr
) = N_Attribute_Reference
3966 (Attribute_Name
(Expr
) = Name_Access
or else
3967 Attribute_Name
(Expr
) = Name_Unchecked_Access
or else
3968 Attribute_Name
(Expr
) = Name_Unrestricted_Access
)
3970 Error_Msg_N
("argument of conversion cannot be access", N
);
3971 Error_Msg_N
("\use qualified expression instead", N
);
3973 end Analyze_Type_Conversion
;
3975 ----------------------
3976 -- Analyze_Unary_Op --
3977 ----------------------
3979 procedure Analyze_Unary_Op
(N
: Node_Id
) is
3980 R
: constant Node_Id
:= Right_Opnd
(N
);
3981 Op_Id
: Entity_Id
:= Entity
(N
);
3984 Set_Etype
(N
, Any_Type
);
3985 Candidate_Type
:= Empty
;
3987 Analyze_Expression
(R
);
3989 if Present
(Op_Id
) then
3990 if Ekind
(Op_Id
) = E_Operator
then
3991 Find_Unary_Types
(R
, Op_Id
, N
);
3993 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
3997 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
3998 while Present
(Op_Id
) loop
3999 if Ekind
(Op_Id
) = E_Operator
then
4000 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
4001 Find_Unary_Types
(R
, Op_Id
, N
);
4004 elsif Is_Overloadable
(Op_Id
) then
4005 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
4008 Op_Id
:= Homonym
(Op_Id
);
4013 end Analyze_Unary_Op
;
4015 ----------------------------------
4016 -- Analyze_Unchecked_Expression --
4017 ----------------------------------
4019 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
4021 Analyze
(Expression
(N
), Suppress
=> All_Checks
);
4022 Set_Etype
(N
, Etype
(Expression
(N
)));
4023 Save_Interps
(Expression
(N
), N
);
4024 end Analyze_Unchecked_Expression
;
4026 ---------------------------------------
4027 -- Analyze_Unchecked_Type_Conversion --
4028 ---------------------------------------
4030 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
4032 Find_Type
(Subtype_Mark
(N
));
4033 Analyze_Expression
(Expression
(N
));
4034 Set_Etype
(N
, Entity
(Subtype_Mark
(N
)));
4035 end Analyze_Unchecked_Type_Conversion
;
4037 ------------------------------------
4038 -- Analyze_User_Defined_Binary_Op --
4039 ------------------------------------
4041 procedure Analyze_User_Defined_Binary_Op
4046 -- Only do analysis if the operator Comes_From_Source, since otherwise
4047 -- the operator was generated by the expander, and all such operators
4048 -- always refer to the operators in package Standard.
4050 if Comes_From_Source
(N
) then
4052 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
4053 F2
: constant Entity_Id
:= Next_Formal
(F1
);
4056 -- Verify that Op_Id is a visible binary function. Note that since
4057 -- we know Op_Id is overloaded, potentially use visible means use
4058 -- visible for sure (RM 9.4(11)).
4060 if Ekind
(Op_Id
) = E_Function
4061 and then Present
(F2
)
4062 and then (Is_Immediately_Visible
(Op_Id
)
4063 or else Is_Potentially_Use_Visible
(Op_Id
))
4064 and then Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
4065 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
4067 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4069 -- If the left operand is overloaded, indicate that the
4070 -- current type is a viable candidate. This is redundant
4071 -- in most cases, but for equality and comparison operators
4072 -- where the context does not impose a type on the operands,
4073 -- setting the proper type is necessary to avoid subsequent
4074 -- ambiguities during resolution, when both user-defined and
4075 -- predefined operators may be candidates.
4077 if Is_Overloaded
(Left_Opnd
(N
)) then
4078 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
4081 if Debug_Flag_E
then
4082 Write_Str
("user defined operator ");
4083 Write_Name
(Chars
(Op_Id
));
4084 Write_Str
(" on node ");
4085 Write_Int
(Int
(N
));
4091 end Analyze_User_Defined_Binary_Op
;
4093 -----------------------------------
4094 -- Analyze_User_Defined_Unary_Op --
4095 -----------------------------------
4097 procedure Analyze_User_Defined_Unary_Op
4102 -- Only do analysis if the operator Comes_From_Source, since otherwise
4103 -- the operator was generated by the expander, and all such operators
4104 -- always refer to the operators in package Standard.
4106 if Comes_From_Source
(N
) then
4108 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
4111 -- Verify that Op_Id is a visible unary function. Note that since
4112 -- we know Op_Id is overloaded, potentially use visible means use
4113 -- visible for sure (RM 9.4(11)).
4115 if Ekind
(Op_Id
) = E_Function
4116 and then No
(Next_Formal
(F
))
4117 and then (Is_Immediately_Visible
(Op_Id
)
4118 or else Is_Potentially_Use_Visible
(Op_Id
))
4119 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
4121 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4125 end Analyze_User_Defined_Unary_Op
;
4127 ---------------------------
4128 -- Check_Arithmetic_Pair --
4129 ---------------------------
4131 procedure Check_Arithmetic_Pair
4132 (T1
, T2
: Entity_Id
;
4136 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
4138 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
4139 -- Check whether the fixed-point type Typ has a user-defined operator
4140 -- (multiplication or division) that should hide the corresponding
4141 -- predefined operator. Used to implement Ada 2005 AI-264, to make
4142 -- such operators more visible and therefore useful.
4144 -- If the name of the operation is an expanded name with prefix
4145 -- Standard, the predefined universal fixed operator is available,
4146 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
4148 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
4149 -- Get specific type (i.e. non-universal type if there is one)
4155 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
4156 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
4162 -- If the universal_fixed operation is given explicitly the rule
4163 -- concerning primitive operations of the type do not apply.
4165 if Nkind
(N
) = N_Function_Call
4166 and then Nkind
(Name
(N
)) = N_Expanded_Name
4167 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
4172 -- The operation is treated as primitive if it is declared in the
4173 -- same scope as the type, and therefore on the same entity chain.
4175 Ent
:= Next_Entity
(Typ
);
4176 while Present
(Ent
) loop
4177 if Chars
(Ent
) = Chars
(Op
) then
4178 F1
:= First_Formal
(Ent
);
4179 F2
:= Next_Formal
(F1
);
4181 -- The operation counts as primitive if either operand or
4182 -- result are of the given base type, and both operands are
4183 -- fixed point types.
4185 if (Base_Type
(Etype
(F1
)) = Bas
4186 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4189 (Base_Type
(Etype
(F2
)) = Bas
4190 and then Is_Fixed_Point_Type
(Etype
(F1
)))
4193 (Base_Type
(Etype
(Ent
)) = Bas
4194 and then Is_Fixed_Point_Type
(Etype
(F1
))
4195 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4211 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
4213 if T1
= Universal_Integer
or else T1
= Universal_Real
then
4214 return Base_Type
(T2
);
4216 return Base_Type
(T1
);
4220 -- Start of processing for Check_Arithmetic_Pair
4223 if Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
4225 if Is_Numeric_Type
(T1
)
4226 and then Is_Numeric_Type
(T2
)
4227 and then (Covers
(T1
=> T1
, T2
=> T2
)
4229 Covers
(T1
=> T2
, T2
=> T1
))
4231 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4234 elsif Op_Name
= Name_Op_Multiply
or else Op_Name
= Name_Op_Divide
then
4236 if Is_Fixed_Point_Type
(T1
)
4237 and then (Is_Fixed_Point_Type
(T2
)
4238 or else T2
= Universal_Real
)
4240 -- If Treat_Fixed_As_Integer is set then the Etype is already set
4241 -- and no further processing is required (this is the case of an
4242 -- operator constructed by Exp_Fixd for a fixed point operation)
4243 -- Otherwise add one interpretation with universal fixed result
4244 -- If the operator is given in functional notation, it comes
4245 -- from source and Fixed_As_Integer cannot apply.
4247 if (Nkind
(N
) not in N_Op
4248 or else not Treat_Fixed_As_Integer
(N
))
4250 (not Has_Fixed_Op
(T1
, Op_Id
)
4251 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4253 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4256 elsif Is_Fixed_Point_Type
(T2
)
4257 and then (Nkind
(N
) not in N_Op
4258 or else not Treat_Fixed_As_Integer
(N
))
4259 and then T1
= Universal_Real
4261 (not Has_Fixed_Op
(T1
, Op_Id
)
4262 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4264 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4266 elsif Is_Numeric_Type
(T1
)
4267 and then Is_Numeric_Type
(T2
)
4268 and then (Covers
(T1
=> T1
, T2
=> T2
)
4270 Covers
(T1
=> T2
, T2
=> T1
))
4272 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4274 elsif Is_Fixed_Point_Type
(T1
)
4275 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4276 or else T2
= Universal_Integer
)
4278 Add_One_Interp
(N
, Op_Id
, T1
);
4280 elsif T2
= Universal_Real
4281 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
4282 and then Op_Name
= Name_Op_Multiply
4284 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
4286 elsif T1
= Universal_Real
4287 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4289 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
4291 elsif Is_Fixed_Point_Type
(T2
)
4292 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
4293 or else T1
= Universal_Integer
)
4294 and then Op_Name
= Name_Op_Multiply
4296 Add_One_Interp
(N
, Op_Id
, T2
);
4298 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
4299 Add_One_Interp
(N
, Op_Id
, T1
);
4301 elsif T2
= Universal_Real
4302 and then T1
= Universal_Integer
4303 and then Op_Name
= Name_Op_Multiply
4305 Add_One_Interp
(N
, Op_Id
, T2
);
4308 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
4310 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
4311 -- set does not require any special processing, since the Etype is
4312 -- already set (case of operation constructed by Exp_Fixed).
4314 if Is_Integer_Type
(T1
)
4315 and then (Covers
(T1
=> T1
, T2
=> T2
)
4317 Covers
(T1
=> T2
, T2
=> T1
))
4319 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4322 elsif Op_Name
= Name_Op_Expon
then
4323 if Is_Numeric_Type
(T1
)
4324 and then not Is_Fixed_Point_Type
(T1
)
4325 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4326 or else T2
= Universal_Integer
)
4328 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
4331 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
4333 -- If not one of the predefined operators, the node may be one
4334 -- of the intrinsic functions. Its kind is always specific, and
4335 -- we can use it directly, rather than the name of the operation.
4337 if Is_Integer_Type
(T1
)
4338 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4339 or else T2
= Universal_Integer
)
4341 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
4344 end Check_Arithmetic_Pair
;
4346 -------------------------------
4347 -- Check_Misspelled_Selector --
4348 -------------------------------
4350 procedure Check_Misspelled_Selector
4351 (Prefix
: Entity_Id
;
4354 Max_Suggestions
: constant := 2;
4355 Nr_Of_Suggestions
: Natural := 0;
4357 Suggestion_1
: Entity_Id
:= Empty
;
4358 Suggestion_2
: Entity_Id
:= Empty
;
4363 -- All the components of the prefix of selector Sel are matched
4364 -- against Sel and a count is maintained of possible misspellings.
4365 -- When at the end of the analysis there are one or two (not more!)
4366 -- possible misspellings, these misspellings will be suggested as
4367 -- possible correction.
4369 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
4371 -- Concurrent types should be handled as well ???
4376 Comp
:= First_Entity
(Prefix
);
4377 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
4378 if Is_Visible_Component
(Comp
) then
4379 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
4380 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
4382 case Nr_Of_Suggestions
is
4383 when 1 => Suggestion_1
:= Comp
;
4384 when 2 => Suggestion_2
:= Comp
;
4385 when others => exit;
4390 Comp
:= Next_Entity
(Comp
);
4393 -- Report at most two suggestions
4395 if Nr_Of_Suggestions
= 1 then
4396 Error_Msg_NE
-- CODEFIX
4397 ("\possible misspelling of&", Sel
, Suggestion_1
);
4399 elsif Nr_Of_Suggestions
= 2 then
4400 Error_Msg_Node_2
:= Suggestion_2
;
4401 Error_Msg_NE
-- CODEFIX
4402 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
4404 end Check_Misspelled_Selector
;
4406 ----------------------
4407 -- Defined_In_Scope --
4408 ----------------------
4410 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean
4412 S1
: constant Entity_Id
:= Scope
(Base_Type
(T
));
4415 or else (S1
= System_Aux_Id
and then S
= Scope
(S1
));
4416 end Defined_In_Scope
;
4422 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
4428 Void_Interp_Seen
: Boolean := False;
4431 pragma Warnings
(Off
, Boolean);
4434 if Ada_Version
>= Ada_05
then
4435 Actual
:= First_Actual
(N
);
4436 while Present
(Actual
) loop
4438 -- Ada 2005 (AI-50217): Post an error in case of premature
4439 -- usage of an entity from the limited view.
4441 if not Analyzed
(Etype
(Actual
))
4442 and then From_With_Type
(Etype
(Actual
))
4444 Error_Msg_Qual_Level
:= 1;
4446 ("missing with_clause for scope of imported type&",
4447 Actual
, Etype
(Actual
));
4448 Error_Msg_Qual_Level
:= 0;
4451 Next_Actual
(Actual
);
4455 -- Analyze each candidate call again, with full error reporting
4459 ("no candidate interpretations match the actuals:!", Nam
);
4460 Err_Mode
:= All_Errors_Mode
;
4461 All_Errors_Mode
:= True;
4463 -- If this is a call to an operation of a concurrent type,
4464 -- the failed interpretations have been removed from the
4465 -- name. Recover them to provide full diagnostics.
4467 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
4468 Set_Entity
(Nam
, Empty
);
4469 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
4470 Set_Is_Overloaded
(New_Nam
, False);
4471 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
4472 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
4473 Analyze_Selected_Component
(New_Nam
);
4474 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
4476 Get_First_Interp
(Nam
, X
, It
);
4479 while Present
(It
.Nam
) loop
4480 if Etype
(It
.Nam
) = Standard_Void_Type
then
4481 Void_Interp_Seen
:= True;
4484 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
4485 Get_Next_Interp
(X
, It
);
4488 if Nkind
(N
) = N_Function_Call
then
4489 Get_First_Interp
(Nam
, X
, It
);
4490 while Present
(It
.Nam
) loop
4491 if Ekind
(It
.Nam
) = E_Function
4492 or else Ekind
(It
.Nam
) = E_Operator
4496 Get_Next_Interp
(X
, It
);
4500 -- If all interpretations are procedures, this deserves a
4501 -- more precise message. Ditto if this appears as the prefix
4502 -- of a selected component, which may be a lexical error.
4505 ("\context requires function call, found procedure name", Nam
);
4507 if Nkind
(Parent
(N
)) = N_Selected_Component
4508 and then N
= Prefix
(Parent
(N
))
4510 Error_Msg_N
-- CODEFIX
4511 ("\period should probably be semicolon", Parent
(N
));
4514 elsif Nkind
(N
) = N_Procedure_Call_Statement
4515 and then not Void_Interp_Seen
4518 "\function name found in procedure call", Nam
);
4521 All_Errors_Mode
:= Err_Mode
;
4524 ---------------------------
4525 -- Find_Arithmetic_Types --
4526 ---------------------------
4528 procedure Find_Arithmetic_Types
4533 Index1
: Interp_Index
;
4534 Index2
: Interp_Index
;
4538 procedure Check_Right_Argument
(T
: Entity_Id
);
4539 -- Check right operand of operator
4541 --------------------------
4542 -- Check_Right_Argument --
4543 --------------------------
4545 procedure Check_Right_Argument
(T
: Entity_Id
) is
4547 if not Is_Overloaded
(R
) then
4548 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
4550 Get_First_Interp
(R
, Index2
, It2
);
4551 while Present
(It2
.Typ
) loop
4552 Check_Arithmetic_Pair
(T
, It2
.Typ
, Op_Id
, N
);
4553 Get_Next_Interp
(Index2
, It2
);
4556 end Check_Right_Argument
;
4558 -- Start of processing for Find_Arithmetic_Types
4561 if not Is_Overloaded
(L
) then
4562 Check_Right_Argument
(Etype
(L
));
4565 Get_First_Interp
(L
, Index1
, It1
);
4566 while Present
(It1
.Typ
) loop
4567 Check_Right_Argument
(It1
.Typ
);
4568 Get_Next_Interp
(Index1
, It1
);
4572 end Find_Arithmetic_Types
;
4574 ------------------------
4575 -- Find_Boolean_Types --
4576 ------------------------
4578 procedure Find_Boolean_Types
4583 Index
: Interp_Index
;
4586 procedure Check_Numeric_Argument
(T
: Entity_Id
);
4587 -- Special case for logical operations one of whose operands is an
4588 -- integer literal. If both are literal the result is any modular type.
4590 ----------------------------
4591 -- Check_Numeric_Argument --
4592 ----------------------------
4594 procedure Check_Numeric_Argument
(T
: Entity_Id
) is
4596 if T
= Universal_Integer
then
4597 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
4599 elsif Is_Modular_Integer_Type
(T
) then
4600 Add_One_Interp
(N
, Op_Id
, T
);
4602 end Check_Numeric_Argument
;
4604 -- Start of processing for Find_Boolean_Types
4607 if not Is_Overloaded
(L
) then
4608 if Etype
(L
) = Universal_Integer
4609 or else Etype
(L
) = Any_Modular
4611 if not Is_Overloaded
(R
) then
4612 Check_Numeric_Argument
(Etype
(R
));
4615 Get_First_Interp
(R
, Index
, It
);
4616 while Present
(It
.Typ
) loop
4617 Check_Numeric_Argument
(It
.Typ
);
4618 Get_Next_Interp
(Index
, It
);
4622 -- If operands are aggregates, we must assume that they may be
4623 -- boolean arrays, and leave disambiguation for the second pass.
4624 -- If only one is an aggregate, verify that the other one has an
4625 -- interpretation as a boolean array
4627 elsif Nkind
(L
) = N_Aggregate
then
4628 if Nkind
(R
) = N_Aggregate
then
4629 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
4631 elsif not Is_Overloaded
(R
) then
4632 if Valid_Boolean_Arg
(Etype
(R
)) then
4633 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
4637 Get_First_Interp
(R
, Index
, It
);
4638 while Present
(It
.Typ
) loop
4639 if Valid_Boolean_Arg
(It
.Typ
) then
4640 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
4643 Get_Next_Interp
(Index
, It
);
4647 elsif Valid_Boolean_Arg
(Etype
(L
))
4648 and then Has_Compatible_Type
(R
, Etype
(L
))
4650 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
4654 Get_First_Interp
(L
, Index
, It
);
4655 while Present
(It
.Typ
) loop
4656 if Valid_Boolean_Arg
(It
.Typ
)
4657 and then Has_Compatible_Type
(R
, It
.Typ
)
4659 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
4662 Get_Next_Interp
(Index
, It
);
4665 end Find_Boolean_Types
;
4667 ---------------------------
4668 -- Find_Comparison_Types --
4669 ---------------------------
4671 procedure Find_Comparison_Types
4676 Index
: Interp_Index
;
4678 Found
: Boolean := False;
4681 Scop
: Entity_Id
:= Empty
;
4683 procedure Try_One_Interp
(T1
: Entity_Id
);
4684 -- Routine to try one proposed interpretation. Note that the context
4685 -- of the operator plays no role in resolving the arguments, so that
4686 -- if there is more than one interpretation of the operands that is
4687 -- compatible with comparison, the operation is ambiguous.
4689 --------------------
4690 -- Try_One_Interp --
4691 --------------------
4693 procedure Try_One_Interp
(T1
: Entity_Id
) is
4696 -- If the operator is an expanded name, then the type of the operand
4697 -- must be defined in the corresponding scope. If the type is
4698 -- universal, the context will impose the correct type.
4701 and then not Defined_In_Scope
(T1
, Scop
)
4702 and then T1
/= Universal_Integer
4703 and then T1
/= Universal_Real
4704 and then T1
/= Any_String
4705 and then T1
/= Any_Composite
4710 if Valid_Comparison_Arg
(T1
)
4711 and then Has_Compatible_Type
(R
, T1
)
4714 and then Base_Type
(T1
) /= Base_Type
(T_F
)
4716 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
4718 if It
= No_Interp
then
4719 Ambiguous_Operands
(N
);
4720 Set_Etype
(L
, Any_Type
);
4734 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
4739 -- Start of processing for Find_Comparison_Types
4742 -- If left operand is aggregate, the right operand has to
4743 -- provide a usable type for it.
4745 if Nkind
(L
) = N_Aggregate
4746 and then Nkind
(R
) /= N_Aggregate
4748 Find_Comparison_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
4752 if Nkind
(N
) = N_Function_Call
4753 and then Nkind
(Name
(N
)) = N_Expanded_Name
4755 Scop
:= Entity
(Prefix
(Name
(N
)));
4757 -- The prefix may be a package renaming, and the subsequent test
4758 -- requires the original package.
4760 if Ekind
(Scop
) = E_Package
4761 and then Present
(Renamed_Entity
(Scop
))
4763 Scop
:= Renamed_Entity
(Scop
);
4764 Set_Entity
(Prefix
(Name
(N
)), Scop
);
4768 if not Is_Overloaded
(L
) then
4769 Try_One_Interp
(Etype
(L
));
4772 Get_First_Interp
(L
, Index
, It
);
4773 while Present
(It
.Typ
) loop
4774 Try_One_Interp
(It
.Typ
);
4775 Get_Next_Interp
(Index
, It
);
4778 end Find_Comparison_Types
;
4780 ----------------------------------------
4781 -- Find_Non_Universal_Interpretations --
4782 ----------------------------------------
4784 procedure Find_Non_Universal_Interpretations
4790 Index
: Interp_Index
;
4794 if T1
= Universal_Integer
4795 or else T1
= Universal_Real
4797 if not Is_Overloaded
(R
) then
4799 (N
, Op_Id
, Standard_Boolean
, Base_Type
(Etype
(R
)));
4801 Get_First_Interp
(R
, Index
, It
);
4802 while Present
(It
.Typ
) loop
4803 if Covers
(It
.Typ
, T1
) then
4805 (N
, Op_Id
, Standard_Boolean
, Base_Type
(It
.Typ
));
4808 Get_Next_Interp
(Index
, It
);
4812 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(T1
));
4814 end Find_Non_Universal_Interpretations
;
4816 ------------------------------
4817 -- Find_Concatenation_Types --
4818 ------------------------------
4820 procedure Find_Concatenation_Types
4825 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
4828 if Is_Array_Type
(Op_Type
)
4829 and then not Is_Limited_Type
(Op_Type
)
4831 and then (Has_Compatible_Type
(L
, Op_Type
)
4833 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
4835 and then (Has_Compatible_Type
(R
, Op_Type
)
4837 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
4839 Add_One_Interp
(N
, Op_Id
, Op_Type
);
4841 end Find_Concatenation_Types
;
4843 -------------------------
4844 -- Find_Equality_Types --
4845 -------------------------
4847 procedure Find_Equality_Types
4852 Index
: Interp_Index
;
4854 Found
: Boolean := False;
4857 Scop
: Entity_Id
:= Empty
;
4859 procedure Try_One_Interp
(T1
: Entity_Id
);
4860 -- The context of the equality operator plays no role in resolving the
4861 -- arguments, so that if there is more than one interpretation of the
4862 -- operands that is compatible with equality, the construct is ambiguous
4863 -- and an error can be emitted now, after trying to disambiguate, i.e.
4864 -- applying preference rules.
4866 --------------------
4867 -- Try_One_Interp --
4868 --------------------
4870 procedure Try_One_Interp
(T1
: Entity_Id
) is
4871 Bas
: constant Entity_Id
:= Base_Type
(T1
);
4874 -- If the operator is an expanded name, then the type of the operand
4875 -- must be defined in the corresponding scope. If the type is
4876 -- universal, the context will impose the correct type. An anonymous
4877 -- type for a 'Access reference is also universal in this sense, as
4878 -- the actual type is obtained from context.
4879 -- In Ada 2005, the equality operator for anonymous access types
4880 -- is declared in Standard, and preference rules apply to it.
4882 if Present
(Scop
) then
4883 if Defined_In_Scope
(T1
, Scop
)
4884 or else T1
= Universal_Integer
4885 or else T1
= Universal_Real
4886 or else T1
= Any_Access
4887 or else T1
= Any_String
4888 or else T1
= Any_Composite
4889 or else (Ekind
(T1
) = E_Access_Subprogram_Type
4890 and then not Comes_From_Source
(T1
))
4894 elsif Ekind
(T1
) = E_Anonymous_Access_Type
4895 and then Scop
= Standard_Standard
4900 -- The scope does not contain an operator for the type
4905 -- If we have infix notation, the operator must be usable.
4906 -- Within an instance, if the type is already established we
4907 -- know it is correct.
4908 -- In Ada 2005, the equality on anonymous access types is declared
4909 -- in Standard, and is always visible.
4911 elsif In_Open_Scopes
(Scope
(Bas
))
4912 or else Is_Potentially_Use_Visible
(Bas
)
4913 or else In_Use
(Bas
)
4914 or else (In_Use
(Scope
(Bas
))
4915 and then not Is_Hidden
(Bas
))
4916 or else (In_Instance
4917 and then First_Subtype
(T1
) = First_Subtype
(Etype
(R
)))
4918 or else Ekind
(T1
) = E_Anonymous_Access_Type
4923 -- Save candidate type for subsquent error message, if any
4925 if not Is_Limited_Type
(T1
) then
4926 Candidate_Type
:= T1
;
4932 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
4933 -- Do not allow anonymous access types in equality operators.
4935 if Ada_Version
< Ada_05
4936 and then Ekind
(T1
) = E_Anonymous_Access_Type
4941 if T1
/= Standard_Void_Type
4942 and then not Is_Limited_Type
(T1
)
4943 and then not Is_Limited_Composite
(T1
)
4944 and then Has_Compatible_Type
(R
, T1
)
4947 and then Base_Type
(T1
) /= Base_Type
(T_F
)
4949 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
4951 if It
= No_Interp
then
4952 Ambiguous_Operands
(N
);
4953 Set_Etype
(L
, Any_Type
);
4966 if not Analyzed
(L
) then
4970 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
4972 -- Case of operator was not visible, Etype still set to Any_Type
4974 if Etype
(N
) = Any_Type
then
4978 elsif Scop
= Standard_Standard
4979 and then Ekind
(T1
) = E_Anonymous_Access_Type
4985 -- Start of processing for Find_Equality_Types
4988 -- If left operand is aggregate, the right operand has to
4989 -- provide a usable type for it.
4991 if Nkind
(L
) = N_Aggregate
4992 and then Nkind
(R
) /= N_Aggregate
4994 Find_Equality_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
4998 if Nkind
(N
) = N_Function_Call
4999 and then Nkind
(Name
(N
)) = N_Expanded_Name
5001 Scop
:= Entity
(Prefix
(Name
(N
)));
5003 -- The prefix may be a package renaming, and the subsequent test
5004 -- requires the original package.
5006 if Ekind
(Scop
) = E_Package
5007 and then Present
(Renamed_Entity
(Scop
))
5009 Scop
:= Renamed_Entity
(Scop
);
5010 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5014 if not Is_Overloaded
(L
) then
5015 Try_One_Interp
(Etype
(L
));
5018 Get_First_Interp
(L
, Index
, It
);
5019 while Present
(It
.Typ
) loop
5020 Try_One_Interp
(It
.Typ
);
5021 Get_Next_Interp
(Index
, It
);
5024 end Find_Equality_Types
;
5026 -------------------------
5027 -- Find_Negation_Types --
5028 -------------------------
5030 procedure Find_Negation_Types
5035 Index
: Interp_Index
;
5039 if not Is_Overloaded
(R
) then
5040 if Etype
(R
) = Universal_Integer
then
5041 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5042 elsif Valid_Boolean_Arg
(Etype
(R
)) then
5043 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5047 Get_First_Interp
(R
, Index
, It
);
5048 while Present
(It
.Typ
) loop
5049 if Valid_Boolean_Arg
(It
.Typ
) then
5050 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5053 Get_Next_Interp
(Index
, It
);
5056 end Find_Negation_Types
;
5058 ------------------------------
5059 -- Find_Primitive_Operation --
5060 ------------------------------
5062 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
5063 Obj
: constant Node_Id
:= Prefix
(N
);
5064 Op
: constant Node_Id
:= Selector_Name
(N
);
5071 Set_Etype
(Op
, Any_Type
);
5073 if Is_Access_Type
(Etype
(Obj
)) then
5074 Typ
:= Designated_Type
(Etype
(Obj
));
5079 if Is_Class_Wide_Type
(Typ
) then
5080 Typ
:= Root_Type
(Typ
);
5083 Prims
:= Primitive_Operations
(Typ
);
5085 Prim
:= First_Elmt
(Prims
);
5086 while Present
(Prim
) loop
5087 if Chars
(Node
(Prim
)) = Chars
(Op
) then
5088 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
5089 Set_Etype
(N
, Etype
(Node
(Prim
)));
5095 -- Now look for class-wide operations of the type or any of its
5096 -- ancestors by iterating over the homonyms of the selector.
5099 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
5103 Hom
:= Current_Entity
(Op
);
5104 while Present
(Hom
) loop
5105 if (Ekind
(Hom
) = E_Procedure
5107 Ekind
(Hom
) = E_Function
)
5108 and then Scope
(Hom
) = Scope
(Typ
)
5109 and then Present
(First_Formal
(Hom
))
5111 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
5113 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
5115 Ekind
(Etype
(First_Formal
(Hom
))) =
5116 E_Anonymous_Access_Type
5119 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
5122 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
5123 Set_Etype
(N
, Etype
(Hom
));
5126 Hom
:= Homonym
(Hom
);
5130 return Etype
(Op
) /= Any_Type
;
5131 end Find_Primitive_Operation
;
5133 ----------------------
5134 -- Find_Unary_Types --
5135 ----------------------
5137 procedure Find_Unary_Types
5142 Index
: Interp_Index
;
5146 if not Is_Overloaded
(R
) then
5147 if Is_Numeric_Type
(Etype
(R
)) then
5148 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
5152 Get_First_Interp
(R
, Index
, It
);
5153 while Present
(It
.Typ
) loop
5154 if Is_Numeric_Type
(It
.Typ
) then
5155 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
5158 Get_Next_Interp
(Index
, It
);
5161 end Find_Unary_Types
;
5167 function Junk_Operand
(N
: Node_Id
) return Boolean is
5171 if Error_Posted
(N
) then
5175 -- Get entity to be tested
5177 if Is_Entity_Name
(N
)
5178 and then Present
(Entity
(N
))
5182 -- An odd case, a procedure name gets converted to a very peculiar
5183 -- function call, and here is where we detect this happening.
5185 elsif Nkind
(N
) = N_Function_Call
5186 and then Is_Entity_Name
(Name
(N
))
5187 and then Present
(Entity
(Name
(N
)))
5191 -- Another odd case, there are at least some cases of selected
5192 -- components where the selected component is not marked as having
5193 -- an entity, even though the selector does have an entity
5195 elsif Nkind
(N
) = N_Selected_Component
5196 and then Present
(Entity
(Selector_Name
(N
)))
5198 Enode
:= Selector_Name
(N
);
5204 -- Now test the entity we got to see if it is a bad case
5206 case Ekind
(Entity
(Enode
)) is
5210 ("package name cannot be used as operand", Enode
);
5212 when Generic_Unit_Kind
=>
5214 ("generic unit name cannot be used as operand", Enode
);
5218 ("subtype name cannot be used as operand", Enode
);
5222 ("entry name cannot be used as operand", Enode
);
5226 ("procedure name cannot be used as operand", Enode
);
5230 ("exception name cannot be used as operand", Enode
);
5232 when E_Block | E_Label | E_Loop
=>
5234 ("label name cannot be used as operand", Enode
);
5244 --------------------
5245 -- Operator_Check --
5246 --------------------
5248 procedure Operator_Check
(N
: Node_Id
) is
5250 Remove_Abstract_Operations
(N
);
5252 -- Test for case of no interpretation found for operator
5254 if Etype
(N
) = Any_Type
then
5258 Op_Id
: Entity_Id
:= Empty
;
5261 R
:= Right_Opnd
(N
);
5263 if Nkind
(N
) in N_Binary_Op
then
5269 -- If either operand has no type, then don't complain further,
5270 -- since this simply means that we have a propagated error.
5273 or else Etype
(R
) = Any_Type
5274 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
5278 -- We explicitly check for the case of concatenation of component
5279 -- with component to avoid reporting spurious matching array types
5280 -- that might happen to be lurking in distant packages (such as
5281 -- run-time packages). This also prevents inconsistencies in the
5282 -- messages for certain ACVC B tests, which can vary depending on
5283 -- types declared in run-time interfaces. Another improvement when
5284 -- aggregates are present is to look for a well-typed operand.
5286 elsif Present
(Candidate_Type
)
5287 and then (Nkind
(N
) /= N_Op_Concat
5288 or else Is_Array_Type
(Etype
(L
))
5289 or else Is_Array_Type
(Etype
(R
)))
5292 if Nkind
(N
) = N_Op_Concat
then
5293 if Etype
(L
) /= Any_Composite
5294 and then Is_Array_Type
(Etype
(L
))
5296 Candidate_Type
:= Etype
(L
);
5298 elsif Etype
(R
) /= Any_Composite
5299 and then Is_Array_Type
(Etype
(R
))
5301 Candidate_Type
:= Etype
(R
);
5306 ("operator for} is not directly visible!",
5307 N
, First_Subtype
(Candidate_Type
));
5308 Error_Msg_N
("use clause would make operation legal!", N
);
5311 -- If either operand is a junk operand (e.g. package name), then
5312 -- post appropriate error messages, but do not complain further.
5314 -- Note that the use of OR in this test instead of OR ELSE is
5315 -- quite deliberate, we may as well check both operands in the
5316 -- binary operator case.
5318 elsif Junk_Operand
(R
)
5319 or (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
5323 -- If we have a logical operator, one of whose operands is
5324 -- Boolean, then we know that the other operand cannot resolve to
5325 -- Boolean (since we got no interpretations), but in that case we
5326 -- pretty much know that the other operand should be Boolean, so
5327 -- resolve it that way (generating an error)
5329 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
) then
5330 if Etype
(L
) = Standard_Boolean
then
5331 Resolve
(R
, Standard_Boolean
);
5333 elsif Etype
(R
) = Standard_Boolean
then
5334 Resolve
(L
, Standard_Boolean
);
5338 -- For an arithmetic operator or comparison operator, if one
5339 -- of the operands is numeric, then we know the other operand
5340 -- is not the same numeric type. If it is a non-numeric type,
5341 -- then probably it is intended to match the other operand.
5343 elsif Nkind_In
(N
, N_Op_Add
,
5349 Nkind_In
(N
, N_Op_Lt
,
5355 if Is_Numeric_Type
(Etype
(L
))
5356 and then not Is_Numeric_Type
(Etype
(R
))
5358 Resolve
(R
, Etype
(L
));
5361 elsif Is_Numeric_Type
(Etype
(R
))
5362 and then not Is_Numeric_Type
(Etype
(L
))
5364 Resolve
(L
, Etype
(R
));
5368 -- Comparisons on A'Access are common enough to deserve a
5371 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
5372 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
5373 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
5376 ("two access attributes cannot be compared directly", N
);
5378 ("\use qualified expression for one of the operands",
5382 -- Another one for C programmers
5384 elsif Nkind
(N
) = N_Op_Concat
5385 and then Valid_Boolean_Arg
(Etype
(L
))
5386 and then Valid_Boolean_Arg
(Etype
(R
))
5388 Error_Msg_N
("invalid operands for concatenation", N
);
5389 Error_Msg_N
-- CODEFIX
5390 ("\maybe AND was meant", N
);
5393 -- A special case for comparison of access parameter with null
5395 elsif Nkind
(N
) = N_Op_Eq
5396 and then Is_Entity_Name
(L
)
5397 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
5398 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
5400 and then Nkind
(R
) = N_Null
5402 Error_Msg_N
("access parameter is not allowed to be null", L
);
5403 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
5406 -- Another special case for exponentiation, where the right
5407 -- operand must be Natural, independently of the base.
5409 elsif Nkind
(N
) = N_Op_Expon
5410 and then Is_Numeric_Type
(Etype
(L
))
5411 and then not Is_Overloaded
(R
)
5413 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
5414 and then Base_Type
(Etype
(R
)) /= Universal_Integer
5417 ("exponent must be of type Natural, found}", R
, Etype
(R
));
5421 -- If we fall through then just give general message. Note that in
5422 -- the following messages, if the operand is overloaded we choose
5423 -- an arbitrary type to complain about, but that is probably more
5424 -- useful than not giving a type at all.
5426 if Nkind
(N
) in N_Unary_Op
then
5427 Error_Msg_Node_2
:= Etype
(R
);
5428 Error_Msg_N
("operator& not defined for}", N
);
5432 if Nkind
(N
) in N_Binary_Op
then
5433 if not Is_Overloaded
(L
)
5434 and then not Is_Overloaded
(R
)
5435 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
5437 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
5438 Error_Msg_N
("there is no applicable operator& for}", N
);
5441 -- Another attempt to find a fix: one of the candidate
5442 -- interpretations may not be use-visible. This has
5443 -- already been checked for predefined operators, so
5444 -- we examine only user-defined functions.
5446 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
5448 while Present
(Op_Id
) loop
5449 if Ekind
(Op_Id
) /= E_Operator
5450 and then Is_Overloadable
(Op_Id
)
5452 if not Is_Immediately_Visible
(Op_Id
)
5453 and then not In_Use
(Scope
(Op_Id
))
5454 and then not Is_Abstract_Subprogram
(Op_Id
)
5455 and then not Is_Hidden
(Op_Id
)
5456 and then Ekind
(Scope
(Op_Id
)) = E_Package
5459 (L
, Etype
(First_Formal
(Op_Id
)))
5461 (Next_Formal
(First_Formal
(Op_Id
)))
5465 Etype
(Next_Formal
(First_Formal
(Op_Id
))))
5468 ("No legal interpretation for operator&", N
);
5470 ("\use clause on& would make operation legal",
5476 Op_Id
:= Homonym
(Op_Id
);
5480 Error_Msg_N
("invalid operand types for operator&", N
);
5482 if Nkind
(N
) /= N_Op_Concat
then
5483 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
5484 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
5494 -----------------------------------------
5495 -- Process_Implicit_Dereference_Prefix --
5496 -----------------------------------------
5498 function Process_Implicit_Dereference_Prefix
5500 P
: Entity_Id
) return Entity_Id
5503 Typ
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
5507 and then (Operating_Mode
= Check_Semantics
or else not Expander_Active
)
5509 -- We create a dummy reference to E to ensure that the reference
5510 -- is not considered as part of an assignment (an implicit
5511 -- dereference can never assign to its prefix). The Comes_From_Source
5512 -- attribute needs to be propagated for accurate warnings.
5514 Ref
:= New_Reference_To
(E
, Sloc
(P
));
5515 Set_Comes_From_Source
(Ref
, Comes_From_Source
(P
));
5516 Generate_Reference
(E
, Ref
);
5519 -- An implicit dereference is a legal occurrence of an
5520 -- incomplete type imported through a limited_with clause,
5521 -- if the full view is visible.
5523 if From_With_Type
(Typ
)
5524 and then not From_With_Type
(Scope
(Typ
))
5526 (Is_Immediately_Visible
(Scope
(Typ
))
5528 (Is_Child_Unit
(Scope
(Typ
))
5529 and then Is_Visible_Child_Unit
(Scope
(Typ
))))
5531 return Available_View
(Typ
);
5536 end Process_Implicit_Dereference_Prefix
;
5538 --------------------------------
5539 -- Remove_Abstract_Operations --
5540 --------------------------------
5542 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
5543 Abstract_Op
: Entity_Id
:= Empty
;
5544 Address_Kludge
: Boolean := False;
5548 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
5549 -- activate this if either extensions are enabled, or if the abstract
5550 -- operation in question comes from a predefined file. This latter test
5551 -- allows us to use abstract to make operations invisible to users. In
5552 -- particular, if type Address is non-private and abstract subprograms
5553 -- are used to hide its operators, they will be truly hidden.
5555 type Operand_Position
is (First_Op
, Second_Op
);
5556 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
5558 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
5559 -- Ambiguities may arise when the operands are literal and the address
5560 -- operations in s-auxdec are visible. In that case, remove the
5561 -- interpretation of a literal as Address, to retain the semantics of
5562 -- Address as a private type.
5564 ------------------------------------
5565 -- Remove_Address_Interpretations --
5566 ------------------------------------
5568 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
5572 if Is_Overloaded
(N
) then
5573 Get_First_Interp
(N
, I
, It
);
5574 while Present
(It
.Nam
) loop
5575 Formal
:= First_Entity
(It
.Nam
);
5577 if Op
= Second_Op
then
5578 Formal
:= Next_Entity
(Formal
);
5581 if Is_Descendent_Of_Address
(Etype
(Formal
)) then
5582 Address_Kludge
:= True;
5586 Get_Next_Interp
(I
, It
);
5589 end Remove_Address_Interpretations
;
5591 -- Start of processing for Remove_Abstract_Operations
5594 if Is_Overloaded
(N
) then
5595 Get_First_Interp
(N
, I
, It
);
5597 while Present
(It
.Nam
) loop
5598 if Is_Overloadable
(It
.Nam
)
5599 and then Is_Abstract_Subprogram
(It
.Nam
)
5600 and then not Is_Dispatching_Operation
(It
.Nam
)
5602 Abstract_Op
:= It
.Nam
;
5604 if Is_Descendent_Of_Address
(It
.Typ
) then
5605 Address_Kludge
:= True;
5609 -- In Ada 2005, this operation does not participate in Overload
5610 -- resolution. If the operation is defined in a predefined
5611 -- unit, it is one of the operations declared abstract in some
5612 -- variants of System, and it must be removed as well.
5614 elsif Ada_Version
>= Ada_05
5615 or else Is_Predefined_File_Name
5616 (Unit_File_Name
(Get_Source_Unit
(It
.Nam
)))
5623 Get_Next_Interp
(I
, It
);
5626 if No
(Abstract_Op
) then
5628 -- If some interpretation yields an integer type, it is still
5629 -- possible that there are address interpretations. Remove them
5630 -- if one operand is a literal, to avoid spurious ambiguities
5631 -- on systems where Address is a visible integer type.
5633 if Is_Overloaded
(N
)
5634 and then Nkind
(N
) in N_Op
5635 and then Is_Integer_Type
(Etype
(N
))
5637 if Nkind
(N
) in N_Binary_Op
then
5638 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
5639 Remove_Address_Interpretations
(Second_Op
);
5641 elsif Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
5642 Remove_Address_Interpretations
(First_Op
);
5647 elsif Nkind
(N
) in N_Op
then
5649 -- Remove interpretations that treat literals as addresses. This
5650 -- is never appropriate, even when Address is defined as a visible
5651 -- Integer type. The reason is that we would really prefer Address
5652 -- to behave as a private type, even in this case, which is there
5653 -- only to accommodate oddities of VMS address sizes. If Address
5654 -- is a visible integer type, we get lots of overload ambiguities.
5656 if Nkind
(N
) in N_Binary_Op
then
5658 U1
: constant Boolean :=
5659 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
5660 U2
: constant Boolean :=
5661 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
5665 Remove_Address_Interpretations
(Second_Op
);
5669 Remove_Address_Interpretations
(First_Op
);
5672 if not (U1
and U2
) then
5674 -- Remove corresponding predefined operator, which is
5675 -- always added to the overload set.
5677 Get_First_Interp
(N
, I
, It
);
5678 while Present
(It
.Nam
) loop
5679 if Scope
(It
.Nam
) = Standard_Standard
5680 and then Base_Type
(It
.Typ
) =
5681 Base_Type
(Etype
(Abstract_Op
))
5686 Get_Next_Interp
(I
, It
);
5689 elsif Is_Overloaded
(N
)
5690 and then Present
(Univ_Type
)
5692 -- If both operands have a universal interpretation,
5693 -- it is still necessary to remove interpretations that
5694 -- yield Address. Any remaining ambiguities will be
5695 -- removed in Disambiguate.
5697 Get_First_Interp
(N
, I
, It
);
5698 while Present
(It
.Nam
) loop
5699 if Is_Descendent_Of_Address
(It
.Typ
) then
5702 elsif not Is_Type
(It
.Nam
) then
5703 Set_Entity
(N
, It
.Nam
);
5706 Get_Next_Interp
(I
, It
);
5712 elsif Nkind
(N
) = N_Function_Call
5714 (Nkind
(Name
(N
)) = N_Operator_Symbol
5716 (Nkind
(Name
(N
)) = N_Expanded_Name
5718 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
5722 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
5723 U1
: constant Boolean :=
5724 Present
(Universal_Interpretation
(Arg1
));
5725 U2
: constant Boolean :=
5726 Present
(Next
(Arg1
)) and then
5727 Present
(Universal_Interpretation
(Next
(Arg1
)));
5731 Remove_Address_Interpretations
(First_Op
);
5735 Remove_Address_Interpretations
(Second_Op
);
5738 if not (U1
and U2
) then
5739 Get_First_Interp
(N
, I
, It
);
5740 while Present
(It
.Nam
) loop
5741 if Scope
(It
.Nam
) = Standard_Standard
5742 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
5747 Get_Next_Interp
(I
, It
);
5753 -- If the removal has left no valid interpretations, emit an error
5754 -- message now and label node as illegal.
5756 if Present
(Abstract_Op
) then
5757 Get_First_Interp
(N
, I
, It
);
5761 -- Removal of abstract operation left no viable candidate
5763 Set_Etype
(N
, Any_Type
);
5764 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
5766 ("cannot call abstract operation& declared#", N
, Abstract_Op
);
5768 -- In Ada 2005, an abstract operation may disable predefined
5769 -- operators. Since the context is not yet known, we mark the
5770 -- predefined operators as potentially hidden. Do not include
5771 -- predefined operators when addresses are involved since this
5772 -- case is handled separately.
5774 elsif Ada_Version
>= Ada_05
5775 and then not Address_Kludge
5777 while Present
(It
.Nam
) loop
5778 if Is_Numeric_Type
(It
.Typ
)
5779 and then Scope
(It
.Typ
) = Standard_Standard
5781 Set_Abstract_Op
(I
, Abstract_Op
);
5784 Get_Next_Interp
(I
, It
);
5789 end Remove_Abstract_Operations
;
5791 -----------------------
5792 -- Try_Indirect_Call --
5793 -----------------------
5795 function Try_Indirect_Call
5798 Typ
: Entity_Id
) return Boolean
5804 pragma Warnings
(Off
, Call_OK
);
5807 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
5809 Actual
:= First_Actual
(N
);
5810 Formal
:= First_Formal
(Designated_Type
(Typ
));
5811 while Present
(Actual
) and then Present
(Formal
) loop
5812 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
5817 Next_Formal
(Formal
);
5820 if No
(Actual
) and then No
(Formal
) then
5821 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
5823 -- Nam is a candidate interpretation for the name in the call,
5824 -- if it is not an indirect call.
5826 if not Is_Type
(Nam
)
5827 and then Is_Entity_Name
(Name
(N
))
5829 Set_Entity
(Name
(N
), Nam
);
5836 end Try_Indirect_Call
;
5838 ----------------------
5839 -- Try_Indexed_Call --
5840 ----------------------
5842 function Try_Indexed_Call
5846 Skip_First
: Boolean) return Boolean
5848 Loc
: constant Source_Ptr
:= Sloc
(N
);
5849 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
5854 Actual
:= First
(Actuals
);
5856 -- If the call was originally written in prefix form, skip the first
5857 -- actual, which is obviously not defaulted.
5863 Index
:= First_Index
(Typ
);
5864 while Present
(Actual
) and then Present
(Index
) loop
5866 -- If the parameter list has a named association, the expression
5867 -- is definitely a call and not an indexed component.
5869 if Nkind
(Actual
) = N_Parameter_Association
then
5873 if Is_Entity_Name
(Actual
)
5874 and then Is_Type
(Entity
(Actual
))
5875 and then No
(Next
(Actual
))
5879 Prefix
=> Make_Function_Call
(Loc
,
5880 Name
=> Relocate_Node
(Name
(N
))),
5882 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
5887 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
5895 if No
(Actual
) and then No
(Index
) then
5896 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
5898 -- Nam is a candidate interpretation for the name in the call,
5899 -- if it is not an indirect call.
5901 if not Is_Type
(Nam
)
5902 and then Is_Entity_Name
(Name
(N
))
5904 Set_Entity
(Name
(N
), Nam
);
5911 end Try_Indexed_Call
;
5913 --------------------------
5914 -- Try_Object_Operation --
5915 --------------------------
5917 function Try_Object_Operation
(N
: Node_Id
) return Boolean is
5918 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
5919 Is_Subprg_Call
: constant Boolean := Nkind_In
5920 (K
, N_Procedure_Call_Statement
,
5922 Loc
: constant Source_Ptr
:= Sloc
(N
);
5923 Obj
: constant Node_Id
:= Prefix
(N
);
5924 Subprog
: constant Node_Id
:=
5925 Make_Identifier
(Sloc
(Selector_Name
(N
)),
5926 Chars
=> Chars
(Selector_Name
(N
)));
5927 -- Identifier on which possible interpretations will be collected
5929 Report_Error
: Boolean := False;
5930 -- If no candidate interpretation matches the context, redo the
5931 -- analysis with error enabled to provide additional information.
5934 Candidate
: Entity_Id
:= Empty
;
5935 New_Call_Node
: Node_Id
:= Empty
;
5936 Node_To_Replace
: Node_Id
;
5937 Obj_Type
: Entity_Id
:= Etype
(Obj
);
5938 Success
: Boolean := False;
5940 function Valid_Candidate
5943 Subp
: Entity_Id
) return Entity_Id
;
5944 -- If the subprogram is a valid interpretation, record it, and add
5945 -- to the list of interpretations of Subprog.
5947 procedure Complete_Object_Operation
5948 (Call_Node
: Node_Id
;
5949 Node_To_Replace
: Node_Id
);
5950 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
5951 -- Call_Node, insert the object (or its dereference) as the first actual
5952 -- in the call, and complete the analysis of the call.
5954 procedure Report_Ambiguity
(Op
: Entity_Id
);
5955 -- If a prefixed procedure call is ambiguous, indicate whether the
5956 -- call includes an implicit dereference or an implicit 'Access.
5958 procedure Transform_Object_Operation
5959 (Call_Node
: out Node_Id
;
5960 Node_To_Replace
: out Node_Id
);
5961 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
5962 -- Call_Node is the resulting subprogram call, Node_To_Replace is
5963 -- either N or the parent of N, and Subprog is a reference to the
5964 -- subprogram we are trying to match.
5966 function Try_Class_Wide_Operation
5967 (Call_Node
: Node_Id
;
5968 Node_To_Replace
: Node_Id
) return Boolean;
5969 -- Traverse all ancestor types looking for a class-wide subprogram
5970 -- for which the current operation is a valid non-dispatching call.
5972 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
5973 -- If prefix is overloaded, its interpretation may include different
5974 -- tagged types, and we must examine the primitive operations and
5975 -- the class-wide operations of each in order to find candidate
5976 -- interpretations for the call as a whole.
5978 function Try_Primitive_Operation
5979 (Call_Node
: Node_Id
;
5980 Node_To_Replace
: Node_Id
) return Boolean;
5981 -- Traverse the list of primitive subprograms looking for a dispatching
5982 -- operation for which the current node is a valid call .
5984 ---------------------
5985 -- Valid_Candidate --
5986 ---------------------
5988 function Valid_Candidate
5991 Subp
: Entity_Id
) return Entity_Id
5993 Arr_Type
: Entity_Id
;
5994 Comp_Type
: Entity_Id
;
5997 -- If the subprogram is a valid interpretation, record it in global
5998 -- variable Subprog, to collect all possible overloadings.
6001 if Subp
/= Entity
(Subprog
) then
6002 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
6006 -- If the call may be an indexed call, retrieve component type of
6007 -- resulting expression, and add possible interpretation.
6012 if Nkind
(Call
) = N_Function_Call
6013 and then Nkind
(Parent
(N
)) = N_Indexed_Component
6014 and then Needs_One_Actual
(Subp
)
6016 if Is_Array_Type
(Etype
(Subp
)) then
6017 Arr_Type
:= Etype
(Subp
);
6019 elsif Is_Access_Type
(Etype
(Subp
))
6020 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
6022 Arr_Type
:= Designated_Type
(Etype
(Subp
));
6026 if Present
(Arr_Type
) then
6028 -- Verify that the actuals (excluding the object)
6029 -- match the types of the indices.
6036 Actual
:= Next
(First_Actual
(Call
));
6037 Index
:= First_Index
(Arr_Type
);
6038 while Present
(Actual
) and then Present
(Index
) loop
6039 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
6044 Next_Actual
(Actual
);
6050 and then Present
(Arr_Type
)
6052 Comp_Type
:= Component_Type
(Arr_Type
);
6056 if Present
(Comp_Type
)
6057 and then Etype
(Subprog
) /= Comp_Type
6059 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
6063 if Etype
(Call
) /= Any_Type
then
6068 end Valid_Candidate
;
6070 -------------------------------
6071 -- Complete_Object_Operation --
6072 -------------------------------
6074 procedure Complete_Object_Operation
6075 (Call_Node
: Node_Id
;
6076 Node_To_Replace
: Node_Id
)
6078 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
6079 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
6080 First_Actual
: Node_Id
;
6083 -- Place the name of the operation, with its interpretations,
6084 -- on the rewritten call.
6086 Set_Name
(Call_Node
, Subprog
);
6088 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
6090 -- For cross-reference purposes, treat the new node as being in
6091 -- the source if the original one is.
6093 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
6094 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
6096 if Nkind
(N
) = N_Selected_Component
6097 and then not Inside_A_Generic
6099 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
6102 -- If need be, rewrite first actual as an explicit dereference
6103 -- If the call is overloaded, the rewriting can only be done
6104 -- once the primitive operation is identified.
6106 if Is_Overloaded
(Subprog
) then
6108 -- The prefix itself may be overloaded, and its interpretations
6109 -- must be propagated to the new actual in the call.
6111 if Is_Overloaded
(Obj
) then
6112 Save_Interps
(Obj
, First_Actual
);
6115 Rewrite
(First_Actual
, Obj
);
6117 elsif not Is_Access_Type
(Formal_Type
)
6118 and then Is_Access_Type
(Etype
(Obj
))
6120 Rewrite
(First_Actual
,
6121 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
6122 Analyze
(First_Actual
);
6124 -- If we need to introduce an explicit dereference, verify that
6125 -- the resulting actual is compatible with the mode of the formal.
6127 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
6128 and then Is_Access_Constant
(Etype
(Obj
))
6131 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
6134 -- Conversely, if the formal is an access parameter and the object
6135 -- is not, replace the actual with a 'Access reference. Its analysis
6136 -- will check that the object is aliased.
6138 elsif Is_Access_Type
(Formal_Type
)
6139 and then not Is_Access_Type
(Etype
(Obj
))
6141 -- A special case: A.all'access is illegal if A is an access to a
6142 -- constant and the context requires an access to a variable.
6144 if not Is_Access_Constant
(Formal_Type
) then
6145 if (Nkind
(Obj
) = N_Explicit_Dereference
6146 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
6147 or else not Is_Variable
(Obj
)
6150 ("actual for& must be a variable", Obj
, Control
);
6154 Rewrite
(First_Actual
,
6155 Make_Attribute_Reference
(Loc
,
6156 Attribute_Name
=> Name_Access
,
6157 Prefix
=> Relocate_Node
(Obj
)));
6159 if not Is_Aliased_View
(Obj
) then
6161 ("object in prefixed call to& must be aliased"
6162 & " (RM-2005 4.3.1 (13))",
6163 Prefix
(First_Actual
), Subprog
);
6166 Analyze
(First_Actual
);
6169 if Is_Overloaded
(Obj
) then
6170 Save_Interps
(Obj
, First_Actual
);
6173 Rewrite
(First_Actual
, Obj
);
6176 Rewrite
(Node_To_Replace
, Call_Node
);
6178 -- Propagate the interpretations collected in subprog to the new
6179 -- function call node, to be resolved from context.
6181 if Is_Overloaded
(Subprog
) then
6182 Save_Interps
(Subprog
, Node_To_Replace
);
6184 Analyze
(Node_To_Replace
);
6186 end Complete_Object_Operation
;
6188 ----------------------
6189 -- Report_Ambiguity --
6190 ----------------------
6192 procedure Report_Ambiguity
(Op
: Entity_Id
) is
6193 Access_Formal
: constant Boolean :=
6194 Is_Access_Type
(Etype
(First_Formal
(Op
)));
6195 Access_Actual
: constant Boolean :=
6196 Is_Access_Type
(Etype
(Prefix
(N
)));
6199 Error_Msg_Sloc
:= Sloc
(Op
);
6201 if Access_Formal
and then not Access_Actual
then
6202 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6204 ("\possible interpretation"
6205 & " (inherited, with implicit 'Access) #", N
);
6208 ("\possible interpretation (with implicit 'Access) #", N
);
6211 elsif not Access_Formal
and then Access_Actual
then
6212 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6214 ("\possible interpretation"
6215 & " ( inherited, with implicit dereference) #", N
);
6218 ("\possible interpretation (with implicit dereference) #", N
);
6222 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6223 Error_Msg_N
("\possible interpretation (inherited)#", N
);
6225 Error_Msg_N
-- CODEFIX
6226 ("\possible interpretation#", N
);
6229 end Report_Ambiguity
;
6231 --------------------------------
6232 -- Transform_Object_Operation --
6233 --------------------------------
6235 procedure Transform_Object_Operation
6236 (Call_Node
: out Node_Id
;
6237 Node_To_Replace
: out Node_Id
)
6239 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
6240 -- Placeholder used as a first parameter in the call, replaced
6241 -- eventually by the proper object.
6243 Parent_Node
: constant Node_Id
:= Parent
(N
);
6249 -- Common case covering 1) Call to a procedure and 2) Call to a
6250 -- function that has some additional actuals.
6252 if Nkind_In
(Parent_Node
, N_Function_Call
,
6253 N_Procedure_Call_Statement
)
6255 -- N is a selected component node containing the name of the
6256 -- subprogram. If N is not the name of the parent node we must
6257 -- not replace the parent node by the new construct. This case
6258 -- occurs when N is a parameterless call to a subprogram that
6259 -- is an actual parameter of a call to another subprogram. For
6261 -- Some_Subprogram (..., Obj.Operation, ...)
6263 and then Name
(Parent_Node
) = N
6265 Node_To_Replace
:= Parent_Node
;
6267 Actuals
:= Parameter_Associations
(Parent_Node
);
6269 if Present
(Actuals
) then
6270 Prepend
(Dummy
, Actuals
);
6272 Actuals
:= New_List
(Dummy
);
6275 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
6277 Make_Procedure_Call_Statement
(Loc
,
6278 Name
=> New_Copy
(Subprog
),
6279 Parameter_Associations
=> Actuals
);
6283 Make_Function_Call
(Loc
,
6284 Name
=> New_Copy
(Subprog
),
6285 Parameter_Associations
=> Actuals
);
6289 -- Before analysis, a function call appears as an indexed component
6290 -- if there are no named associations.
6292 elsif Nkind
(Parent_Node
) = N_Indexed_Component
6293 and then N
= Prefix
(Parent_Node
)
6295 Node_To_Replace
:= Parent_Node
;
6297 Actuals
:= Expressions
(Parent_Node
);
6299 Actual
:= First
(Actuals
);
6300 while Present
(Actual
) loop
6305 Prepend
(Dummy
, Actuals
);
6308 Make_Function_Call
(Loc
,
6309 Name
=> New_Copy
(Subprog
),
6310 Parameter_Associations
=> Actuals
);
6312 -- Parameterless call: Obj.F is rewritten as F (Obj)
6315 Node_To_Replace
:= N
;
6318 Make_Function_Call
(Loc
,
6319 Name
=> New_Copy
(Subprog
),
6320 Parameter_Associations
=> New_List
(Dummy
));
6322 end Transform_Object_Operation
;
6324 ------------------------------
6325 -- Try_Class_Wide_Operation --
6326 ------------------------------
6328 function Try_Class_Wide_Operation
6329 (Call_Node
: Node_Id
;
6330 Node_To_Replace
: Node_Id
) return Boolean
6332 Anc_Type
: Entity_Id
;
6333 Matching_Op
: Entity_Id
:= Empty
;
6336 procedure Traverse_Homonyms
6337 (Anc_Type
: Entity_Id
;
6338 Error
: out Boolean);
6339 -- Traverse the homonym chain of the subprogram searching for those
6340 -- homonyms whose first formal has the Anc_Type's class-wide type,
6341 -- or an anonymous access type designating the class-wide type. If
6342 -- an ambiguity is detected, then Error is set to True.
6344 procedure Traverse_Interfaces
6345 (Anc_Type
: Entity_Id
;
6346 Error
: out Boolean);
6347 -- Traverse the list of interfaces, if any, associated with Anc_Type
6348 -- and search for acceptable class-wide homonyms associated with each
6349 -- interface. If an ambiguity is detected, then Error is set to True.
6351 -----------------------
6352 -- Traverse_Homonyms --
6353 -----------------------
6355 procedure Traverse_Homonyms
6356 (Anc_Type
: Entity_Id
;
6357 Error
: out Boolean)
6359 Cls_Type
: Entity_Id
;
6367 Cls_Type
:= Class_Wide_Type
(Anc_Type
);
6369 Hom
:= Current_Entity
(Subprog
);
6371 -- Find operation whose first parameter is of the class-wide
6372 -- type, a subtype thereof, or an anonymous access to same.
6374 while Present
(Hom
) loop
6375 if (Ekind
(Hom
) = E_Procedure
6377 Ekind
(Hom
) = E_Function
)
6378 and then Scope
(Hom
) = Scope
(Anc_Type
)
6379 and then Present
(First_Formal
(Hom
))
6381 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
6383 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
6385 Ekind
(Etype
(First_Formal
(Hom
))) =
6386 E_Anonymous_Access_Type
6389 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
6392 Set_Etype
(Call_Node
, Any_Type
);
6393 Set_Is_Overloaded
(Call_Node
, False);
6396 if No
(Matching_Op
) then
6397 Hom_Ref
:= New_Reference_To
(Hom
, Sloc
(Subprog
));
6398 Set_Etype
(Call_Node
, Any_Type
);
6399 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
6401 Set_Name
(Call_Node
, Hom_Ref
);
6406 Report
=> Report_Error
,
6408 Skip_First
=> True);
6411 Valid_Candidate
(Success
, Call_Node
, Hom
);
6417 Report
=> Report_Error
,
6419 Skip_First
=> True);
6421 if Present
(Valid_Candidate
(Success
, Call_Node
, Hom
))
6422 and then Nkind
(Call_Node
) /= N_Function_Call
6424 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
6425 Report_Ambiguity
(Matching_Op
);
6426 Report_Ambiguity
(Hom
);
6433 Hom
:= Homonym
(Hom
);
6435 end Traverse_Homonyms
;
6437 -------------------------
6438 -- Traverse_Interfaces --
6439 -------------------------
6441 procedure Traverse_Interfaces
6442 (Anc_Type
: Entity_Id
;
6443 Error
: out Boolean)
6445 Intface_List
: constant List_Id
:=
6446 Abstract_Interface_List
(Anc_Type
);
6452 if Is_Non_Empty_List
(Intface_List
) then
6453 Intface
:= First
(Intface_List
);
6454 while Present
(Intface
) loop
6456 -- Look for acceptable class-wide homonyms associated with
6459 Traverse_Homonyms
(Etype
(Intface
), Error
);
6465 -- Continue the search by looking at each of the interface's
6466 -- associated interface ancestors.
6468 Traverse_Interfaces
(Etype
(Intface
), Error
);
6477 end Traverse_Interfaces
;
6479 -- Start of processing for Try_Class_Wide_Operation
6482 -- Loop through ancestor types (including interfaces), traversing
6483 -- the homonym chain of the subprogram, trying out those homonyms
6484 -- whose first formal has the class-wide type of the ancestor, or
6485 -- an anonymous access type designating the class-wide type.
6487 Anc_Type
:= Obj_Type
;
6489 -- Look for a match among homonyms associated with the ancestor
6491 Traverse_Homonyms
(Anc_Type
, Error
);
6497 -- Continue the search for matches among homonyms associated with
6498 -- any interfaces implemented by the ancestor.
6500 Traverse_Interfaces
(Anc_Type
, Error
);
6506 exit when Etype
(Anc_Type
) = Anc_Type
;
6507 Anc_Type
:= Etype
(Anc_Type
);
6510 if Present
(Matching_Op
) then
6511 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
6514 return Present
(Matching_Op
);
6515 end Try_Class_Wide_Operation
;
6517 -----------------------------------
6518 -- Try_One_Prefix_Interpretation --
6519 -----------------------------------
6521 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
6525 if Is_Access_Type
(Obj_Type
) then
6526 Obj_Type
:= Designated_Type
(Obj_Type
);
6529 if Ekind
(Obj_Type
) = E_Private_Subtype
then
6530 Obj_Type
:= Base_Type
(Obj_Type
);
6533 if Is_Class_Wide_Type
(Obj_Type
) then
6534 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
6537 -- The type may have be obtained through a limited_with clause,
6538 -- in which case the primitive operations are available on its
6539 -- non-limited view. If still incomplete, retrieve full view.
6541 if Ekind
(Obj_Type
) = E_Incomplete_Type
6542 and then From_With_Type
(Obj_Type
)
6544 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
6547 -- If the object is not tagged, or the type is still an incomplete
6548 -- type, this is not a prefixed call.
6550 if not Is_Tagged_Type
(Obj_Type
)
6551 or else Is_Incomplete_Type
(Obj_Type
)
6556 if Try_Primitive_Operation
6557 (Call_Node
=> New_Call_Node
,
6558 Node_To_Replace
=> Node_To_Replace
)
6560 Try_Class_Wide_Operation
6561 (Call_Node
=> New_Call_Node
,
6562 Node_To_Replace
=> Node_To_Replace
)
6566 end Try_One_Prefix_Interpretation
;
6568 -----------------------------
6569 -- Try_Primitive_Operation --
6570 -----------------------------
6572 function Try_Primitive_Operation
6573 (Call_Node
: Node_Id
;
6574 Node_To_Replace
: Node_Id
) return Boolean
6577 Prim_Op
: Entity_Id
;
6578 Matching_Op
: Entity_Id
:= Empty
;
6579 Prim_Op_Ref
: Node_Id
:= Empty
;
6581 Corr_Type
: Entity_Id
:= Empty
;
6582 -- If the prefix is a synchronized type, the controlling type of
6583 -- the primitive operation is the corresponding record type, else
6584 -- this is the object type itself.
6586 Success
: Boolean := False;
6588 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
6589 -- For tagged types the candidate interpretations are found in
6590 -- the list of primitive operations of the type and its ancestors.
6591 -- For formal tagged types we have to find the operations declared
6592 -- in the same scope as the type (including in the generic formal
6593 -- part) because the type itself carries no primitive operations,
6594 -- except for formal derived types that inherit the operations of
6595 -- the parent and progenitors.
6596 -- If the context is a generic subprogram body, the generic formals
6597 -- are visible by name, but are not in the entity list of the
6598 -- subprogram because that list starts with the subprogram formals.
6599 -- We retrieve the candidate operations from the generic declaration.
6601 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
6602 -- An operation that overrides an inherited operation in the private
6603 -- part of its package may be hidden, but if the inherited operation
6604 -- is visible a direct call to it will dispatch to the private one,
6605 -- which is therefore a valid candidate.
6607 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
6608 -- Verify that the prefix, dereferenced if need be, is a valid
6609 -- controlling argument in a call to Op. The remaining actuals
6610 -- are checked in the subsequent call to Analyze_One_Call.
6612 ------------------------------
6613 -- Collect_Generic_Type_Ops --
6614 ------------------------------
6616 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
6617 Bas
: constant Entity_Id
:= Base_Type
(T
);
6618 Candidates
: constant Elist_Id
:= New_Elmt_List
;
6622 procedure Check_Candidate
;
6623 -- The operation is a candidate if its first parameter is a
6624 -- controlling operand of the desired type.
6626 -----------------------
6627 -- Check_Candidate; --
6628 -----------------------
6630 procedure Check_Candidate
is
6632 Formal
:= First_Formal
(Subp
);
6635 and then Is_Controlling_Formal
(Formal
)
6637 (Base_Type
(Etype
(Formal
)) = Bas
6639 (Is_Access_Type
(Etype
(Formal
))
6640 and then Designated_Type
(Etype
(Formal
)) = Bas
))
6642 Append_Elmt
(Subp
, Candidates
);
6644 end Check_Candidate
;
6646 -- Start of processing for Collect_Generic_Type_Ops
6649 if Is_Derived_Type
(T
) then
6650 return Primitive_Operations
(T
);
6652 elsif Ekind
(Scope
(T
)) = E_Procedure
6653 or else Ekind
(Scope
(T
)) = E_Function
6655 -- Scan the list of generic formals to find subprograms
6656 -- that may have a first controlling formal of the type.
6663 First
(Generic_Formal_Declarations
6664 (Unit_Declaration_Node
(Scope
(T
))));
6665 while Present
(Decl
) loop
6666 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
6667 Subp
:= Defining_Entity
(Decl
);
6678 -- Scan the list of entities declared in the same scope as
6679 -- the type. In general this will be an open scope, given that
6680 -- the call we are analyzing can only appear within a generic
6681 -- declaration or body (either the one that declares T, or a
6684 Subp
:= First_Entity
(Scope
(T
));
6685 while Present
(Subp
) loop
6686 if Is_Overloadable
(Subp
) then
6695 end Collect_Generic_Type_Ops
;
6697 ---------------------------
6698 -- Is_Private_Overriding --
6699 ---------------------------
6701 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
6702 Visible_Op
: constant Entity_Id
:= Homonym
(Op
);
6705 return Present
(Visible_Op
)
6706 and then Scope
(Op
) = Scope
(Visible_Op
)
6707 and then not Comes_From_Source
(Visible_Op
)
6708 and then Alias
(Visible_Op
) = Op
6709 and then not Is_Hidden
(Visible_Op
);
6710 end Is_Private_Overriding
;
6712 -----------------------------
6713 -- Valid_First_Argument_Of --
6714 -----------------------------
6716 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
6717 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
6720 if Is_Concurrent_Type
(Typ
)
6721 and then Present
(Corresponding_Record_Type
(Typ
))
6723 Typ
:= Corresponding_Record_Type
(Typ
);
6726 -- Simple case. Object may be a subtype of the tagged type or
6727 -- may be the corresponding record of a synchronized type.
6729 return Obj_Type
= Typ
6730 or else Base_Type
(Obj_Type
) = Typ
6731 or else Corr_Type
= Typ
6733 -- Prefix can be dereferenced
6736 (Is_Access_Type
(Corr_Type
)
6737 and then Designated_Type
(Corr_Type
) = Typ
)
6739 -- Formal is an access parameter, for which the object
6740 -- can provide an access.
6743 (Ekind
(Typ
) = E_Anonymous_Access_Type
6744 and then Designated_Type
(Typ
) = Base_Type
(Corr_Type
));
6745 end Valid_First_Argument_Of
;
6747 -- Start of processing for Try_Primitive_Operation
6750 -- Look for subprograms in the list of primitive operations. The name
6751 -- must be identical, and the kind of call indicates the expected
6752 -- kind of operation (function or procedure). If the type is a
6753 -- (tagged) synchronized type, the primitive ops are attached to the
6754 -- corresponding record (base) type.
6756 if Is_Concurrent_Type
(Obj_Type
) then
6757 if not Present
(Corresponding_Record_Type
(Obj_Type
)) then
6761 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
6762 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
6764 elsif not Is_Generic_Type
(Obj_Type
) then
6765 Corr_Type
:= Obj_Type
;
6766 Elmt
:= First_Elmt
(Primitive_Operations
(Obj_Type
));
6769 Corr_Type
:= Obj_Type
;
6770 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
6773 while Present
(Elmt
) loop
6774 Prim_Op
:= Node
(Elmt
);
6776 if Chars
(Prim_Op
) = Chars
(Subprog
)
6777 and then Present
(First_Formal
(Prim_Op
))
6778 and then Valid_First_Argument_Of
(Prim_Op
)
6780 (Nkind
(Call_Node
) = N_Function_Call
)
6781 = (Ekind
(Prim_Op
) = E_Function
)
6783 -- Ada 2005 (AI-251): If this primitive operation corresponds
6784 -- with an immediate ancestor interface there is no need to add
6785 -- it to the list of interpretations; the corresponding aliased
6786 -- primitive is also in this list of primitive operations and
6787 -- will be used instead.
6789 if (Present
(Interface_Alias
(Prim_Op
))
6790 and then Is_Ancestor
(Find_Dispatching_Type
6791 (Alias
(Prim_Op
)), Corr_Type
))
6793 -- Do not consider hidden primitives unless the type is in an
6794 -- open scope or we are within an instance, where visibility
6795 -- is known to be correct, or else if this is an overriding
6796 -- operation in the private part for an inherited operation.
6798 or else (Is_Hidden
(Prim_Op
)
6799 and then not Is_Immediately_Visible
(Obj_Type
)
6800 and then not In_Instance
6801 and then not Is_Private_Overriding
(Prim_Op
))
6806 Set_Etype
(Call_Node
, Any_Type
);
6807 Set_Is_Overloaded
(Call_Node
, False);
6809 if No
(Matching_Op
) then
6810 Prim_Op_Ref
:= New_Reference_To
(Prim_Op
, Sloc
(Subprog
));
6811 Candidate
:= Prim_Op
;
6813 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
6815 Set_Name
(Call_Node
, Prim_Op_Ref
);
6821 Report
=> Report_Error
,
6823 Skip_First
=> True);
6825 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
6827 -- More than one interpretation, collect for subsequent
6828 -- disambiguation. If this is a procedure call and there
6829 -- is another match, report ambiguity now.
6835 Report
=> Report_Error
,
6837 Skip_First
=> True);
6839 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
6840 and then Nkind
(Call_Node
) /= N_Function_Call
6842 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
6843 Report_Ambiguity
(Matching_Op
);
6844 Report_Ambiguity
(Prim_Op
);
6854 if Present
(Matching_Op
) then
6855 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
6858 return Present
(Matching_Op
);
6859 end Try_Primitive_Operation
;
6861 -- Start of processing for Try_Object_Operation
6864 Analyze_Expression
(Obj
);
6866 -- Analyze the actuals if node is known to be a subprogram call
6868 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
6869 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
6870 while Present
(Actual
) loop
6871 Analyze_Expression
(Actual
);
6876 -- Build a subprogram call node, using a copy of Obj as its first
6877 -- actual. This is a placeholder, to be replaced by an explicit
6878 -- dereference when needed.
6880 Transform_Object_Operation
6881 (Call_Node
=> New_Call_Node
,
6882 Node_To_Replace
=> Node_To_Replace
);
6884 Set_Etype
(New_Call_Node
, Any_Type
);
6885 Set_Etype
(Subprog
, Any_Type
);
6886 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
6888 if not Is_Overloaded
(Obj
) then
6889 Try_One_Prefix_Interpretation
(Obj_Type
);
6896 Get_First_Interp
(Obj
, I
, It
);
6897 while Present
(It
.Nam
) loop
6898 Try_One_Prefix_Interpretation
(It
.Typ
);
6899 Get_Next_Interp
(I
, It
);
6904 if Etype
(New_Call_Node
) /= Any_Type
then
6905 Complete_Object_Operation
6906 (Call_Node
=> New_Call_Node
,
6907 Node_To_Replace
=> Node_To_Replace
);
6910 elsif Present
(Candidate
) then
6912 -- The argument list is not type correct. Re-analyze with error
6913 -- reporting enabled, and use one of the possible candidates.
6914 -- In All_Errors_Mode, re-analyze all failed interpretations.
6916 if All_Errors_Mode
then
6917 Report_Error
:= True;
6918 if Try_Primitive_Operation
6919 (Call_Node
=> New_Call_Node
,
6920 Node_To_Replace
=> Node_To_Replace
)
6923 Try_Class_Wide_Operation
6924 (Call_Node
=> New_Call_Node
,
6925 Node_To_Replace
=> Node_To_Replace
)
6932 (N
=> New_Call_Node
,
6936 Skip_First
=> True);
6939 -- No need for further errors
6944 -- There was no candidate operation, so report it as an error
6945 -- in the caller: Analyze_Selected_Component.
6949 end Try_Object_Operation
;
6955 procedure wpo
(T
: Entity_Id
) is
6960 if not Is_Tagged_Type
(T
) then
6964 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
6965 while Present
(E
) loop
6967 Write_Int
(Int
(Op
));
6968 Write_Str
(" === ");
6969 Write_Name
(Chars
(Op
));
6971 Write_Name
(Chars
(Scope
(Op
)));