1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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_Case
; use Sem_Case
;
47 with Sem_Cat
; use Sem_Cat
;
48 with Sem_Ch3
; use Sem_Ch3
;
49 with Sem_Ch6
; use Sem_Ch6
;
50 with Sem_Ch8
; use Sem_Ch8
;
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_Type
; use Sem_Type
;
56 with Sem_Util
; use Sem_Util
;
57 with Sem_Warn
; use Sem_Warn
;
58 with Stand
; use Stand
;
59 with Sinfo
; use Sinfo
;
60 with Snames
; use Snames
;
61 with Tbuild
; use Tbuild
;
63 package body Sem_Ch4
is
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 procedure Analyze_Concatenation_Rest
(N
: Node_Id
);
70 -- Does the "rest" of the work of Analyze_Concatenation, after the left
71 -- operand has been analyzed. See Analyze_Concatenation for details.
73 procedure Analyze_Expression
(N
: Node_Id
);
74 -- For expressions that are not names, this is just a call to analyze.
75 -- If the expression is a name, it may be a call to a parameterless
76 -- function, and if so must be converted into an explicit call node
77 -- and analyzed as such. This deproceduring must be done during the first
78 -- pass of overload resolution, because otherwise a procedure call with
79 -- overloaded actuals may fail to resolve.
81 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
);
82 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call
83 -- is an operator name or an expanded name whose selector is an operator
84 -- name, and one possible interpretation is as a predefined operator.
86 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
);
87 -- If the prefix of a selected_component is overloaded, the proper
88 -- interpretation that yields a record type with the proper selector
89 -- name must be selected.
91 procedure Analyze_User_Defined_Binary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
92 -- Procedure to analyze a user defined binary operator, which is resolved
93 -- like a function, but instead of a list of actuals it is presented
94 -- with the left and right operands of an operator node.
96 procedure Analyze_User_Defined_Unary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
97 -- Procedure to analyze a user defined unary operator, which is resolved
98 -- like a function, but instead of a list of actuals, it is presented with
99 -- the operand of the operator node.
101 procedure Ambiguous_Operands
(N
: Node_Id
);
102 -- for equality, membership, and comparison operators with overloaded
103 -- arguments, list possible interpretations.
105 procedure Analyze_One_Call
109 Success
: out Boolean;
110 Skip_First
: Boolean := False);
111 -- Check one interpretation of an overloaded subprogram name for
112 -- compatibility with the types of the actuals in a call. If there is a
113 -- single interpretation which does not match, post error if Report is
116 -- Nam is the entity that provides the formals against which the actuals
117 -- are checked. Nam is either the name of a subprogram, or the internal
118 -- subprogram type constructed for an access_to_subprogram. If the actuals
119 -- are compatible with Nam, then Nam is added to the list of candidate
120 -- interpretations for N, and Success is set to True.
122 -- The flag Skip_First is used when analyzing a call that was rewritten
123 -- from object notation. In this case the first actual may have to receive
124 -- an explicit dereference, depending on the first formal of the operation
125 -- being called. The caller will have verified that the object is legal
126 -- for the call. If the remaining parameters match, the first parameter
127 -- will rewritten as a dereference if needed, prior to completing analysis.
129 procedure Check_Misspelled_Selector
132 -- Give possible misspelling diagnostic if Sel is likely to be a mis-
133 -- spelling of one of the selectors of the Prefix. This is called by
134 -- Analyze_Selected_Component after producing an invalid selector error
137 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean;
138 -- Verify that type T is declared in scope S. Used to find interpretations
139 -- for operators given by expanded names. This is abstracted as a separate
140 -- function to handle extensions to System, where S is System, but T is
141 -- declared in the extension.
143 procedure Find_Arithmetic_Types
147 -- L and R are the operands of an arithmetic operator. Find
148 -- consistent pairs of interpretations for L and R that have a
149 -- numeric type consistent with the semantics of the operator.
151 procedure Find_Comparison_Types
155 -- L and R are operands of a comparison operator. Find consistent
156 -- pairs of interpretations for L and R.
158 procedure Find_Concatenation_Types
162 -- For the four varieties of concatenation
164 procedure Find_Equality_Types
168 -- Ditto for equality operators
170 procedure Find_Boolean_Types
174 -- Ditto for binary logical operations
176 procedure Find_Negation_Types
180 -- Find consistent interpretation for operand of negation operator
182 procedure Find_Non_Universal_Interpretations
187 -- For equality and comparison operators, the result is always boolean,
188 -- and the legality of the operation is determined from the visibility
189 -- of the operand types. If one of the operands has a universal interpre-
190 -- tation, the legality check uses some compatible non-universal
191 -- interpretation of the other operand. N can be an operator node, or
192 -- a function call whose name is an operator designator.
194 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean;
195 -- Find candidate interpretations for the name Obj.Proc when it appears
196 -- in a subprogram renaming declaration.
198 procedure Find_Unary_Types
202 -- Unary arithmetic types: plus, minus, abs
204 procedure Check_Arithmetic_Pair
208 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
209 -- types for left and right operand. Determine whether they constitute
210 -- a valid pair for the given operator, and record the corresponding
211 -- interpretation of the operator node. The node N may be an operator
212 -- node (the usual case) or a function call whose prefix is an operator
213 -- designator. In both cases Op_Id is the operator name itself.
215 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
);
216 -- Give detailed information on overloaded call where none of the
217 -- interpretations match. N is the call node, Nam the designator for
218 -- the overloaded entity being called.
220 function Junk_Operand
(N
: Node_Id
) return Boolean;
221 -- Test for an operand that is an inappropriate entity (e.g. a package
222 -- name or a label). If so, issue an error message and return True. If
223 -- the operand is not an inappropriate entity kind, return False.
225 procedure Operator_Check
(N
: Node_Id
);
226 -- Verify that an operator has received some valid interpretation. If none
227 -- was found, determine whether a use clause would make the operation
228 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
229 -- every type compatible with the operator, even if the operator for the
230 -- type is not directly visible. The routine uses this type to emit a more
231 -- informative message.
233 function Process_Implicit_Dereference_Prefix
235 P
: Node_Id
) return Entity_Id
;
236 -- Called when P is the prefix of an implicit dereference, denoting an
237 -- object E. The function returns the designated type of the prefix, taking
238 -- into account that the designated type of an anonymous access type may be
239 -- a limited view, when the non-limited view is visible.
240 -- If in semantics only mode (-gnatc or generic), the function also records
241 -- that the prefix is a reference to E, if any. Normally, such a reference
242 -- is generated only when the implicit dereference is expanded into an
243 -- explicit one, but for consistency we must generate the reference when
244 -- expansion is disabled as well.
246 procedure Remove_Abstract_Operations
(N
: Node_Id
);
247 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
248 -- operation is not a candidate interpretation.
250 function Try_Indexed_Call
254 Skip_First
: Boolean) return Boolean;
255 -- If a function has defaults for all its actuals, a call to it may in fact
256 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
257 -- interpretation as an indexing, prior to analysis as a call. If both are
258 -- possible, the node is overloaded with both interpretations (same symbol
259 -- but two different types). If the call is written in prefix form, the
260 -- prefix becomes the first parameter in the call, and only the remaining
261 -- actuals must be checked for the presence of defaults.
263 function Try_Indirect_Call
266 Typ
: Entity_Id
) return Boolean;
267 -- Similarly, a function F that needs no actuals can return an access to a
268 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
269 -- the call may be overloaded with both interpretations.
271 function Try_Object_Operation
(N
: Node_Id
) return Boolean;
272 -- Ada 2005 (AI-252): Support the object.operation notation
274 procedure wpo
(T
: Entity_Id
);
275 pragma Warnings
(Off
, wpo
);
276 -- Used for debugging: obtain list of primitive operations even if
277 -- type is not frozen and dispatch table is not built yet.
279 ------------------------
280 -- Ambiguous_Operands --
281 ------------------------
283 procedure Ambiguous_Operands
(N
: Node_Id
) is
284 procedure List_Operand_Interps
(Opnd
: Node_Id
);
286 --------------------------
287 -- List_Operand_Interps --
288 --------------------------
290 procedure List_Operand_Interps
(Opnd
: Node_Id
) is
295 if Is_Overloaded
(Opnd
) then
296 if Nkind
(Opnd
) in N_Op
then
298 elsif Nkind
(Opnd
) = N_Function_Call
then
308 if Opnd
= Left_Opnd
(N
) then
309 Error_Msg_N
("\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
475 Def_Id
:= Make_Temporary
(Loc
, 'S');
478 Make_Subtype_Declaration
(Loc
,
479 Defining_Identifier
=> Def_Id
,
480 Subtype_Indication
=> Relocate_Node
(E
)));
482 if Sav_Errs
/= Serious_Errors_Detected
483 and then Nkind
(Constraint
(E
)) =
484 N_Index_Or_Discriminant_Constraint
486 Error_Msg_N
-- CODEFIX
487 ("if qualified expression was meant, " &
488 "use apostrophe!", Constraint
(E
));
491 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
492 Rewrite
(Expression
(N
), E
);
496 Type_Id
:= Process_Subtype
(E
, N
);
497 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
498 Set_Etype
(Acc_Type
, Acc_Type
);
499 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
500 Check_Fully_Declared
(Type_Id
, N
);
502 -- Ada 2005 (AI-231): If the designated type is itself an access
503 -- type that excludes null, its default initialization will
504 -- be a null object, and we can insert an unconditional raise
505 -- before the allocator.
507 if Can_Never_Be_Null
(Type_Id
) then
509 Not_Null_Check
: constant Node_Id
:=
510 Make_Raise_Constraint_Error
(Sloc
(E
),
511 Reason
=> CE_Null_Not_Allowed
);
513 if Expander_Active
then
514 Insert_Action
(N
, Not_Null_Check
);
515 Analyze
(Not_Null_Check
);
517 Error_Msg_N
("null value not allowed here?", E
);
522 -- Check restriction against dynamically allocated protected
523 -- objects. Note that when limited aggregates are supported,
524 -- a similar test should be applied to an allocator with a
525 -- qualified expression ???
527 if Is_Protected_Type
(Type_Id
) then
528 Check_Restriction
(No_Protected_Type_Allocators
, N
);
531 -- Check for missing initialization. Skip this check if we already
532 -- had errors on analyzing the allocator, since in that case these
533 -- are probably cascaded errors.
535 if Is_Indefinite_Subtype
(Type_Id
)
536 and then Serious_Errors_Detected
= Sav_Errs
538 if Is_Class_Wide_Type
(Type_Id
) then
540 ("initialization required in class-wide allocation", N
);
542 if Ada_Version
< Ada_05
543 and then Is_Limited_Type
(Type_Id
)
545 Error_Msg_N
("unconstrained allocation not allowed", N
);
547 if Is_Array_Type
(Type_Id
) then
549 ("\constraint with array bounds required", N
);
551 elsif Has_Unknown_Discriminants
(Type_Id
) then
554 else pragma Assert
(Has_Discriminants
(Type_Id
));
556 ("\constraint with discriminant values required", N
);
559 -- Limited Ada 2005 and general non-limited case
563 ("uninitialized unconstrained allocation not allowed",
566 if Is_Array_Type
(Type_Id
) then
568 ("\qualified expression or constraint with " &
569 "array bounds required", N
);
571 elsif Has_Unknown_Discriminants
(Type_Id
) then
572 Error_Msg_N
("\qualified expression required", N
);
574 else pragma Assert
(Has_Discriminants
(Type_Id
));
576 ("\qualified expression or constraint with " &
577 "discriminant values required", N
);
585 if Is_Abstract_Type
(Type_Id
) then
586 Error_Msg_N
("cannot allocate abstract object", E
);
589 if Has_Task
(Designated_Type
(Acc_Type
)) then
590 Check_Restriction
(No_Tasking
, N
);
591 Check_Restriction
(Max_Tasks
, N
);
592 Check_Restriction
(No_Task_Allocators
, N
);
595 -- If the No_Streams restriction is set, check that the type of the
596 -- object is not, and does not contain, any subtype derived from
597 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
598 -- Has_Stream just for efficiency reasons. There is no point in
599 -- spending time on a Has_Stream check if the restriction is not set.
601 if Restrictions
.Set
(No_Streams
) then
602 if Has_Stream
(Designated_Type
(Acc_Type
)) then
603 Check_Restriction
(No_Streams
, N
);
607 Set_Etype
(N
, Acc_Type
);
609 if not Is_Library_Level_Entity
(Acc_Type
) then
610 Check_Restriction
(No_Local_Allocators
, N
);
613 if Serious_Errors_Detected
> Sav_Errs
then
614 Set_Error_Posted
(N
);
615 Set_Etype
(N
, Any_Type
);
617 end Analyze_Allocator
;
619 ---------------------------
620 -- Analyze_Arithmetic_Op --
621 ---------------------------
623 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
624 L
: constant Node_Id
:= Left_Opnd
(N
);
625 R
: constant Node_Id
:= Right_Opnd
(N
);
629 Candidate_Type
:= Empty
;
630 Analyze_Expression
(L
);
631 Analyze_Expression
(R
);
633 -- If the entity is already set, the node is the instantiation of a
634 -- generic node with a non-local reference, or was manufactured by a
635 -- call to Make_Op_xxx. In either case the entity is known to be valid,
636 -- and we do not need to collect interpretations, instead we just get
637 -- the single possible interpretation.
641 if Present
(Op_Id
) then
642 if Ekind
(Op_Id
) = E_Operator
then
644 if Nkind_In
(N
, N_Op_Divide
, N_Op_Mod
, N_Op_Multiply
, N_Op_Rem
)
645 and then Treat_Fixed_As_Integer
(N
)
649 Set_Etype
(N
, Any_Type
);
650 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
654 Set_Etype
(N
, Any_Type
);
655 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
658 -- Entity is not already set, so we do need to collect interpretations
661 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
662 Set_Etype
(N
, Any_Type
);
664 while Present
(Op_Id
) loop
665 if Ekind
(Op_Id
) = E_Operator
666 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
668 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
670 -- The following may seem superfluous, because an operator cannot
671 -- be generic, but this ignores the cleverness of the author of
674 elsif Is_Overloadable
(Op_Id
) then
675 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
678 Op_Id
:= Homonym
(Op_Id
);
683 end Analyze_Arithmetic_Op
;
689 -- Function, procedure, and entry calls are checked here. The Name in
690 -- the call may be overloaded. The actuals have been analyzed and may
691 -- themselves be overloaded. On exit from this procedure, the node N
692 -- may have zero, one or more interpretations. In the first case an
693 -- error message is produced. In the last case, the node is flagged
694 -- as overloaded and the interpretations are collected in All_Interp.
696 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
697 -- the type-checking is similar to that of other calls.
699 procedure Analyze_Call
(N
: Node_Id
) is
700 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
705 Success
: Boolean := False;
707 Deref
: Boolean := False;
708 -- Flag indicates whether an interpretation of the prefix is a
709 -- parameterless call that returns an access_to_subprogram.
711 function Name_Denotes_Function
return Boolean;
712 -- If the type of the name is an access to subprogram, this may be the
713 -- type of a name, or the return type of the function being called. If
714 -- the name is not an entity then it can denote a protected function.
715 -- Until we distinguish Etype from Return_Type, we must use this routine
716 -- to resolve the meaning of the name in the call.
718 procedure No_Interpretation
;
719 -- Output error message when no valid interpretation exists
721 ---------------------------
722 -- Name_Denotes_Function --
723 ---------------------------
725 function Name_Denotes_Function
return Boolean is
727 if Is_Entity_Name
(Nam
) then
728 return Ekind
(Entity
(Nam
)) = E_Function
;
730 elsif Nkind
(Nam
) = N_Selected_Component
then
731 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
736 end Name_Denotes_Function
;
738 -----------------------
739 -- No_Interpretation --
740 -----------------------
742 procedure No_Interpretation
is
743 L
: constant Boolean := Is_List_Member
(N
);
744 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
747 -- If the node is in a list whose parent is not an expression then it
748 -- must be an attempted procedure call.
750 if L
and then K
not in N_Subexpr
then
751 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
753 ("must instantiate generic procedure& before call",
757 ("procedure or entry name expected", Nam
);
760 -- Check for tasking cases where only an entry call will do
763 and then Nkind_In
(K
, N_Entry_Call_Alternative
,
764 N_Triggering_Alternative
)
766 Error_Msg_N
("entry name expected", Nam
);
768 -- Otherwise give general error message
771 Error_Msg_N
("invalid prefix in call", Nam
);
773 end No_Interpretation
;
775 -- Start of processing for Analyze_Call
778 -- Initialize the type of the result of the call to the error type,
779 -- which will be reset if the type is successfully resolved.
781 Set_Etype
(N
, Any_Type
);
785 if not Is_Overloaded
(Nam
) then
787 -- Only one interpretation to check
789 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
790 Nam_Ent
:= Etype
(Nam
);
792 -- If the prefix is an access_to_subprogram, this may be an indirect
793 -- call. This is the case if the name in the call is not an entity
794 -- name, or if it is a function name in the context of a procedure
795 -- call. In this latter case, we have a call to a parameterless
796 -- function that returns a pointer_to_procedure which is the entity
797 -- being called. Finally, F (X) may be a call to a parameterless
798 -- function that returns a pointer to a function with parameters.
800 elsif Is_Access_Type
(Etype
(Nam
))
801 and then Ekind
(Designated_Type
(Etype
(Nam
))) = E_Subprogram_Type
803 (not Name_Denotes_Function
804 or else Nkind
(N
) = N_Procedure_Call_Statement
806 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
807 and then Is_Entity_Name
(Nam
)
808 and then No
(First_Formal
(Entity
(Nam
)))
809 and then Present
(Actuals
)))
811 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
812 Insert_Explicit_Dereference
(Nam
);
814 -- Selected component case. Simple entry or protected operation,
815 -- where the entry name is given by the selector name.
817 elsif Nkind
(Nam
) = N_Selected_Component
then
818 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
820 if not Ekind_In
(Nam_Ent
, E_Entry
,
825 Error_Msg_N
("name in call is not a callable entity", Nam
);
826 Set_Etype
(N
, Any_Type
);
830 -- If the name is an Indexed component, it can be a call to a member
831 -- of an entry family. The prefix must be a selected component whose
832 -- selector is the entry. Analyze_Procedure_Call normalizes several
833 -- kinds of call into this form.
835 elsif Nkind
(Nam
) = N_Indexed_Component
then
836 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
837 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
839 Error_Msg_N
("name in call is not a callable entity", Nam
);
840 Set_Etype
(N
, Any_Type
);
844 elsif not Is_Entity_Name
(Nam
) then
845 Error_Msg_N
("name in call is not a callable entity", Nam
);
846 Set_Etype
(N
, Any_Type
);
850 Nam_Ent
:= Entity
(Nam
);
852 -- If no interpretations, give error message
854 if not Is_Overloadable
(Nam_Ent
) then
860 -- Operations generated for RACW stub types are called only through
861 -- dispatching, and can never be the static interpretation of a call.
863 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
868 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
870 -- If this is an indirect call, the return type of the access_to
871 -- subprogram may be an incomplete type. At the point of the call,
872 -- use the full type if available, and at the same time update
873 -- the return type of the access_to_subprogram.
876 and then Nkind
(Nam
) = N_Explicit_Dereference
877 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
878 and then Present
(Full_View
(Etype
(N
)))
880 Set_Etype
(N
, Full_View
(Etype
(N
)));
881 Set_Etype
(Nam_Ent
, Etype
(N
));
885 -- An overloaded selected component must denote overloaded operations
886 -- of a concurrent type. The interpretations are attached to the
887 -- simple name of those operations.
889 if Nkind
(Nam
) = N_Selected_Component
then
890 Nam
:= Selector_Name
(Nam
);
893 Get_First_Interp
(Nam
, X
, It
);
895 while Present
(It
.Nam
) loop
899 -- Name may be call that returns an access to subprogram, or more
900 -- generally an overloaded expression one of whose interpretations
901 -- yields an access to subprogram. If the name is an entity, we
902 -- do not dereference, because the node is a call that returns
903 -- the access type: note difference between f(x), where the call
904 -- may return an access subprogram type, and f(x)(y), where the
905 -- type returned by the call to f is implicitly dereferenced to
906 -- analyze the outer call.
908 if Is_Access_Type
(Nam_Ent
) then
909 Nam_Ent
:= Designated_Type
(Nam_Ent
);
911 elsif Is_Access_Type
(Etype
(Nam_Ent
))
913 (not Is_Entity_Name
(Nam
)
914 or else Nkind
(N
) = N_Procedure_Call_Statement
)
915 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
918 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
920 if Is_Entity_Name
(Nam
) then
925 -- If the call has been rewritten from a prefixed call, the first
926 -- parameter has been analyzed, but may need a subsequent
927 -- dereference, so skip its analysis now.
929 if N
/= Original_Node
(N
)
930 and then Nkind
(Original_Node
(N
)) = Nkind
(N
)
931 and then Nkind
(Name
(N
)) /= Nkind
(Name
(Original_Node
(N
)))
932 and then Present
(Parameter_Associations
(N
))
933 and then Present
(Etype
(First
(Parameter_Associations
(N
))))
936 (N
, Nam_Ent
, False, Success
, Skip_First
=> True);
938 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
941 -- If the interpretation succeeds, mark the proper type of the
942 -- prefix (any valid candidate will do). If not, remove the
943 -- candidate interpretation. This only needs to be done for
944 -- overloaded protected operations, for other entities disambi-
945 -- guation is done directly in Resolve.
949 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
951 Set_Entity
(Nam
, It
.Nam
);
952 Insert_Explicit_Dereference
(Nam
);
953 Set_Etype
(Nam
, Nam_Ent
);
956 Set_Etype
(Nam
, It
.Typ
);
959 elsif Nkind_In
(Name
(N
), N_Selected_Component
,
965 Get_Next_Interp
(X
, It
);
968 -- If the name is the result of a function call, it can only
969 -- be a call to a function returning an access to subprogram.
970 -- Insert explicit dereference.
972 if Nkind
(Nam
) = N_Function_Call
then
973 Insert_Explicit_Dereference
(Nam
);
976 if Etype
(N
) = Any_Type
then
978 -- None of the interpretations is compatible with the actuals
980 Diagnose_Call
(N
, Nam
);
982 -- Special checks for uninstantiated put routines
984 if Nkind
(N
) = N_Procedure_Call_Statement
985 and then Is_Entity_Name
(Nam
)
986 and then Chars
(Nam
) = Name_Put
987 and then List_Length
(Actuals
) = 1
990 Arg
: constant Node_Id
:= First
(Actuals
);
994 if Nkind
(Arg
) = N_Parameter_Association
then
995 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
1000 if Is_Signed_Integer_Type
(Typ
) then
1002 ("possible missing instantiation of " &
1003 "'Text_'I'O.'Integer_'I'O!", Nam
);
1005 elsif Is_Modular_Integer_Type
(Typ
) then
1007 ("possible missing instantiation of " &
1008 "'Text_'I'O.'Modular_'I'O!", Nam
);
1010 elsif Is_Floating_Point_Type
(Typ
) then
1012 ("possible missing instantiation of " &
1013 "'Text_'I'O.'Float_'I'O!", Nam
);
1015 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1017 ("possible missing instantiation of " &
1018 "'Text_'I'O.'Fixed_'I'O!", Nam
);
1020 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1022 ("possible missing instantiation of " &
1023 "'Text_'I'O.'Decimal_'I'O!", Nam
);
1025 elsif Is_Enumeration_Type
(Typ
) then
1027 ("possible missing instantiation of " &
1028 "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1033 elsif not Is_Overloaded
(N
)
1034 and then Is_Entity_Name
(Nam
)
1036 -- Resolution yields a single interpretation. Verify that the
1037 -- reference has capitalization consistent with the declaration.
1039 Set_Entity_With_Style_Check
(Nam
, Entity
(Nam
));
1040 Generate_Reference
(Entity
(Nam
), Nam
);
1042 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1044 Remove_Abstract_Operations
(N
);
1051 -----------------------------
1052 -- Analyze_Case_Expression --
1053 -----------------------------
1055 procedure Analyze_Case_Expression
(N
: Node_Id
) is
1056 Expr
: constant Node_Id
:= Expression
(N
);
1057 FirstX
: constant Node_Id
:= Expression
(First
(Alternatives
(N
)));
1059 Exp_Type
: Entity_Id
;
1060 Exp_Btype
: Entity_Id
;
1063 Dont_Care
: Boolean;
1064 Others_Present
: Boolean;
1066 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
1067 -- Error routine invoked by the generic instantiation below when
1068 -- the case expression has a non static choice.
1070 package Case_Choices_Processing
is new
1071 Generic_Choices_Processing
1072 (Get_Alternatives
=> Alternatives
,
1073 Get_Choices
=> Discrete_Choices
,
1074 Process_Empty_Choice
=> No_OP
,
1075 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
1076 Process_Associated_Node
=> No_OP
);
1077 use Case_Choices_Processing
;
1079 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
1081 -----------------------------
1082 -- Non_Static_Choice_Error --
1083 -----------------------------
1085 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
1087 Flag_Non_Static_Expr
1088 ("choice given in case expression is not static!", Choice
);
1089 end Non_Static_Choice_Error
;
1091 -- Start of processing for Analyze_Case_Expression
1094 if Comes_From_Source
(N
) then
1095 Check_Compiler_Unit
(N
);
1098 Analyze_And_Resolve
(Expr
, Any_Discrete
);
1099 Check_Unset_Reference
(Expr
);
1100 Exp_Type
:= Etype
(Expr
);
1101 Exp_Btype
:= Base_Type
(Exp_Type
);
1103 Alt
:= First
(Alternatives
(N
));
1104 while Present
(Alt
) loop
1105 Analyze
(Expression
(Alt
));
1109 if not Is_Overloaded
(FirstX
) then
1110 Set_Etype
(N
, Etype
(FirstX
));
1118 Set_Etype
(N
, Any_Type
);
1120 Get_First_Interp
(FirstX
, I
, It
);
1121 while Present
(It
.Nam
) loop
1123 -- For each intepretation of the first expression, we only
1124 -- add the intepretation if every other expression in the
1125 -- case expression alternatives has a compatible type.
1127 Alt
:= Next
(First
(Alternatives
(N
)));
1128 while Present
(Alt
) loop
1129 exit when not Has_Compatible_Type
(Expression
(Alt
), It
.Typ
);
1134 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1137 Get_Next_Interp
(I
, It
);
1142 Exp_Btype
:= Base_Type
(Exp_Type
);
1144 -- The expression must be of a discrete type which must be determinable
1145 -- independently of the context in which the expression occurs, but
1146 -- using the fact that the expression must be of a discrete type.
1147 -- Moreover, the type this expression must not be a character literal
1148 -- (which is always ambiguous).
1150 -- If error already reported by Resolve, nothing more to do
1152 if Exp_Btype
= Any_Discrete
1153 or else Exp_Btype
= Any_Type
1157 elsif Exp_Btype
= Any_Character
then
1159 ("character literal as case expression is ambiguous", Expr
);
1163 -- If the case expression is a formal object of mode in out, then
1164 -- treat it as having a nonstatic subtype by forcing use of the base
1165 -- type (which has to get passed to Check_Case_Choices below). Also
1166 -- use base type when the case expression is parenthesized.
1168 if Paren_Count
(Expr
) > 0
1169 or else (Is_Entity_Name
(Expr
)
1170 and then Ekind
(Entity
(Expr
)) = E_Generic_In_Out_Parameter
)
1172 Exp_Type
:= Exp_Btype
;
1175 -- Call instantiated Analyze_Choices which does the rest of the work
1178 (N
, Exp_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
1180 if Exp_Type
= Universal_Integer
and then not Others_Present
then
1182 ("case on universal integer requires OTHERS choice", Expr
);
1184 end Analyze_Case_Expression
;
1186 ---------------------------
1187 -- Analyze_Comparison_Op --
1188 ---------------------------
1190 procedure Analyze_Comparison_Op
(N
: Node_Id
) is
1191 L
: constant Node_Id
:= Left_Opnd
(N
);
1192 R
: constant Node_Id
:= Right_Opnd
(N
);
1193 Op_Id
: Entity_Id
:= Entity
(N
);
1196 Set_Etype
(N
, Any_Type
);
1197 Candidate_Type
:= Empty
;
1199 Analyze_Expression
(L
);
1200 Analyze_Expression
(R
);
1202 if Present
(Op_Id
) then
1203 if Ekind
(Op_Id
) = E_Operator
then
1204 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1206 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1209 if Is_Overloaded
(L
) then
1210 Set_Etype
(L
, Intersect_Types
(L
, R
));
1214 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1215 while Present
(Op_Id
) loop
1216 if Ekind
(Op_Id
) = E_Operator
then
1217 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1219 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1222 Op_Id
:= Homonym
(Op_Id
);
1227 end Analyze_Comparison_Op
;
1229 ---------------------------
1230 -- Analyze_Concatenation --
1231 ---------------------------
1233 procedure Analyze_Concatenation
(N
: Node_Id
) is
1235 -- We wish to avoid deep recursion, because concatenations are often
1236 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1237 -- operands nonrecursively until we find something that is not a
1238 -- concatenation (A in this case), or has already been analyzed. We
1239 -- analyze that, and then walk back up the tree following Parent
1240 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1241 -- work at each level. The Parent pointers allow us to avoid recursion,
1242 -- and thus avoid running out of memory.
1248 Candidate_Type
:= Empty
;
1250 -- The following code is equivalent to:
1252 -- Set_Etype (N, Any_Type);
1253 -- Analyze_Expression (Left_Opnd (N));
1254 -- Analyze_Concatenation_Rest (N);
1256 -- where the Analyze_Expression call recurses back here if the left
1257 -- operand is a concatenation.
1259 -- Walk down left operands
1262 Set_Etype
(NN
, Any_Type
);
1263 L
:= Left_Opnd
(NN
);
1264 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1268 -- Now (given the above example) NN is A&B and L is A
1270 -- First analyze L ...
1272 Analyze_Expression
(L
);
1274 -- ... then walk NN back up until we reach N (where we started), calling
1275 -- Analyze_Concatenation_Rest along the way.
1278 Analyze_Concatenation_Rest
(NN
);
1282 end Analyze_Concatenation
;
1284 --------------------------------
1285 -- Analyze_Concatenation_Rest --
1286 --------------------------------
1288 -- If the only one-dimensional array type in scope is String,
1289 -- this is the resulting type of the operation. Otherwise there
1290 -- will be a concatenation operation defined for each user-defined
1291 -- one-dimensional array.
1293 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1294 L
: constant Node_Id
:= Left_Opnd
(N
);
1295 R
: constant Node_Id
:= Right_Opnd
(N
);
1296 Op_Id
: Entity_Id
:= Entity
(N
);
1301 Analyze_Expression
(R
);
1303 -- If the entity is present, the node appears in an instance, and
1304 -- denotes a predefined concatenation operation. The resulting type is
1305 -- obtained from the arguments when possible. If the arguments are
1306 -- aggregates, the array type and the concatenation type must be
1309 if Present
(Op_Id
) then
1310 if Ekind
(Op_Id
) = E_Operator
then
1311 LT
:= Base_Type
(Etype
(L
));
1312 RT
:= Base_Type
(Etype
(R
));
1314 if Is_Array_Type
(LT
)
1315 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1317 Add_One_Interp
(N
, Op_Id
, LT
);
1319 elsif Is_Array_Type
(RT
)
1320 and then LT
= Base_Type
(Component_Type
(RT
))
1322 Add_One_Interp
(N
, Op_Id
, RT
);
1324 -- If one operand is a string type or a user-defined array type,
1325 -- and the other is a literal, result is of the specific type.
1328 (Root_Type
(LT
) = Standard_String
1329 or else Scope
(LT
) /= Standard_Standard
)
1330 and then Etype
(R
) = Any_String
1332 Add_One_Interp
(N
, Op_Id
, LT
);
1335 (Root_Type
(RT
) = Standard_String
1336 or else Scope
(RT
) /= Standard_Standard
)
1337 and then Etype
(L
) = Any_String
1339 Add_One_Interp
(N
, Op_Id
, RT
);
1341 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
1342 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1345 -- Type and its operations must be visible
1347 Set_Entity
(N
, Empty
);
1348 Analyze_Concatenation
(N
);
1352 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1356 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
1357 while Present
(Op_Id
) loop
1358 if Ekind
(Op_Id
) = E_Operator
then
1360 -- Do not consider operators declared in dead code, they can
1361 -- not be part of the resolution.
1363 if Is_Eliminated
(Op_Id
) then
1366 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
1370 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1373 Op_Id
:= Homonym
(Op_Id
);
1378 end Analyze_Concatenation_Rest
;
1380 ------------------------------------
1381 -- Analyze_Conditional_Expression --
1382 ------------------------------------
1384 procedure Analyze_Conditional_Expression
(N
: Node_Id
) is
1385 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1386 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1387 Else_Expr
: Node_Id
;
1390 -- Defend against error of missing expressions from previous error
1392 if No
(Then_Expr
) then
1396 Else_Expr
:= Next
(Then_Expr
);
1398 if Comes_From_Source
(N
) then
1399 Check_Compiler_Unit
(N
);
1402 Analyze_Expression
(Condition
);
1403 Analyze_Expression
(Then_Expr
);
1405 if Present
(Else_Expr
) then
1406 Analyze_Expression
(Else_Expr
);
1409 -- If then expression not overloaded, then that decides the type
1411 if not Is_Overloaded
(Then_Expr
) then
1412 Set_Etype
(N
, Etype
(Then_Expr
));
1414 -- Case where then expression is overloaded
1422 Set_Etype
(N
, Any_Type
);
1423 Get_First_Interp
(Then_Expr
, I
, It
);
1424 while Present
(It
.Nam
) loop
1426 -- For each possible intepretation of the Then Expression,
1427 -- add it only if the else expression has a compatible type.
1429 -- Is this right if Else_Expr is empty?
1431 if Has_Compatible_Type
(Else_Expr
, It
.Typ
) then
1432 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1435 Get_Next_Interp
(I
, It
);
1439 end Analyze_Conditional_Expression
;
1441 -------------------------
1442 -- Analyze_Equality_Op --
1443 -------------------------
1445 procedure Analyze_Equality_Op
(N
: Node_Id
) is
1446 Loc
: constant Source_Ptr
:= Sloc
(N
);
1447 L
: constant Node_Id
:= Left_Opnd
(N
);
1448 R
: constant Node_Id
:= Right_Opnd
(N
);
1452 Set_Etype
(N
, Any_Type
);
1453 Candidate_Type
:= Empty
;
1455 Analyze_Expression
(L
);
1456 Analyze_Expression
(R
);
1458 -- If the entity is set, the node is a generic instance with a non-local
1459 -- reference to the predefined operator or to a user-defined function.
1460 -- It can also be an inequality that is expanded into the negation of a
1461 -- call to a user-defined equality operator.
1463 -- For the predefined case, the result is Boolean, regardless of the
1464 -- type of the operands. The operands may even be limited, if they are
1465 -- generic actuals. If they are overloaded, label the left argument with
1466 -- the common type that must be present, or with the type of the formal
1467 -- of the user-defined function.
1469 if Present
(Entity
(N
)) then
1470 Op_Id
:= Entity
(N
);
1472 if Ekind
(Op_Id
) = E_Operator
then
1473 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
1475 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1478 if Is_Overloaded
(L
) then
1479 if Ekind
(Op_Id
) = E_Operator
then
1480 Set_Etype
(L
, Intersect_Types
(L
, R
));
1482 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
1487 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1488 while Present
(Op_Id
) loop
1489 if Ekind
(Op_Id
) = E_Operator
then
1490 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1492 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1495 Op_Id
:= Homonym
(Op_Id
);
1499 -- If there was no match, and the operator is inequality, this may
1500 -- be a case where inequality has not been made explicit, as for
1501 -- tagged types. Analyze the node as the negation of an equality
1502 -- operation. This cannot be done earlier, because before analysis
1503 -- we cannot rule out the presence of an explicit inequality.
1505 if Etype
(N
) = Any_Type
1506 and then Nkind
(N
) = N_Op_Ne
1508 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
1509 while Present
(Op_Id
) loop
1510 if Ekind
(Op_Id
) = E_Operator
then
1511 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1513 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1516 Op_Id
:= Homonym
(Op_Id
);
1519 if Etype
(N
) /= Any_Type
then
1520 Op_Id
:= Entity
(N
);
1526 Left_Opnd
=> Left_Opnd
(N
),
1527 Right_Opnd
=> Right_Opnd
(N
))));
1529 Set_Entity
(Right_Opnd
(N
), Op_Id
);
1535 end Analyze_Equality_Op
;
1537 ----------------------------------
1538 -- Analyze_Explicit_Dereference --
1539 ----------------------------------
1541 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
1542 Loc
: constant Source_Ptr
:= Sloc
(N
);
1543 P
: constant Node_Id
:= Prefix
(N
);
1549 function Is_Function_Type
return Boolean;
1550 -- Check whether node may be interpreted as an implicit function call
1552 ----------------------
1553 -- Is_Function_Type --
1554 ----------------------
1556 function Is_Function_Type
return Boolean is
1561 if not Is_Overloaded
(N
) then
1562 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
1563 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
1566 Get_First_Interp
(N
, I
, It
);
1567 while Present
(It
.Nam
) loop
1568 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
1569 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
1574 Get_Next_Interp
(I
, It
);
1579 end Is_Function_Type
;
1581 -- Start of processing for Analyze_Explicit_Dereference
1585 Set_Etype
(N
, Any_Type
);
1587 -- Test for remote access to subprogram type, and if so return
1588 -- after rewriting the original tree.
1590 if Remote_AST_E_Dereference
(P
) then
1594 -- Normal processing for other than remote access to subprogram type
1596 if not Is_Overloaded
(P
) then
1597 if Is_Access_Type
(Etype
(P
)) then
1599 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
1600 -- avoid other problems caused by the Private_Subtype and it is
1601 -- safe to go to the Base_Type because this is the same as
1602 -- converting the access value to its Base_Type.
1605 DT
: Entity_Id
:= Designated_Type
(Etype
(P
));
1608 if Ekind
(DT
) = E_Private_Subtype
1609 and then Is_For_Access_Subtype
(DT
)
1611 DT
:= Base_Type
(DT
);
1614 -- An explicit dereference is a legal occurrence of an
1615 -- incomplete type imported through a limited_with clause,
1616 -- if the full view is visible.
1618 if From_With_Type
(DT
)
1619 and then not From_With_Type
(Scope
(DT
))
1621 (Is_Immediately_Visible
(Scope
(DT
))
1623 (Is_Child_Unit
(Scope
(DT
))
1624 and then Is_Visible_Child_Unit
(Scope
(DT
))))
1626 Set_Etype
(N
, Available_View
(DT
));
1633 elsif Etype
(P
) /= Any_Type
then
1634 Error_Msg_N
("prefix of dereference must be an access type", N
);
1639 Get_First_Interp
(P
, I
, It
);
1640 while Present
(It
.Nam
) loop
1643 if Is_Access_Type
(T
) then
1644 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
1647 Get_Next_Interp
(I
, It
);
1650 -- Error if no interpretation of the prefix has an access type
1652 if Etype
(N
) = Any_Type
then
1654 ("access type required in prefix of explicit dereference", P
);
1655 Set_Etype
(N
, Any_Type
);
1661 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
1663 and then (Nkind
(Parent
(N
)) /= N_Function_Call
1664 or else N
/= Name
(Parent
(N
)))
1666 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1667 or else N
/= Name
(Parent
(N
)))
1669 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
1670 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
1672 (Attribute_Name
(Parent
(N
)) /= Name_Address
1674 Attribute_Name
(Parent
(N
)) /= Name_Access
))
1676 -- Name is a function call with no actuals, in a context that
1677 -- requires deproceduring (including as an actual in an enclosing
1678 -- function or procedure call). There are some pathological cases
1679 -- where the prefix might include functions that return access to
1680 -- subprograms and others that return a regular type. Disambiguation
1681 -- of those has to take place in Resolve.
1684 Make_Function_Call
(Loc
,
1685 Name
=> Make_Explicit_Dereference
(Loc
, P
),
1686 Parameter_Associations
=> New_List
);
1688 -- If the prefix is overloaded, remove operations that have formals,
1689 -- we know that this is a parameterless call.
1691 if Is_Overloaded
(P
) then
1692 Get_First_Interp
(P
, I
, It
);
1693 while Present
(It
.Nam
) loop
1696 if No
(First_Formal
(Base_Type
(Designated_Type
(T
)))) then
1702 Get_Next_Interp
(I
, It
);
1709 elsif not Is_Function_Type
1710 and then Is_Overloaded
(N
)
1712 -- The prefix may include access to subprograms and other access
1713 -- types. If the context selects the interpretation that is a
1714 -- function call (not a procedure call) we cannot rewrite the node
1715 -- yet, but we include the result of the call interpretation.
1717 Get_First_Interp
(N
, I
, It
);
1718 while Present
(It
.Nam
) loop
1719 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
1720 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
1721 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1723 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
1726 Get_Next_Interp
(I
, It
);
1730 -- A value of remote access-to-class-wide must not be dereferenced
1733 Validate_Remote_Access_To_Class_Wide_Type
(N
);
1734 end Analyze_Explicit_Dereference
;
1736 ------------------------
1737 -- Analyze_Expression --
1738 ------------------------
1740 procedure Analyze_Expression
(N
: Node_Id
) is
1743 Check_Parameterless_Call
(N
);
1744 end Analyze_Expression
;
1746 -------------------------------------
1747 -- Analyze_Expression_With_Actions --
1748 -------------------------------------
1750 procedure Analyze_Expression_With_Actions
(N
: Node_Id
) is
1754 A
:= First
(Actions
(N
));
1761 Analyze_Expression
(Expression
(N
));
1762 Set_Etype
(N
, Etype
(Expression
(N
)));
1763 end Analyze_Expression_With_Actions
;
1765 ------------------------------------
1766 -- Analyze_Indexed_Component_Form --
1767 ------------------------------------
1769 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
1770 P
: constant Node_Id
:= Prefix
(N
);
1771 Exprs
: constant List_Id
:= Expressions
(N
);
1777 procedure Process_Function_Call
;
1778 -- Prefix in indexed component form is an overloadable entity,
1779 -- so the node is a function call. Reformat it as such.
1781 procedure Process_Indexed_Component
;
1782 -- Prefix in indexed component form is actually an indexed component.
1783 -- This routine processes it, knowing that the prefix is already
1786 procedure Process_Indexed_Component_Or_Slice
;
1787 -- An indexed component with a single index may designate a slice if
1788 -- the index is a subtype mark. This routine disambiguates these two
1789 -- cases by resolving the prefix to see if it is a subtype mark.
1791 procedure Process_Overloaded_Indexed_Component
;
1792 -- If the prefix of an indexed component is overloaded, the proper
1793 -- interpretation is selected by the index types and the context.
1795 ---------------------------
1796 -- Process_Function_Call --
1797 ---------------------------
1799 procedure Process_Function_Call
is
1803 Change_Node
(N
, N_Function_Call
);
1805 Set_Parameter_Associations
(N
, Exprs
);
1807 -- Analyze actuals prior to analyzing the call itself
1809 Actual
:= First
(Parameter_Associations
(N
));
1810 while Present
(Actual
) loop
1812 Check_Parameterless_Call
(Actual
);
1814 -- Move to next actual. Note that we use Next, not Next_Actual
1815 -- here. The reason for this is a bit subtle. If a function call
1816 -- includes named associations, the parser recognizes the node as
1817 -- a call, and it is analyzed as such. If all associations are
1818 -- positional, the parser builds an indexed_component node, and
1819 -- it is only after analysis of the prefix that the construct
1820 -- is recognized as a call, in which case Process_Function_Call
1821 -- rewrites the node and analyzes the actuals. If the list of
1822 -- actuals is malformed, the parser may leave the node as an
1823 -- indexed component (despite the presence of named associations).
1824 -- The iterator Next_Actual is equivalent to Next if the list is
1825 -- positional, but follows the normalized chain of actuals when
1826 -- named associations are present. In this case normalization has
1827 -- not taken place, and actuals remain unanalyzed, which leads to
1828 -- subsequent crashes or loops if there is an attempt to continue
1829 -- analysis of the program.
1835 end Process_Function_Call
;
1837 -------------------------------
1838 -- Process_Indexed_Component --
1839 -------------------------------
1841 procedure Process_Indexed_Component
is
1843 Array_Type
: Entity_Id
;
1845 Pent
: Entity_Id
:= Empty
;
1848 Exp
:= First
(Exprs
);
1850 if Is_Overloaded
(P
) then
1851 Process_Overloaded_Indexed_Component
;
1854 Array_Type
:= Etype
(P
);
1856 if Is_Entity_Name
(P
) then
1858 elsif Nkind
(P
) = N_Selected_Component
1859 and then Is_Entity_Name
(Selector_Name
(P
))
1861 Pent
:= Entity
(Selector_Name
(P
));
1864 -- Prefix must be appropriate for an array type, taking into
1865 -- account a possible implicit dereference.
1867 if Is_Access_Type
(Array_Type
) then
1868 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
1869 Array_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, P
);
1872 if Is_Array_Type
(Array_Type
) then
1875 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
1877 Set_Etype
(N
, Any_Type
);
1879 if not Has_Compatible_Type
1880 (Exp
, Entry_Index_Type
(Pent
))
1882 Error_Msg_N
("invalid index type in entry name", N
);
1884 elsif Present
(Next
(Exp
)) then
1885 Error_Msg_N
("too many subscripts in entry reference", N
);
1888 Set_Etype
(N
, Etype
(P
));
1893 elsif Is_Record_Type
(Array_Type
)
1894 and then Remote_AST_I_Dereference
(P
)
1898 elsif Array_Type
= Any_Type
then
1899 Set_Etype
(N
, Any_Type
);
1901 -- In most cases the analysis of the prefix will have emitted
1902 -- an error already, but if the prefix may be interpreted as a
1903 -- call in prefixed notation, the report is left to the caller.
1904 -- To prevent cascaded errors, report only if no previous ones.
1906 if Serious_Errors_Detected
= 0 then
1907 Error_Msg_N
("invalid prefix in indexed component", P
);
1909 if Nkind
(P
) = N_Expanded_Name
then
1910 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
1916 -- Here we definitely have a bad indexing
1919 if Nkind
(Parent
(N
)) = N_Requeue_Statement
1920 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
1923 ("REQUEUE does not permit parameters", First
(Exprs
));
1925 elsif Is_Entity_Name
(P
)
1926 and then Etype
(P
) = Standard_Void_Type
1928 Error_Msg_NE
("incorrect use of&", P
, Entity
(P
));
1931 Error_Msg_N
("array type required in indexed component", P
);
1934 Set_Etype
(N
, Any_Type
);
1938 Index
:= First_Index
(Array_Type
);
1939 while Present
(Index
) and then Present
(Exp
) loop
1940 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
1941 Wrong_Type
(Exp
, Etype
(Index
));
1942 Set_Etype
(N
, Any_Type
);
1950 Set_Etype
(N
, Component_Type
(Array_Type
));
1952 if Present
(Index
) then
1954 ("too few subscripts in array reference", First
(Exprs
));
1956 elsif Present
(Exp
) then
1957 Error_Msg_N
("too many subscripts in array reference", Exp
);
1960 end Process_Indexed_Component
;
1962 ----------------------------------------
1963 -- Process_Indexed_Component_Or_Slice --
1964 ----------------------------------------
1966 procedure Process_Indexed_Component_Or_Slice
is
1968 Exp
:= First
(Exprs
);
1969 while Present
(Exp
) loop
1970 Analyze_Expression
(Exp
);
1974 Exp
:= First
(Exprs
);
1976 -- If one index is present, and it is a subtype name, then the
1977 -- node denotes a slice (note that the case of an explicit range
1978 -- for a slice was already built as an N_Slice node in the first
1979 -- place, so that case is not handled here).
1981 -- We use a replace rather than a rewrite here because this is one
1982 -- of the cases in which the tree built by the parser is plain wrong.
1985 and then Is_Entity_Name
(Exp
)
1986 and then Is_Type
(Entity
(Exp
))
1989 Make_Slice
(Sloc
(N
),
1991 Discrete_Range
=> New_Copy
(Exp
)));
1994 -- Otherwise (more than one index present, or single index is not
1995 -- a subtype name), then we have the indexed component case.
1998 Process_Indexed_Component
;
2000 end Process_Indexed_Component_Or_Slice
;
2002 ------------------------------------------
2003 -- Process_Overloaded_Indexed_Component --
2004 ------------------------------------------
2006 procedure Process_Overloaded_Indexed_Component
is
2015 Set_Etype
(N
, Any_Type
);
2017 Get_First_Interp
(P
, I
, It
);
2018 while Present
(It
.Nam
) loop
2021 if Is_Access_Type
(Typ
) then
2022 Typ
:= Designated_Type
(Typ
);
2023 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
2026 if Is_Array_Type
(Typ
) then
2028 -- Got a candidate: verify that index types are compatible
2030 Index
:= First_Index
(Typ
);
2032 Exp
:= First
(Exprs
);
2033 while Present
(Index
) and then Present
(Exp
) loop
2034 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2046 if Found
and then No
(Index
) and then No
(Exp
) then
2048 Etype
(Component_Type
(Typ
)),
2049 Etype
(Component_Type
(Typ
)));
2053 Get_Next_Interp
(I
, It
);
2056 if Etype
(N
) = Any_Type
then
2057 Error_Msg_N
("no legal interpretation for indexed component", N
);
2058 Set_Is_Overloaded
(N
, False);
2062 end Process_Overloaded_Indexed_Component
;
2064 -- Start of processing for Analyze_Indexed_Component_Form
2067 -- Get name of array, function or type
2071 if Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
) then
2073 -- If P is an explicit dereference whose prefix is of a
2074 -- remote access-to-subprogram type, then N has already
2075 -- been rewritten as a subprogram call and analyzed.
2080 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
2082 P_T
:= Base_Type
(Etype
(P
));
2084 if Is_Entity_Name
(P
)
2085 or else Nkind
(P
) = N_Operator_Symbol
2089 if Is_Type
(U_N
) then
2091 -- Reformat node as a type conversion
2093 E
:= Remove_Head
(Exprs
);
2095 if Present
(First
(Exprs
)) then
2097 ("argument of type conversion must be single expression", N
);
2100 Change_Node
(N
, N_Type_Conversion
);
2101 Set_Subtype_Mark
(N
, P
);
2103 Set_Expression
(N
, E
);
2105 -- After changing the node, call for the specific Analysis
2106 -- routine directly, to avoid a double call to the expander.
2108 Analyze_Type_Conversion
(N
);
2112 if Is_Overloadable
(U_N
) then
2113 Process_Function_Call
;
2115 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
2116 or else (Is_Access_Type
(Etype
(P
))
2118 Ekind
(Designated_Type
(Etype
(P
))) =
2121 -- Call to access_to-subprogram with possible implicit dereference
2123 Process_Function_Call
;
2125 elsif Is_Generic_Subprogram
(U_N
) then
2127 -- A common beginner's (or C++ templates fan) error
2129 Error_Msg_N
("generic subprogram cannot be called", N
);
2130 Set_Etype
(N
, Any_Type
);
2134 Process_Indexed_Component_Or_Slice
;
2137 -- If not an entity name, prefix is an expression that may denote
2138 -- an array or an access-to-subprogram.
2141 if Ekind
(P_T
) = E_Subprogram_Type
2142 or else (Is_Access_Type
(P_T
)
2144 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
2146 Process_Function_Call
;
2148 elsif Nkind
(P
) = N_Selected_Component
2149 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
2151 Process_Function_Call
;
2154 -- Indexed component, slice, or a call to a member of a family
2155 -- entry, which will be converted to an entry call later.
2157 Process_Indexed_Component_Or_Slice
;
2160 end Analyze_Indexed_Component_Form
;
2162 ------------------------
2163 -- Analyze_Logical_Op --
2164 ------------------------
2166 procedure Analyze_Logical_Op
(N
: Node_Id
) is
2167 L
: constant Node_Id
:= Left_Opnd
(N
);
2168 R
: constant Node_Id
:= Right_Opnd
(N
);
2169 Op_Id
: Entity_Id
:= Entity
(N
);
2172 Set_Etype
(N
, Any_Type
);
2173 Candidate_Type
:= Empty
;
2175 Analyze_Expression
(L
);
2176 Analyze_Expression
(R
);
2178 if Present
(Op_Id
) then
2180 if Ekind
(Op_Id
) = E_Operator
then
2181 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2183 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2187 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2188 while Present
(Op_Id
) loop
2189 if Ekind
(Op_Id
) = E_Operator
then
2190 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2192 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2195 Op_Id
:= Homonym
(Op_Id
);
2200 end Analyze_Logical_Op
;
2202 ---------------------------
2203 -- Analyze_Membership_Op --
2204 ---------------------------
2206 procedure Analyze_Membership_Op
(N
: Node_Id
) is
2207 L
: constant Node_Id
:= Left_Opnd
(N
);
2208 R
: constant Node_Id
:= Right_Opnd
(N
);
2210 Index
: Interp_Index
;
2212 Found
: Boolean := False;
2216 procedure Try_One_Interp
(T1
: Entity_Id
);
2217 -- Routine to try one proposed interpretation. Note that the context
2218 -- of the operation plays no role in resolving the arguments, so that
2219 -- if there is more than one interpretation of the operands that is
2220 -- compatible with a membership test, the operation is ambiguous.
2222 --------------------
2223 -- Try_One_Interp --
2224 --------------------
2226 procedure Try_One_Interp
(T1
: Entity_Id
) is
2228 if Has_Compatible_Type
(R
, T1
) then
2230 and then Base_Type
(T1
) /= Base_Type
(T_F
)
2232 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
2234 if It
= No_Interp
then
2235 Ambiguous_Operands
(N
);
2236 Set_Etype
(L
, Any_Type
);
2253 procedure Analyze_Set_Membership
;
2254 -- If a set of alternatives is present, analyze each and find the
2255 -- common type to which they must all resolve.
2257 ----------------------------
2258 -- Analyze_Set_Membership --
2259 ----------------------------
2261 procedure Analyze_Set_Membership
is
2263 Index
: Interp_Index
;
2265 Candidate_Interps
: Node_Id
;
2266 Common_Type
: Entity_Id
:= Empty
;
2270 Candidate_Interps
:= L
;
2272 if not Is_Overloaded
(L
) then
2273 Common_Type
:= Etype
(L
);
2275 Alt
:= First
(Alternatives
(N
));
2276 while Present
(Alt
) loop
2279 if not Has_Compatible_Type
(Alt
, Common_Type
) then
2280 Wrong_Type
(Alt
, Common_Type
);
2287 Alt
:= First
(Alternatives
(N
));
2288 while Present
(Alt
) loop
2290 if not Is_Overloaded
(Alt
) then
2291 Common_Type
:= Etype
(Alt
);
2294 Get_First_Interp
(Alt
, Index
, It
);
2295 while Present
(It
.Typ
) loop
2297 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
2299 Remove_Interp
(Index
);
2302 Get_Next_Interp
(Index
, It
);
2305 Get_First_Interp
(Alt
, Index
, It
);
2308 Error_Msg_N
("alternative has no legal type", Alt
);
2312 -- If alternative is not overloaded, we have a unique type
2315 Set_Etype
(Alt
, It
.Typ
);
2316 Get_Next_Interp
(Index
, It
);
2319 Set_Is_Overloaded
(Alt
, False);
2320 Common_Type
:= Etype
(Alt
);
2323 Candidate_Interps
:= Alt
;
2330 Set_Etype
(N
, Standard_Boolean
);
2332 if Present
(Common_Type
) then
2333 Set_Etype
(L
, Common_Type
);
2334 Set_Is_Overloaded
(L
, False);
2337 Error_Msg_N
("cannot resolve membership operation", N
);
2339 end Analyze_Set_Membership
;
2341 -- Start of processing for Analyze_Membership_Op
2344 Analyze_Expression
(L
);
2347 and then Ada_Version
>= Ada_12
2349 Analyze_Set_Membership
;
2353 if Nkind
(R
) = N_Range
2354 or else (Nkind
(R
) = N_Attribute_Reference
2355 and then Attribute_Name
(R
) = Name_Range
)
2359 if not Is_Overloaded
(L
) then
2360 Try_One_Interp
(Etype
(L
));
2363 Get_First_Interp
(L
, Index
, It
);
2364 while Present
(It
.Typ
) loop
2365 Try_One_Interp
(It
.Typ
);
2366 Get_Next_Interp
(Index
, It
);
2370 -- If not a range, it can only be a subtype mark, or else there
2371 -- is a more basic error, to be diagnosed in Find_Type.
2376 if Is_Entity_Name
(R
) then
2377 Check_Fully_Declared
(Entity
(R
), R
);
2381 -- Compatibility between expression and subtype mark or range is
2382 -- checked during resolution. The result of the operation is Boolean
2385 Set_Etype
(N
, Standard_Boolean
);
2387 if Comes_From_Source
(N
)
2388 and then Present
(Right_Opnd
(N
))
2389 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
2391 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
2393 end Analyze_Membership_Op
;
2395 ----------------------
2396 -- Analyze_Negation --
2397 ----------------------
2399 procedure Analyze_Negation
(N
: Node_Id
) is
2400 R
: constant Node_Id
:= Right_Opnd
(N
);
2401 Op_Id
: Entity_Id
:= Entity
(N
);
2404 Set_Etype
(N
, Any_Type
);
2405 Candidate_Type
:= Empty
;
2407 Analyze_Expression
(R
);
2409 if Present
(Op_Id
) then
2410 if Ekind
(Op_Id
) = E_Operator
then
2411 Find_Negation_Types
(R
, Op_Id
, N
);
2413 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2417 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2418 while Present
(Op_Id
) loop
2419 if Ekind
(Op_Id
) = E_Operator
then
2420 Find_Negation_Types
(R
, Op_Id
, N
);
2422 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
2425 Op_Id
:= Homonym
(Op_Id
);
2430 end Analyze_Negation
;
2436 procedure Analyze_Null
(N
: Node_Id
) is
2438 Set_Etype
(N
, Any_Access
);
2441 ----------------------
2442 -- Analyze_One_Call --
2443 ----------------------
2445 procedure Analyze_One_Call
2449 Success
: out Boolean;
2450 Skip_First
: Boolean := False)
2452 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2453 Prev_T
: constant Entity_Id
:= Etype
(N
);
2455 Must_Skip
: constant Boolean := Skip_First
2456 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
2458 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
2459 and then Nkind
(Prefix
(Original_Node
(N
)))
2460 = N_Selected_Component
);
2461 -- The first formal must be omitted from the match when trying to find
2462 -- a primitive operation that is a possible interpretation, and also
2463 -- after the call has been rewritten, because the corresponding actual
2464 -- is already known to be compatible, and because this may be an
2465 -- indexing of a call with default parameters.
2469 Is_Indexed
: Boolean := False;
2470 Is_Indirect
: Boolean := False;
2471 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
2474 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
2475 -- There may be a user-defined operator that hides the current
2476 -- interpretation. We must check for this independently of the
2477 -- analysis of the call with the user-defined operation, because
2478 -- the parameter names may be wrong and yet the hiding takes place.
2479 -- This fixes a problem with ACATS test B34014O.
2481 -- When the type Address is a visible integer type, and the DEC
2482 -- system extension is visible, the predefined operator may be
2483 -- hidden as well, by one of the address operations in auxdec.
2484 -- Finally, The abstract operations on address do not hide the
2485 -- predefined operator (this is the purpose of making them abstract).
2487 procedure Indicate_Name_And_Type
;
2488 -- If candidate interpretation matches, indicate name and type of
2489 -- result on call node.
2491 ----------------------------
2492 -- Indicate_Name_And_Type --
2493 ----------------------------
2495 procedure Indicate_Name_And_Type
is
2497 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
2500 -- If the prefix of the call is a name, indicate the entity
2501 -- being called. If it is not a name, it is an expression that
2502 -- denotes an access to subprogram or else an entry or family. In
2503 -- the latter case, the name is a selected component, and the entity
2504 -- being called is noted on the selector.
2506 if not Is_Type
(Nam
) then
2507 if Is_Entity_Name
(Name
(N
))
2508 or else Nkind
(Name
(N
)) = N_Operator_Symbol
2510 Set_Entity
(Name
(N
), Nam
);
2512 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
2513 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
2517 if Debug_Flag_E
and not Report
then
2518 Write_Str
(" Overloaded call ");
2519 Write_Int
(Int
(N
));
2520 Write_Str
(" compatible with ");
2521 Write_Int
(Int
(Nam
));
2524 end Indicate_Name_And_Type
;
2526 ------------------------
2527 -- Operator_Hidden_By --
2528 ------------------------
2530 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
2531 Act1
: constant Node_Id
:= First_Actual
(N
);
2532 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2533 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
2534 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
2537 if Ekind
(Fun
) /= E_Function
2538 or else Is_Abstract_Subprogram
(Fun
)
2542 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
2545 elsif Present
(Form2
) then
2547 No
(Act2
) or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
2552 elsif Present
(Act2
) then
2556 -- Now we know that the arity of the operator matches the function,
2557 -- and the function call is a valid interpretation. The function
2558 -- hides the operator if it has the right signature, or if one of
2559 -- its operands is a non-abstract operation on Address when this is
2560 -- a visible integer type.
2562 return Hides_Op
(Fun
, Nam
)
2563 or else Is_Descendent_Of_Address
(Etype
(Form1
))
2566 and then Is_Descendent_Of_Address
(Etype
(Form2
)));
2567 end Operator_Hidden_By
;
2569 -- Start of processing for Analyze_One_Call
2574 -- If the subprogram has no formals or if all the formals have defaults,
2575 -- and the return type is an array type, the node may denote an indexing
2576 -- of the result of a parameterless call. In Ada 2005, the subprogram
2577 -- may have one non-defaulted formal, and the call may have been written
2578 -- in prefix notation, so that the rebuilt parameter list has more than
2581 if not Is_Overloadable
(Nam
)
2582 and then Ekind
(Nam
) /= E_Subprogram_Type
2583 and then Ekind
(Nam
) /= E_Entry_Family
2588 -- An indexing requires at least one actual
2590 if not Is_Empty_List
(Actuals
)
2592 (Needs_No_Actuals
(Nam
)
2594 (Needs_One_Actual
(Nam
)
2595 and then Present
(Next_Actual
(First
(Actuals
)))))
2597 if Is_Array_Type
(Subp_Type
) then
2598 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
2600 elsif Is_Access_Type
(Subp_Type
)
2601 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
2605 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
2607 -- The prefix can also be a parameterless function that returns an
2608 -- access to subprogram, in which case this is an indirect call.
2609 -- If this succeeds, an explicit dereference is added later on,
2610 -- in Analyze_Call or Resolve_Call.
2612 elsif Is_Access_Type
(Subp_Type
)
2613 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
2615 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
2620 -- If the call has been transformed into a slice, it is of the form
2621 -- F (Subtype) where F is parameterless. The node has been rewritten in
2622 -- Try_Indexed_Call and there is nothing else to do.
2625 and then Nkind
(N
) = N_Slice
2631 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
2635 -- If an indirect call is a possible interpretation, indicate
2636 -- success to the caller.
2642 -- Mismatch in number or names of parameters
2644 elsif Debug_Flag_E
then
2645 Write_Str
(" normalization fails in call ");
2646 Write_Int
(Int
(N
));
2647 Write_Str
(" with subprogram ");
2648 Write_Int
(Int
(Nam
));
2652 -- If the context expects a function call, discard any interpretation
2653 -- that is a procedure. If the node is not overloaded, leave as is for
2654 -- better error reporting when type mismatch is found.
2656 elsif Nkind
(N
) = N_Function_Call
2657 and then Is_Overloaded
(Name
(N
))
2658 and then Ekind
(Nam
) = E_Procedure
2662 -- Ditto for function calls in a procedure context
2664 elsif Nkind
(N
) = N_Procedure_Call_Statement
2665 and then Is_Overloaded
(Name
(N
))
2666 and then Etype
(Nam
) /= Standard_Void_Type
2670 elsif No
(Actuals
) then
2672 -- If Normalize succeeds, then there are default parameters for
2675 Indicate_Name_And_Type
;
2677 elsif Ekind
(Nam
) = E_Operator
then
2678 if Nkind
(N
) = N_Procedure_Call_Statement
then
2682 -- This can occur when the prefix of the call is an operator
2683 -- name or an expanded name whose selector is an operator name.
2685 Analyze_Operator_Call
(N
, Nam
);
2687 if Etype
(N
) /= Prev_T
then
2689 -- Check that operator is not hidden by a function interpretation
2691 if Is_Overloaded
(Name
(N
)) then
2697 Get_First_Interp
(Name
(N
), I
, It
);
2698 while Present
(It
.Nam
) loop
2699 if Operator_Hidden_By
(It
.Nam
) then
2700 Set_Etype
(N
, Prev_T
);
2704 Get_Next_Interp
(I
, It
);
2709 -- If operator matches formals, record its name on the call.
2710 -- If the operator is overloaded, Resolve will select the
2711 -- correct one from the list of interpretations. The call
2712 -- node itself carries the first candidate.
2714 Set_Entity
(Name
(N
), Nam
);
2717 elsif Report
and then Etype
(N
) = Any_Type
then
2718 Error_Msg_N
("incompatible arguments for operator", N
);
2722 -- Normalize_Actuals has chained the named associations in the
2723 -- correct order of the formals.
2725 Actual
:= First_Actual
(N
);
2726 Formal
:= First_Formal
(Nam
);
2728 -- If we are analyzing a call rewritten from object notation,
2729 -- skip first actual, which may be rewritten later as an
2730 -- explicit dereference.
2733 Next_Actual
(Actual
);
2734 Next_Formal
(Formal
);
2737 while Present
(Actual
) and then Present
(Formal
) loop
2738 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
2739 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
2741 -- The actual can be compatible with the formal, but we must
2742 -- also check that the context is not an address type that is
2743 -- visibly an integer type, as is the case in VMS_64. In this
2744 -- case the use of literals is illegal, except in the body of
2745 -- descendents of system, where arithmetic operations on
2746 -- address are of course used.
2748 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
2750 (Etype
(Actual
) /= Universal_Integer
2751 or else not Is_Descendent_Of_Address
(Etype
(Formal
))
2753 Is_Predefined_File_Name
2754 (Unit_File_Name
(Get_Source_Unit
(N
))))
2756 Next_Actual
(Actual
);
2757 Next_Formal
(Formal
);
2760 if Debug_Flag_E
then
2761 Write_Str
(" type checking fails in call ");
2762 Write_Int
(Int
(N
));
2763 Write_Str
(" with formal ");
2764 Write_Int
(Int
(Formal
));
2765 Write_Str
(" in subprogram ");
2766 Write_Int
(Int
(Nam
));
2770 if Report
and not Is_Indexed
and not Is_Indirect
then
2772 -- Ada 2005 (AI-251): Complete the error notification
2773 -- to help new Ada 2005 users.
2775 if Is_Class_Wide_Type
(Etype
(Formal
))
2776 and then Is_Interface
(Etype
(Etype
(Formal
)))
2777 and then not Interface_Present_In_Ancestor
2778 (Typ
=> Etype
(Actual
),
2779 Iface
=> Etype
(Etype
(Formal
)))
2782 ("(Ada 2005) does not implement interface }",
2783 Actual
, Etype
(Etype
(Formal
)));
2786 Wrong_Type
(Actual
, Etype
(Formal
));
2788 if Nkind
(Actual
) = N_Op_Eq
2789 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
2791 Formal
:= First_Formal
(Nam
);
2792 while Present
(Formal
) loop
2793 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
2794 Error_Msg_N
-- CODEFIX
2795 ("possible misspelling of `='>`!", Actual
);
2799 Next_Formal
(Formal
);
2803 if All_Errors_Mode
then
2804 Error_Msg_Sloc
:= Sloc
(Nam
);
2806 if Is_Overloadable
(Nam
)
2807 and then Present
(Alias
(Nam
))
2808 and then not Comes_From_Source
(Nam
)
2811 ("\\ =='> in call to inherited operation & #!",
2814 elsif Ekind
(Nam
) = E_Subprogram_Type
then
2816 Access_To_Subprogram_Typ
:
2817 constant Entity_Id
:=
2819 (Associated_Node_For_Itype
(Nam
));
2822 "\\ =='> in call to dereference of &#!",
2823 Actual
, Access_To_Subprogram_Typ
);
2828 ("\\ =='> in call to &#!", Actual
, Nam
);
2838 -- Normalize_Actuals has verified that a default value exists
2839 -- for this formal. Current actual names a subsequent formal.
2841 Next_Formal
(Formal
);
2845 -- On exit, all actuals match
2847 Indicate_Name_And_Type
;
2849 end Analyze_One_Call
;
2851 ---------------------------
2852 -- Analyze_Operator_Call --
2853 ---------------------------
2855 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
2856 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
2857 Act1
: constant Node_Id
:= First_Actual
(N
);
2858 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2861 -- Binary operator case
2863 if Present
(Act2
) then
2865 -- If more than two operands, then not binary operator after all
2867 if Present
(Next_Actual
(Act2
)) then
2870 elsif Op_Name
= Name_Op_Add
2871 or else Op_Name
= Name_Op_Subtract
2872 or else Op_Name
= Name_Op_Multiply
2873 or else Op_Name
= Name_Op_Divide
2874 or else Op_Name
= Name_Op_Mod
2875 or else Op_Name
= Name_Op_Rem
2876 or else Op_Name
= Name_Op_Expon
2878 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
2880 elsif Op_Name
= Name_Op_And
2881 or else Op_Name
= Name_Op_Or
2882 or else Op_Name
= Name_Op_Xor
2884 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
2886 elsif Op_Name
= Name_Op_Lt
2887 or else Op_Name
= Name_Op_Le
2888 or else Op_Name
= Name_Op_Gt
2889 or else Op_Name
= Name_Op_Ge
2891 Find_Comparison_Types
(Act1
, Act2
, Op_Id
, N
);
2893 elsif Op_Name
= Name_Op_Eq
2894 or else Op_Name
= Name_Op_Ne
2896 Find_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
2898 elsif Op_Name
= Name_Op_Concat
then
2899 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
2901 -- Is this else null correct, or should it be an abort???
2907 -- Unary operator case
2910 if Op_Name
= Name_Op_Subtract
or else
2911 Op_Name
= Name_Op_Add
or else
2912 Op_Name
= Name_Op_Abs
2914 Find_Unary_Types
(Act1
, Op_Id
, N
);
2917 Op_Name
= Name_Op_Not
2919 Find_Negation_Types
(Act1
, Op_Id
, N
);
2921 -- Is this else null correct, or should it be an abort???
2927 end Analyze_Operator_Call
;
2929 -------------------------------------------
2930 -- Analyze_Overloaded_Selected_Component --
2931 -------------------------------------------
2933 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
2934 Nam
: constant Node_Id
:= Prefix
(N
);
2935 Sel
: constant Node_Id
:= Selector_Name
(N
);
2942 Set_Etype
(Sel
, Any_Type
);
2944 Get_First_Interp
(Nam
, I
, It
);
2945 while Present
(It
.Typ
) loop
2946 if Is_Access_Type
(It
.Typ
) then
2947 T
:= Designated_Type
(It
.Typ
);
2948 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
2953 if Is_Record_Type
(T
) then
2955 -- If the prefix is a class-wide type, the visible components are
2956 -- those of the base type.
2958 if Is_Class_Wide_Type
(T
) then
2962 Comp
:= First_Entity
(T
);
2963 while Present
(Comp
) loop
2964 if Chars
(Comp
) = Chars
(Sel
)
2965 and then Is_Visible_Component
(Comp
)
2968 -- AI05-105: if the context is an object renaming with
2969 -- an anonymous access type, the expected type of the
2970 -- object must be anonymous. This is a name resolution rule.
2972 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
2973 or else No
(Access_Definition
(Parent
(N
)))
2974 or else Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Type
2976 Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Subprogram_Type
2978 Set_Entity
(Sel
, Comp
);
2979 Set_Etype
(Sel
, Etype
(Comp
));
2980 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
2982 -- This also specifies a candidate to resolve the name.
2983 -- Further overloading will be resolved from context.
2984 -- The selector name itself does not carry overloading
2987 Set_Etype
(Nam
, It
.Typ
);
2990 -- Named access type in the context of a renaming
2991 -- declaration with an access definition. Remove
2992 -- inapplicable candidate.
3001 elsif Is_Concurrent_Type
(T
) then
3002 Comp
:= First_Entity
(T
);
3003 while Present
(Comp
)
3004 and then Comp
/= First_Private_Entity
(T
)
3006 if Chars
(Comp
) = Chars
(Sel
) then
3007 if Is_Overloadable
(Comp
) then
3008 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3010 Set_Entity_With_Style_Check
(Sel
, Comp
);
3011 Generate_Reference
(Comp
, Sel
);
3014 Set_Etype
(Sel
, Etype
(Comp
));
3015 Set_Etype
(N
, Etype
(Comp
));
3016 Set_Etype
(Nam
, It
.Typ
);
3018 -- For access type case, introduce explicit dereference for
3019 -- more uniform treatment of entry calls. Do this only once
3020 -- if several interpretations yield an access type.
3022 if Is_Access_Type
(Etype
(Nam
))
3023 and then Nkind
(Nam
) /= N_Explicit_Dereference
3025 Insert_Explicit_Dereference
(Nam
);
3027 (Warn_On_Dereference
, "?implicit dereference", N
);
3034 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3037 Get_Next_Interp
(I
, It
);
3040 if Etype
(N
) = Any_Type
3041 and then not Try_Object_Operation
(N
)
3043 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
3044 Set_Entity
(Sel
, Any_Id
);
3045 Set_Etype
(Sel
, Any_Type
);
3047 end Analyze_Overloaded_Selected_Component
;
3049 ----------------------------------
3050 -- Analyze_Qualified_Expression --
3051 ----------------------------------
3053 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
3054 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
3055 Expr
: constant Node_Id
:= Expression
(N
);
3061 Analyze_Expression
(Expr
);
3063 Set_Etype
(N
, Any_Type
);
3068 if T
= Any_Type
then
3072 Check_Fully_Declared
(T
, N
);
3074 -- If expected type is class-wide, check for exact match before
3075 -- expansion, because if the expression is a dispatching call it
3076 -- may be rewritten as explicit dereference with class-wide result.
3077 -- If expression is overloaded, retain only interpretations that
3078 -- will yield exact matches.
3080 if Is_Class_Wide_Type
(T
) then
3081 if not Is_Overloaded
(Expr
) then
3082 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
) then
3083 if Nkind
(Expr
) = N_Aggregate
then
3084 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
3086 Wrong_Type
(Expr
, T
);
3091 Get_First_Interp
(Expr
, I
, It
);
3093 while Present
(It
.Nam
) loop
3094 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
3098 Get_Next_Interp
(I
, It
);
3104 end Analyze_Qualified_Expression
;
3110 procedure Analyze_Range
(N
: Node_Id
) is
3111 L
: constant Node_Id
:= Low_Bound
(N
);
3112 H
: constant Node_Id
:= High_Bound
(N
);
3113 I1
, I2
: Interp_Index
;
3116 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
3117 -- Verify the compatibility of two types, and choose the
3118 -- non universal one if the other is universal.
3120 procedure Check_High_Bound
(T
: Entity_Id
);
3121 -- Test one interpretation of the low bound against all those
3122 -- of the high bound.
3124 procedure Check_Universal_Expression
(N
: Node_Id
);
3125 -- In Ada83, reject bounds of a universal range that are not
3126 -- literals or entity names.
3128 -----------------------
3129 -- Check_Common_Type --
3130 -----------------------
3132 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
3134 if Covers
(T1
=> T1
, T2
=> T2
)
3136 Covers
(T1
=> T2
, T2
=> T1
)
3138 if T1
= Universal_Integer
3139 or else T1
= Universal_Real
3140 or else T1
= Any_Character
3142 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
3145 Add_One_Interp
(N
, T1
, T1
);
3148 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
3151 end Check_Common_Type
;
3153 ----------------------
3154 -- Check_High_Bound --
3155 ----------------------
3157 procedure Check_High_Bound
(T
: Entity_Id
) is
3159 if not Is_Overloaded
(H
) then
3160 Check_Common_Type
(T
, Etype
(H
));
3162 Get_First_Interp
(H
, I2
, It2
);
3163 while Present
(It2
.Typ
) loop
3164 Check_Common_Type
(T
, It2
.Typ
);
3165 Get_Next_Interp
(I2
, It2
);
3168 end Check_High_Bound
;
3170 -----------------------------
3171 -- Is_Universal_Expression --
3172 -----------------------------
3174 procedure Check_Universal_Expression
(N
: Node_Id
) is
3176 if Etype
(N
) = Universal_Integer
3177 and then Nkind
(N
) /= N_Integer_Literal
3178 and then not Is_Entity_Name
(N
)
3179 and then Nkind
(N
) /= N_Attribute_Reference
3181 Error_Msg_N
("illegal bound in discrete range", N
);
3183 end Check_Universal_Expression
;
3185 -- Start of processing for Analyze_Range
3188 Set_Etype
(N
, Any_Type
);
3189 Analyze_Expression
(L
);
3190 Analyze_Expression
(H
);
3192 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
3196 if not Is_Overloaded
(L
) then
3197 Check_High_Bound
(Etype
(L
));
3199 Get_First_Interp
(L
, I1
, It1
);
3200 while Present
(It1
.Typ
) loop
3201 Check_High_Bound
(It1
.Typ
);
3202 Get_Next_Interp
(I1
, It1
);
3206 -- If result is Any_Type, then we did not find a compatible pair
3208 if Etype
(N
) = Any_Type
then
3209 Error_Msg_N
("incompatible types in range ", N
);
3213 if Ada_Version
= Ada_83
3215 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
3216 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
3218 Check_Universal_Expression
(L
);
3219 Check_Universal_Expression
(H
);
3223 -----------------------
3224 -- Analyze_Reference --
3225 -----------------------
3227 procedure Analyze_Reference
(N
: Node_Id
) is
3228 P
: constant Node_Id
:= Prefix
(N
);
3231 Acc_Type
: Entity_Id
;
3236 -- An interesting error check, if we take the 'Reference of an object
3237 -- for which a pragma Atomic or Volatile has been given, and the type
3238 -- of the object is not Atomic or Volatile, then we are in trouble. The
3239 -- problem is that no trace of the atomic/volatile status will remain
3240 -- for the backend to respect when it deals with the resulting pointer,
3241 -- since the pointer type will not be marked atomic (it is a pointer to
3242 -- the base type of the object).
3244 -- It is not clear if that can ever occur, but in case it does, we will
3245 -- generate an error message. Not clear if this message can ever be
3246 -- generated, and pretty clear that it represents a bug if it is, still
3247 -- seems worth checking!
3251 if Is_Entity_Name
(P
)
3252 and then Is_Object_Reference
(P
)
3257 if (Has_Atomic_Components
(E
)
3258 and then not Has_Atomic_Components
(T
))
3260 (Has_Volatile_Components
(E
)
3261 and then not Has_Volatile_Components
(T
))
3262 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
3263 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
3265 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
3269 -- Carry on with normal processing
3271 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
3272 Set_Etype
(Acc_Type
, Acc_Type
);
3273 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
3274 Set_Etype
(N
, Acc_Type
);
3275 end Analyze_Reference
;
3277 --------------------------------
3278 -- Analyze_Selected_Component --
3279 --------------------------------
3281 -- Prefix is a record type or a task or protected type. In the latter case,
3282 -- the selector must denote a visible entry.
3284 procedure Analyze_Selected_Component
(N
: Node_Id
) is
3285 Name
: constant Node_Id
:= Prefix
(N
);
3286 Sel
: constant Node_Id
:= Selector_Name
(N
);
3289 Has_Candidate
: Boolean := False;
3292 Pent
: Entity_Id
:= Empty
;
3293 Prefix_Type
: Entity_Id
;
3295 Type_To_Use
: Entity_Id
;
3296 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
3297 -- a class-wide type, we use its root type, whose components are
3298 -- present in the class-wide type.
3300 Is_Single_Concurrent_Object
: Boolean;
3301 -- Set True if the prefix is a single task or a single protected object
3303 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
3304 -- It is known that the parent of N denotes a subprogram call. Comp
3305 -- is an overloadable component of the concurrent type of the prefix.
3306 -- Determine whether all formals of the parent of N and Comp are mode
3307 -- conformant. If the parent node is not analyzed yet it may be an
3308 -- indexed component rather than a function call.
3310 ------------------------------
3311 -- Has_Mode_Conformant_Spec --
3312 ------------------------------
3314 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
3315 Comp_Param
: Entity_Id
;
3317 Param_Typ
: Entity_Id
;
3320 Comp_Param
:= First_Formal
(Comp
);
3322 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
3323 Param
:= First
(Expressions
(Parent
(N
)));
3325 Param
:= First
(Parameter_Associations
(Parent
(N
)));
3328 while Present
(Comp_Param
)
3329 and then Present
(Param
)
3331 Param_Typ
:= Find_Parameter_Type
(Param
);
3333 if Present
(Param_Typ
)
3335 not Conforming_Types
3336 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
3341 Next_Formal
(Comp_Param
);
3345 -- One of the specs has additional formals
3347 if Present
(Comp_Param
) or else Present
(Param
) then
3352 end Has_Mode_Conformant_Spec
;
3354 -- Start of processing for Analyze_Selected_Component
3357 Set_Etype
(N
, Any_Type
);
3359 if Is_Overloaded
(Name
) then
3360 Analyze_Overloaded_Selected_Component
(N
);
3363 elsif Etype
(Name
) = Any_Type
then
3364 Set_Entity
(Sel
, Any_Id
);
3365 Set_Etype
(Sel
, Any_Type
);
3369 Prefix_Type
:= Etype
(Name
);
3372 if Is_Access_Type
(Prefix_Type
) then
3374 -- A RACW object can never be used as prefix of a selected
3375 -- component since that means it is dereferenced without
3376 -- being a controlling operand of a dispatching operation
3377 -- (RM E.2.2(16/1)). Before reporting an error, we must check
3378 -- whether this is actually a dispatching call in prefix form.
3380 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
3381 and then Comes_From_Source
(N
)
3383 if Try_Object_Operation
(N
) then
3387 ("invalid dereference of a remote access-to-class-wide value",
3391 -- Normal case of selected component applied to access type
3394 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3396 if Is_Entity_Name
(Name
) then
3397 Pent
:= Entity
(Name
);
3398 elsif Nkind
(Name
) = N_Selected_Component
3399 and then Is_Entity_Name
(Selector_Name
(Name
))
3401 Pent
:= Entity
(Selector_Name
(Name
));
3404 Prefix_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, Name
);
3407 -- If we have an explicit dereference of a remote access-to-class-wide
3408 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
3409 -- have to check for the case of a prefix that is a controlling operand
3410 -- of a prefixed dispatching call, as the dereference is legal in that
3411 -- case. Normally this condition is checked in Validate_Remote_Access_
3412 -- To_Class_Wide_Type, but we have to defer the checking for selected
3413 -- component prefixes because of the prefixed dispatching call case.
3414 -- Note that implicit dereferences are checked for this just above.
3416 elsif Nkind
(Name
) = N_Explicit_Dereference
3417 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Name
)))
3418 and then Comes_From_Source
(N
)
3420 if Try_Object_Operation
(N
) then
3424 ("invalid dereference of a remote access-to-class-wide value",
3429 -- (Ada 2005): if the prefix is the limited view of a type, and
3430 -- the context already includes the full view, use the full view
3431 -- in what follows, either to retrieve a component of to find
3432 -- a primitive operation. If the prefix is an explicit dereference,
3433 -- set the type of the prefix to reflect this transformation.
3434 -- If the non-limited view is itself an incomplete type, get the
3435 -- full view if available.
3437 if Is_Incomplete_Type
(Prefix_Type
)
3438 and then From_With_Type
(Prefix_Type
)
3439 and then Present
(Non_Limited_View
(Prefix_Type
))
3441 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
3443 if Nkind
(N
) = N_Explicit_Dereference
then
3444 Set_Etype
(Prefix
(N
), Prefix_Type
);
3447 elsif Ekind
(Prefix_Type
) = E_Class_Wide_Type
3448 and then From_With_Type
(Prefix_Type
)
3449 and then Present
(Non_Limited_View
(Etype
(Prefix_Type
)))
3452 Class_Wide_Type
(Non_Limited_View
(Etype
(Prefix_Type
)));
3454 if Nkind
(N
) = N_Explicit_Dereference
then
3455 Set_Etype
(Prefix
(N
), Prefix_Type
);
3459 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
3460 Prefix_Type
:= Base_Type
(Prefix_Type
);
3463 Type_To_Use
:= Prefix_Type
;
3465 -- For class-wide types, use the entity list of the root type. This
3466 -- indirection is specially important for private extensions because
3467 -- only the root type get switched (not the class-wide type).
3469 if Is_Class_Wide_Type
(Prefix_Type
) then
3470 Type_To_Use
:= Root_Type
(Prefix_Type
);
3473 -- If the prefix is a single concurrent object, use its name in error
3474 -- messages, rather than that of its anonymous type.
3476 Is_Single_Concurrent_Object
:=
3477 Is_Concurrent_Type
(Prefix_Type
)
3478 and then Is_Internal_Name
(Chars
(Prefix_Type
))
3479 and then not Is_Derived_Type
(Prefix_Type
)
3480 and then Is_Entity_Name
(Name
);
3482 Comp
:= First_Entity
(Type_To_Use
);
3484 -- If the selector has an original discriminant, the node appears in
3485 -- an instance. Replace the discriminant with the corresponding one
3486 -- in the current discriminated type. For nested generics, this must
3487 -- be done transitively, so note the new original discriminant.
3489 if Nkind
(Sel
) = N_Identifier
3490 and then Present
(Original_Discriminant
(Sel
))
3492 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
3494 -- Mark entity before rewriting, for completeness and because
3495 -- subsequent semantic checks might examine the original node.
3497 Set_Entity
(Sel
, Comp
);
3498 Rewrite
(Selector_Name
(N
),
3499 New_Occurrence_Of
(Comp
, Sloc
(N
)));
3500 Set_Original_Discriminant
(Selector_Name
(N
), Comp
);
3501 Set_Etype
(N
, Etype
(Comp
));
3503 if Is_Access_Type
(Etype
(Name
)) then
3504 Insert_Explicit_Dereference
(Name
);
3505 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
3508 elsif Is_Record_Type
(Prefix_Type
) then
3510 -- Find component with given name
3512 while Present
(Comp
) loop
3513 if Chars
(Comp
) = Chars
(Sel
)
3514 and then Is_Visible_Component
(Comp
)
3516 Set_Entity_With_Style_Check
(Sel
, Comp
);
3517 Set_Etype
(Sel
, Etype
(Comp
));
3519 if Ekind
(Comp
) = E_Discriminant
then
3520 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
3522 ("cannot reference discriminant of Unchecked_Union",
3526 if Is_Generic_Type
(Prefix_Type
)
3528 Is_Generic_Type
(Root_Type
(Prefix_Type
))
3530 Set_Original_Discriminant
(Sel
, Comp
);
3534 -- Resolve the prefix early otherwise it is not possible to
3535 -- build the actual subtype of the component: it may need
3536 -- to duplicate this prefix and duplication is only allowed
3537 -- on fully resolved expressions.
3541 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
3542 -- subtypes in a package specification.
3545 -- limited with Pkg;
3547 -- type Acc_Inc is access Pkg.T;
3549 -- N : Natural := X.all.Comp; -- ERROR, limited view
3550 -- end Pkg; -- Comp is not visible
3552 if Nkind
(Name
) = N_Explicit_Dereference
3553 and then From_With_Type
(Etype
(Prefix
(Name
)))
3554 and then not Is_Potentially_Use_Visible
(Etype
(Name
))
3555 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
3556 N_Package_Specification
3559 ("premature usage of incomplete}", Prefix
(Name
),
3560 Etype
(Prefix
(Name
)));
3563 -- We never need an actual subtype for the case of a selection
3564 -- for a indexed component of a non-packed array, since in
3565 -- this case gigi generates all the checks and can find the
3566 -- necessary bounds information.
3568 -- We also do not need an actual subtype for the case of
3569 -- a first, last, length, or range attribute applied to a
3570 -- non-packed array, since gigi can again get the bounds in
3571 -- these cases (gigi cannot handle the packed case, since it
3572 -- has the bounds of the packed array type, not the original
3573 -- bounds of the type). However, if the prefix is itself a
3574 -- selected component, as in a.b.c (i), gigi may regard a.b.c
3575 -- as a dynamic-sized temporary, so we do generate an actual
3576 -- subtype for this case.
3578 Parent_N
:= Parent
(N
);
3580 if not Is_Packed
(Etype
(Comp
))
3582 ((Nkind
(Parent_N
) = N_Indexed_Component
3583 and then Nkind
(Name
) /= N_Selected_Component
)
3585 (Nkind
(Parent_N
) = N_Attribute_Reference
3586 and then (Attribute_Name
(Parent_N
) = Name_First
3588 Attribute_Name
(Parent_N
) = Name_Last
3590 Attribute_Name
(Parent_N
) = Name_Length
3592 Attribute_Name
(Parent_N
) = Name_Range
)))
3594 Set_Etype
(N
, Etype
(Comp
));
3596 -- If full analysis is not enabled, we do not generate an
3597 -- actual subtype, because in the absence of expansion
3598 -- reference to a formal of a protected type, for example,
3599 -- will not be properly transformed, and will lead to
3600 -- out-of-scope references in gigi.
3602 -- In all other cases, we currently build an actual subtype.
3603 -- It seems likely that many of these cases can be avoided,
3604 -- but right now, the front end makes direct references to the
3605 -- bounds (e.g. in generating a length check), and if we do
3606 -- not make an actual subtype, we end up getting a direct
3607 -- reference to a discriminant, which will not do.
3609 elsif Full_Analysis
then
3611 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
3612 Insert_Action
(N
, Act_Decl
);
3614 if No
(Act_Decl
) then
3615 Set_Etype
(N
, Etype
(Comp
));
3618 -- Component type depends on discriminants. Enter the
3619 -- main attributes of the subtype.
3622 Subt
: constant Entity_Id
:=
3623 Defining_Identifier
(Act_Decl
);
3626 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
3627 Set_Ekind
(Subt
, Ekind
(Etype
(Comp
)));
3628 Set_Etype
(N
, Subt
);
3632 -- If Full_Analysis not enabled, just set the Etype
3635 Set_Etype
(N
, Etype
(Comp
));
3641 -- If the prefix is a private extension, check only the visible
3642 -- components of the partial view. This must include the tag,
3643 -- which can appear in expanded code in a tag check.
3645 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
3646 and then Chars
(Selector_Name
(N
)) /= Name_uTag
3648 exit when Comp
= Last_Entity
(Type_To_Use
);
3654 -- Ada 2005 (AI-252): The selected component can be interpreted as
3655 -- a prefixed view of a subprogram. Depending on the context, this is
3656 -- either a name that can appear in a renaming declaration, or part
3657 -- of an enclosing call given in prefix form.
3659 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
3660 -- selected component should resolve to a name.
3662 if Ada_Version
>= Ada_05
3663 and then Is_Tagged_Type
(Prefix_Type
)
3664 and then not Is_Concurrent_Type
(Prefix_Type
)
3666 if Nkind
(Parent
(N
)) = N_Generic_Association
3667 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
3668 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
3670 if Find_Primitive_Operation
(N
) then
3674 elsif Try_Object_Operation
(N
) then
3678 -- If the transformation fails, it will be necessary to redo the
3679 -- analysis with all errors enabled, to indicate candidate
3680 -- interpretations and reasons for each failure ???
3684 elsif Is_Private_Type
(Prefix_Type
) then
3686 -- Allow access only to discriminants of the type. If the type has
3687 -- no full view, gigi uses the parent type for the components, so we
3688 -- do the same here.
3690 if No
(Full_View
(Prefix_Type
)) then
3691 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
3692 Comp
:= First_Entity
(Type_To_Use
);
3695 while Present
(Comp
) loop
3696 if Chars
(Comp
) = Chars
(Sel
) then
3697 if Ekind
(Comp
) = E_Discriminant
then
3698 Set_Entity_With_Style_Check
(Sel
, Comp
);
3699 Generate_Reference
(Comp
, Sel
);
3701 Set_Etype
(Sel
, Etype
(Comp
));
3702 Set_Etype
(N
, Etype
(Comp
));
3704 if Is_Generic_Type
(Prefix_Type
)
3705 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
3707 Set_Original_Discriminant
(Sel
, Comp
);
3710 -- Before declaring an error, check whether this is tagged
3711 -- private type and a call to a primitive operation.
3713 elsif Ada_Version
>= Ada_05
3714 and then Is_Tagged_Type
(Prefix_Type
)
3715 and then Try_Object_Operation
(N
)
3720 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
3721 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
3722 Set_Entity
(Sel
, Any_Id
);
3723 Set_Etype
(N
, Any_Type
);
3732 elsif Is_Concurrent_Type
(Prefix_Type
) then
3734 -- Find visible operation with given name. For a protected type,
3735 -- the possible candidates are discriminants, entries or protected
3736 -- procedures. For a task type, the set can only include entries or
3737 -- discriminants if the task type is not an enclosing scope. If it
3738 -- is an enclosing scope (e.g. in an inner task) then all entities
3739 -- are visible, but the prefix must denote the enclosing scope, i.e.
3740 -- can only be a direct name or an expanded name.
3742 Set_Etype
(Sel
, Any_Type
);
3743 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
3745 while Present
(Comp
) loop
3746 if Chars
(Comp
) = Chars
(Sel
) then
3747 if Is_Overloadable
(Comp
) then
3748 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3750 -- If the prefix is tagged, the correct interpretation may
3751 -- lie in the primitive or class-wide operations of the
3752 -- type. Perform a simple conformance check to determine
3753 -- whether Try_Object_Operation should be invoked even if
3754 -- a visible entity is found.
3756 if Is_Tagged_Type
(Prefix_Type
)
3758 Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
3760 N_Indexed_Component
)
3761 and then Has_Mode_Conformant_Spec
(Comp
)
3763 Has_Candidate
:= True;
3766 -- Note: a selected component may not denote a component of a
3767 -- protected type (4.1.3(7)).
3769 elsif Ekind_In
(Comp
, E_Discriminant
, E_Entry_Family
)
3771 and then not Is_Protected_Type
(Prefix_Type
)
3772 and then Is_Entity_Name
(Name
))
3774 Set_Entity_With_Style_Check
(Sel
, Comp
);
3775 Generate_Reference
(Comp
, Sel
);
3781 Set_Etype
(Sel
, Etype
(Comp
));
3782 Set_Etype
(N
, Etype
(Comp
));
3784 if Ekind
(Comp
) = E_Discriminant
then
3785 Set_Original_Discriminant
(Sel
, Comp
);
3788 -- For access type case, introduce explicit dereference for
3789 -- more uniform treatment of entry calls.
3791 if Is_Access_Type
(Etype
(Name
)) then
3792 Insert_Explicit_Dereference
(Name
);
3794 (Warn_On_Dereference
, "?implicit dereference", N
);
3800 exit when not In_Scope
3802 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
3805 -- If there is no visible entity with the given name or none of the
3806 -- visible entities are plausible interpretations, check whether
3807 -- there is some other primitive operation with that name.
3809 if Ada_Version
>= Ada_05
3810 and then Is_Tagged_Type
(Prefix_Type
)
3812 if (Etype
(N
) = Any_Type
3813 or else not Has_Candidate
)
3814 and then Try_Object_Operation
(N
)
3818 -- If the context is not syntactically a procedure call, it
3819 -- may be a call to a primitive function declared outside of
3820 -- the synchronized type.
3822 -- If the context is a procedure call, there might still be
3823 -- an overloading between an entry and a primitive procedure
3824 -- declared outside of the synchronized type, called in prefix
3825 -- notation. This is harder to disambiguate because in one case
3826 -- the controlling formal is implicit ???
3828 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
3829 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
3830 and then Try_Object_Operation
(N
)
3836 if Etype
(N
) = Any_Type
and then Is_Protected_Type
(Prefix_Type
) then
3837 -- Case of a prefix of a protected type: selector might denote
3838 -- an invisible private component.
3840 Comp
:= First_Private_Entity
(Base_Type
(Prefix_Type
));
3841 while Present
(Comp
) and then Chars
(Comp
) /= Chars
(Sel
) loop
3845 if Present
(Comp
) then
3846 if Is_Single_Concurrent_Object
then
3847 Error_Msg_Node_2
:= Entity
(Name
);
3848 Error_Msg_NE
("invisible selector& for &", N
, Sel
);
3851 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
3852 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
3858 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3863 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
3866 -- If N still has no type, the component is not defined in the prefix
3868 if Etype
(N
) = Any_Type
then
3870 if Is_Single_Concurrent_Object
then
3871 Error_Msg_Node_2
:= Entity
(Name
);
3872 Error_Msg_NE
("no selector& for&", N
, Sel
);
3874 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
3876 elsif Is_Generic_Type
(Prefix_Type
)
3877 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
3878 and then Prefix_Type
/= Etype
(Prefix_Type
)
3879 and then Is_Record_Type
(Etype
(Prefix_Type
))
3881 -- If this is a derived formal type, the parent may have
3882 -- different visibility at this point. Try for an inherited
3883 -- component before reporting an error.
3885 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
3886 Analyze_Selected_Component
(N
);
3889 elsif Ekind
(Prefix_Type
) = E_Record_Subtype_With_Private
3890 and then Is_Generic_Actual_Type
(Prefix_Type
)
3891 and then Present
(Full_View
(Prefix_Type
))
3893 -- Similarly, if this the actual for a formal derived type, the
3894 -- component inherited from the generic parent may not be visible
3895 -- in the actual, but the selected component is legal.
3902 First_Component
(Generic_Parent_Type
(Parent
(Prefix_Type
)));
3903 while Present
(Comp
) loop
3904 if Chars
(Comp
) = Chars
(Sel
) then
3905 Set_Entity_With_Style_Check
(Sel
, Comp
);
3906 Set_Etype
(Sel
, Etype
(Comp
));
3907 Set_Etype
(N
, Etype
(Comp
));
3911 Next_Component
(Comp
);
3914 pragma Assert
(Etype
(N
) /= Any_Type
);
3918 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
3920 -- Check whether this is a component of the base type
3921 -- which is absent from a statically constrained subtype.
3922 -- This will raise constraint error at run-time, but is
3923 -- not a compile-time error. When the selector is illegal
3924 -- for base type as well fall through and generate a
3925 -- compilation error anyway.
3927 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
3928 while Present
(Comp
) loop
3929 if Chars
(Comp
) = Chars
(Sel
)
3930 and then Is_Visible_Component
(Comp
)
3932 Set_Entity_With_Style_Check
(Sel
, Comp
);
3933 Generate_Reference
(Comp
, Sel
);
3934 Set_Etype
(Sel
, Etype
(Comp
));
3935 Set_Etype
(N
, Etype
(Comp
));
3937 -- Emit appropriate message. Gigi will replace the
3938 -- node subsequently with the appropriate Raise.
3940 Apply_Compile_Time_Constraint_Error
3941 (N
, "component not present in }?",
3942 CE_Discriminant_Check_Failed
,
3943 Ent
=> Prefix_Type
, Rep
=> False);
3944 Set_Raises_Constraint_Error
(N
);
3948 Next_Component
(Comp
);
3953 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
3954 Error_Msg_NE
("no selector& for}", N
, Sel
);
3956 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
3959 Set_Entity
(Sel
, Any_Id
);
3960 Set_Etype
(Sel
, Any_Type
);
3962 end Analyze_Selected_Component
;
3964 ---------------------------
3965 -- Analyze_Short_Circuit --
3966 ---------------------------
3968 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
3969 L
: constant Node_Id
:= Left_Opnd
(N
);
3970 R
: constant Node_Id
:= Right_Opnd
(N
);
3975 Analyze_Expression
(L
);
3976 Analyze_Expression
(R
);
3977 Set_Etype
(N
, Any_Type
);
3979 if not Is_Overloaded
(L
) then
3980 if Root_Type
(Etype
(L
)) = Standard_Boolean
3981 and then Has_Compatible_Type
(R
, Etype
(L
))
3983 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
3987 Get_First_Interp
(L
, Ind
, It
);
3988 while Present
(It
.Typ
) loop
3989 if Root_Type
(It
.Typ
) = Standard_Boolean
3990 and then Has_Compatible_Type
(R
, It
.Typ
)
3992 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
3995 Get_Next_Interp
(Ind
, It
);
3999 -- Here we have failed to find an interpretation. Clearly we know that
4000 -- it is not the case that both operands can have an interpretation of
4001 -- Boolean, but this is by far the most likely intended interpretation.
4002 -- So we simply resolve both operands as Booleans, and at least one of
4003 -- these resolutions will generate an error message, and we do not need
4004 -- to give another error message on the short circuit operation itself.
4006 if Etype
(N
) = Any_Type
then
4007 Resolve
(L
, Standard_Boolean
);
4008 Resolve
(R
, Standard_Boolean
);
4009 Set_Etype
(N
, Standard_Boolean
);
4011 end Analyze_Short_Circuit
;
4017 procedure Analyze_Slice
(N
: Node_Id
) is
4018 P
: constant Node_Id
:= Prefix
(N
);
4019 D
: constant Node_Id
:= Discrete_Range
(N
);
4020 Array_Type
: Entity_Id
;
4022 procedure Analyze_Overloaded_Slice
;
4023 -- If the prefix is overloaded, select those interpretations that
4024 -- yield a one-dimensional array type.
4026 ------------------------------
4027 -- Analyze_Overloaded_Slice --
4028 ------------------------------
4030 procedure Analyze_Overloaded_Slice
is
4036 Set_Etype
(N
, Any_Type
);
4038 Get_First_Interp
(P
, I
, It
);
4039 while Present
(It
.Nam
) loop
4042 if Is_Access_Type
(Typ
) then
4043 Typ
:= Designated_Type
(Typ
);
4044 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
4047 if Is_Array_Type
(Typ
)
4048 and then Number_Dimensions
(Typ
) = 1
4049 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
4051 Add_One_Interp
(N
, Typ
, Typ
);
4054 Get_Next_Interp
(I
, It
);
4057 if Etype
(N
) = Any_Type
then
4058 Error_Msg_N
("expect array type in prefix of slice", N
);
4060 end Analyze_Overloaded_Slice
;
4062 -- Start of processing for Analyze_Slice
4068 if Is_Overloaded
(P
) then
4069 Analyze_Overloaded_Slice
;
4072 Array_Type
:= Etype
(P
);
4073 Set_Etype
(N
, Any_Type
);
4075 if Is_Access_Type
(Array_Type
) then
4076 Array_Type
:= Designated_Type
(Array_Type
);
4077 Error_Msg_NW
(Warn_On_Dereference
, "?implicit dereference", N
);
4080 if not Is_Array_Type
(Array_Type
) then
4081 Wrong_Type
(P
, Any_Array
);
4083 elsif Number_Dimensions
(Array_Type
) > 1 then
4085 ("type is not one-dimensional array in slice prefix", N
);
4088 Has_Compatible_Type
(D
, Etype
(First_Index
(Array_Type
)))
4090 Wrong_Type
(D
, Etype
(First_Index
(Array_Type
)));
4093 Set_Etype
(N
, Array_Type
);
4098 -----------------------------
4099 -- Analyze_Type_Conversion --
4100 -----------------------------
4102 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
4103 Expr
: constant Node_Id
:= Expression
(N
);
4107 -- If Conversion_OK is set, then the Etype is already set, and the
4108 -- only processing required is to analyze the expression. This is
4109 -- used to construct certain "illegal" conversions which are not
4110 -- allowed by Ada semantics, but can be handled OK by Gigi, see
4111 -- Sinfo for further details.
4113 if Conversion_OK
(N
) then
4118 -- Otherwise full type analysis is required, as well as some semantic
4119 -- checks to make sure the argument of the conversion is appropriate.
4121 Find_Type
(Subtype_Mark
(N
));
4122 T
:= Entity
(Subtype_Mark
(N
));
4124 Check_Fully_Declared
(T
, N
);
4125 Analyze_Expression
(Expr
);
4126 Validate_Remote_Type_Type_Conversion
(N
);
4128 -- Only remaining step is validity checks on the argument. These
4129 -- are skipped if the conversion does not come from the source.
4131 if not Comes_From_Source
(N
) then
4134 -- If there was an error in a generic unit, no need to replicate the
4135 -- error message. Conversely, constant-folding in the generic may
4136 -- transform the argument of a conversion into a string literal, which
4137 -- is legal. Therefore the following tests are not performed in an
4140 elsif In_Instance
then
4143 elsif Nkind
(Expr
) = N_Null
then
4144 Error_Msg_N
("argument of conversion cannot be null", N
);
4145 Error_Msg_N
("\use qualified expression instead", N
);
4146 Set_Etype
(N
, Any_Type
);
4148 elsif Nkind
(Expr
) = N_Aggregate
then
4149 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
4150 Error_Msg_N
("\use qualified expression instead", N
);
4152 elsif Nkind
(Expr
) = N_Allocator
then
4153 Error_Msg_N
("argument of conversion cannot be an allocator", N
);
4154 Error_Msg_N
("\use qualified expression instead", N
);
4156 elsif Nkind
(Expr
) = N_String_Literal
then
4157 Error_Msg_N
("argument of conversion cannot be string literal", N
);
4158 Error_Msg_N
("\use qualified expression instead", N
);
4160 elsif Nkind
(Expr
) = N_Character_Literal
then
4161 if Ada_Version
= Ada_83
then
4164 Error_Msg_N
("argument of conversion cannot be character literal",
4166 Error_Msg_N
("\use qualified expression instead", N
);
4169 elsif Nkind
(Expr
) = N_Attribute_Reference
4171 (Attribute_Name
(Expr
) = Name_Access
or else
4172 Attribute_Name
(Expr
) = Name_Unchecked_Access
or else
4173 Attribute_Name
(Expr
) = Name_Unrestricted_Access
)
4175 Error_Msg_N
("argument of conversion cannot be access", N
);
4176 Error_Msg_N
("\use qualified expression instead", N
);
4178 end Analyze_Type_Conversion
;
4180 ----------------------
4181 -- Analyze_Unary_Op --
4182 ----------------------
4184 procedure Analyze_Unary_Op
(N
: Node_Id
) is
4185 R
: constant Node_Id
:= Right_Opnd
(N
);
4186 Op_Id
: Entity_Id
:= Entity
(N
);
4189 Set_Etype
(N
, Any_Type
);
4190 Candidate_Type
:= Empty
;
4192 Analyze_Expression
(R
);
4194 if Present
(Op_Id
) then
4195 if Ekind
(Op_Id
) = E_Operator
then
4196 Find_Unary_Types
(R
, Op_Id
, N
);
4198 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4202 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
4203 while Present
(Op_Id
) loop
4204 if Ekind
(Op_Id
) = E_Operator
then
4205 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
4206 Find_Unary_Types
(R
, Op_Id
, N
);
4209 elsif Is_Overloadable
(Op_Id
) then
4210 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
4213 Op_Id
:= Homonym
(Op_Id
);
4218 end Analyze_Unary_Op
;
4220 ----------------------------------
4221 -- Analyze_Unchecked_Expression --
4222 ----------------------------------
4224 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
4226 Analyze
(Expression
(N
), Suppress
=> All_Checks
);
4227 Set_Etype
(N
, Etype
(Expression
(N
)));
4228 Save_Interps
(Expression
(N
), N
);
4229 end Analyze_Unchecked_Expression
;
4231 ---------------------------------------
4232 -- Analyze_Unchecked_Type_Conversion --
4233 ---------------------------------------
4235 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
4237 Find_Type
(Subtype_Mark
(N
));
4238 Analyze_Expression
(Expression
(N
));
4239 Set_Etype
(N
, Entity
(Subtype_Mark
(N
)));
4240 end Analyze_Unchecked_Type_Conversion
;
4242 ------------------------------------
4243 -- Analyze_User_Defined_Binary_Op --
4244 ------------------------------------
4246 procedure Analyze_User_Defined_Binary_Op
4251 -- Only do analysis if the operator Comes_From_Source, since otherwise
4252 -- the operator was generated by the expander, and all such operators
4253 -- always refer to the operators in package Standard.
4255 if Comes_From_Source
(N
) then
4257 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
4258 F2
: constant Entity_Id
:= Next_Formal
(F1
);
4261 -- Verify that Op_Id is a visible binary function. Note that since
4262 -- we know Op_Id is overloaded, potentially use visible means use
4263 -- visible for sure (RM 9.4(11)).
4265 if Ekind
(Op_Id
) = E_Function
4266 and then Present
(F2
)
4267 and then (Is_Immediately_Visible
(Op_Id
)
4268 or else Is_Potentially_Use_Visible
(Op_Id
))
4269 and then Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
4270 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
4272 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4274 -- If the left operand is overloaded, indicate that the
4275 -- current type is a viable candidate. This is redundant
4276 -- in most cases, but for equality and comparison operators
4277 -- where the context does not impose a type on the operands,
4278 -- setting the proper type is necessary to avoid subsequent
4279 -- ambiguities during resolution, when both user-defined and
4280 -- predefined operators may be candidates.
4282 if Is_Overloaded
(Left_Opnd
(N
)) then
4283 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
4286 if Debug_Flag_E
then
4287 Write_Str
("user defined operator ");
4288 Write_Name
(Chars
(Op_Id
));
4289 Write_Str
(" on node ");
4290 Write_Int
(Int
(N
));
4296 end Analyze_User_Defined_Binary_Op
;
4298 -----------------------------------
4299 -- Analyze_User_Defined_Unary_Op --
4300 -----------------------------------
4302 procedure Analyze_User_Defined_Unary_Op
4307 -- Only do analysis if the operator Comes_From_Source, since otherwise
4308 -- the operator was generated by the expander, and all such operators
4309 -- always refer to the operators in package Standard.
4311 if Comes_From_Source
(N
) then
4313 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
4316 -- Verify that Op_Id is a visible unary function. Note that since
4317 -- we know Op_Id is overloaded, potentially use visible means use
4318 -- visible for sure (RM 9.4(11)).
4320 if Ekind
(Op_Id
) = E_Function
4321 and then No
(Next_Formal
(F
))
4322 and then (Is_Immediately_Visible
(Op_Id
)
4323 or else Is_Potentially_Use_Visible
(Op_Id
))
4324 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
4326 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4330 end Analyze_User_Defined_Unary_Op
;
4332 ---------------------------
4333 -- Check_Arithmetic_Pair --
4334 ---------------------------
4336 procedure Check_Arithmetic_Pair
4337 (T1
, T2
: Entity_Id
;
4341 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
4343 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
4344 -- Check whether the fixed-point type Typ has a user-defined operator
4345 -- (multiplication or division) that should hide the corresponding
4346 -- predefined operator. Used to implement Ada 2005 AI-264, to make
4347 -- such operators more visible and therefore useful.
4349 -- If the name of the operation is an expanded name with prefix
4350 -- Standard, the predefined universal fixed operator is available,
4351 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
4353 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
4354 -- Get specific type (i.e. non-universal type if there is one)
4360 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
4361 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
4367 -- If the universal_fixed operation is given explicitly the rule
4368 -- concerning primitive operations of the type do not apply.
4370 if Nkind
(N
) = N_Function_Call
4371 and then Nkind
(Name
(N
)) = N_Expanded_Name
4372 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
4377 -- The operation is treated as primitive if it is declared in the
4378 -- same scope as the type, and therefore on the same entity chain.
4380 Ent
:= Next_Entity
(Typ
);
4381 while Present
(Ent
) loop
4382 if Chars
(Ent
) = Chars
(Op
) then
4383 F1
:= First_Formal
(Ent
);
4384 F2
:= Next_Formal
(F1
);
4386 -- The operation counts as primitive if either operand or
4387 -- result are of the given base type, and both operands are
4388 -- fixed point types.
4390 if (Base_Type
(Etype
(F1
)) = Bas
4391 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4394 (Base_Type
(Etype
(F2
)) = Bas
4395 and then Is_Fixed_Point_Type
(Etype
(F1
)))
4398 (Base_Type
(Etype
(Ent
)) = Bas
4399 and then Is_Fixed_Point_Type
(Etype
(F1
))
4400 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4416 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
4418 if T1
= Universal_Integer
or else T1
= Universal_Real
then
4419 return Base_Type
(T2
);
4421 return Base_Type
(T1
);
4425 -- Start of processing for Check_Arithmetic_Pair
4428 if Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
4430 if Is_Numeric_Type
(T1
)
4431 and then Is_Numeric_Type
(T2
)
4432 and then (Covers
(T1
=> T1
, T2
=> T2
)
4434 Covers
(T1
=> T2
, T2
=> T1
))
4436 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4439 elsif Op_Name
= Name_Op_Multiply
or else Op_Name
= Name_Op_Divide
then
4441 if Is_Fixed_Point_Type
(T1
)
4442 and then (Is_Fixed_Point_Type
(T2
)
4443 or else T2
= Universal_Real
)
4445 -- If Treat_Fixed_As_Integer is set then the Etype is already set
4446 -- and no further processing is required (this is the case of an
4447 -- operator constructed by Exp_Fixd for a fixed point operation)
4448 -- Otherwise add one interpretation with universal fixed result
4449 -- If the operator is given in functional notation, it comes
4450 -- from source and Fixed_As_Integer cannot apply.
4452 if (Nkind
(N
) not in N_Op
4453 or else not Treat_Fixed_As_Integer
(N
))
4455 (not Has_Fixed_Op
(T1
, Op_Id
)
4456 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4458 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4461 elsif Is_Fixed_Point_Type
(T2
)
4462 and then (Nkind
(N
) not in N_Op
4463 or else not Treat_Fixed_As_Integer
(N
))
4464 and then T1
= Universal_Real
4466 (not Has_Fixed_Op
(T1
, Op_Id
)
4467 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4469 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4471 elsif Is_Numeric_Type
(T1
)
4472 and then Is_Numeric_Type
(T2
)
4473 and then (Covers
(T1
=> T1
, T2
=> T2
)
4475 Covers
(T1
=> T2
, T2
=> T1
))
4477 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4479 elsif Is_Fixed_Point_Type
(T1
)
4480 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4481 or else T2
= Universal_Integer
)
4483 Add_One_Interp
(N
, Op_Id
, T1
);
4485 elsif T2
= Universal_Real
4486 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
4487 and then Op_Name
= Name_Op_Multiply
4489 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
4491 elsif T1
= Universal_Real
4492 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4494 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
4496 elsif Is_Fixed_Point_Type
(T2
)
4497 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
4498 or else T1
= Universal_Integer
)
4499 and then Op_Name
= Name_Op_Multiply
4501 Add_One_Interp
(N
, Op_Id
, T2
);
4503 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
4504 Add_One_Interp
(N
, Op_Id
, T1
);
4506 elsif T2
= Universal_Real
4507 and then T1
= Universal_Integer
4508 and then Op_Name
= Name_Op_Multiply
4510 Add_One_Interp
(N
, Op_Id
, T2
);
4513 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
4515 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
4516 -- set does not require any special processing, since the Etype is
4517 -- already set (case of operation constructed by Exp_Fixed).
4519 if Is_Integer_Type
(T1
)
4520 and then (Covers
(T1
=> T1
, T2
=> T2
)
4522 Covers
(T1
=> T2
, T2
=> T1
))
4524 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4527 elsif Op_Name
= Name_Op_Expon
then
4528 if Is_Numeric_Type
(T1
)
4529 and then not Is_Fixed_Point_Type
(T1
)
4530 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4531 or else T2
= Universal_Integer
)
4533 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
4536 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
4538 -- If not one of the predefined operators, the node may be one
4539 -- of the intrinsic functions. Its kind is always specific, and
4540 -- we can use it directly, rather than the name of the operation.
4542 if Is_Integer_Type
(T1
)
4543 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4544 or else T2
= Universal_Integer
)
4546 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
4549 end Check_Arithmetic_Pair
;
4551 -------------------------------
4552 -- Check_Misspelled_Selector --
4553 -------------------------------
4555 procedure Check_Misspelled_Selector
4556 (Prefix
: Entity_Id
;
4559 Max_Suggestions
: constant := 2;
4560 Nr_Of_Suggestions
: Natural := 0;
4562 Suggestion_1
: Entity_Id
:= Empty
;
4563 Suggestion_2
: Entity_Id
:= Empty
;
4568 -- All the components of the prefix of selector Sel are matched
4569 -- against Sel and a count is maintained of possible misspellings.
4570 -- When at the end of the analysis there are one or two (not more!)
4571 -- possible misspellings, these misspellings will be suggested as
4572 -- possible correction.
4574 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
4576 -- Concurrent types should be handled as well ???
4581 Comp
:= First_Entity
(Prefix
);
4582 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
4583 if Is_Visible_Component
(Comp
) then
4584 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
4585 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
4587 case Nr_Of_Suggestions
is
4588 when 1 => Suggestion_1
:= Comp
;
4589 when 2 => Suggestion_2
:= Comp
;
4590 when others => exit;
4595 Comp
:= Next_Entity
(Comp
);
4598 -- Report at most two suggestions
4600 if Nr_Of_Suggestions
= 1 then
4601 Error_Msg_NE
-- CODEFIX
4602 ("\possible misspelling of&", Sel
, Suggestion_1
);
4604 elsif Nr_Of_Suggestions
= 2 then
4605 Error_Msg_Node_2
:= Suggestion_2
;
4606 Error_Msg_NE
-- CODEFIX
4607 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
4609 end Check_Misspelled_Selector
;
4611 ----------------------
4612 -- Defined_In_Scope --
4613 ----------------------
4615 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean
4617 S1
: constant Entity_Id
:= Scope
(Base_Type
(T
));
4620 or else (S1
= System_Aux_Id
and then S
= Scope
(S1
));
4621 end Defined_In_Scope
;
4627 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
4633 Void_Interp_Seen
: Boolean := False;
4636 pragma Warnings
(Off
, Boolean);
4639 if Ada_Version
>= Ada_05
then
4640 Actual
:= First_Actual
(N
);
4641 while Present
(Actual
) loop
4643 -- Ada 2005 (AI-50217): Post an error in case of premature
4644 -- usage of an entity from the limited view.
4646 if not Analyzed
(Etype
(Actual
))
4647 and then From_With_Type
(Etype
(Actual
))
4649 Error_Msg_Qual_Level
:= 1;
4651 ("missing with_clause for scope of imported type&",
4652 Actual
, Etype
(Actual
));
4653 Error_Msg_Qual_Level
:= 0;
4656 Next_Actual
(Actual
);
4660 -- Analyze each candidate call again, with full error reporting
4664 ("no candidate interpretations match the actuals:!", Nam
);
4665 Err_Mode
:= All_Errors_Mode
;
4666 All_Errors_Mode
:= True;
4668 -- If this is a call to an operation of a concurrent type,
4669 -- the failed interpretations have been removed from the
4670 -- name. Recover them to provide full diagnostics.
4672 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
4673 Set_Entity
(Nam
, Empty
);
4674 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
4675 Set_Is_Overloaded
(New_Nam
, False);
4676 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
4677 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
4678 Analyze_Selected_Component
(New_Nam
);
4679 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
4681 Get_First_Interp
(Nam
, X
, It
);
4684 while Present
(It
.Nam
) loop
4685 if Etype
(It
.Nam
) = Standard_Void_Type
then
4686 Void_Interp_Seen
:= True;
4689 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
4690 Get_Next_Interp
(X
, It
);
4693 if Nkind
(N
) = N_Function_Call
then
4694 Get_First_Interp
(Nam
, X
, It
);
4695 while Present
(It
.Nam
) loop
4696 if Ekind_In
(It
.Nam
, E_Function
, E_Operator
) then
4699 Get_Next_Interp
(X
, It
);
4703 -- If all interpretations are procedures, this deserves a
4704 -- more precise message. Ditto if this appears as the prefix
4705 -- of a selected component, which may be a lexical error.
4708 ("\context requires function call, found procedure name", Nam
);
4710 if Nkind
(Parent
(N
)) = N_Selected_Component
4711 and then N
= Prefix
(Parent
(N
))
4713 Error_Msg_N
-- CODEFIX
4714 ("\period should probably be semicolon", Parent
(N
));
4717 elsif Nkind
(N
) = N_Procedure_Call_Statement
4718 and then not Void_Interp_Seen
4721 "\function name found in procedure call", Nam
);
4724 All_Errors_Mode
:= Err_Mode
;
4727 ---------------------------
4728 -- Find_Arithmetic_Types --
4729 ---------------------------
4731 procedure Find_Arithmetic_Types
4736 Index1
: Interp_Index
;
4737 Index2
: Interp_Index
;
4741 procedure Check_Right_Argument
(T
: Entity_Id
);
4742 -- Check right operand of operator
4744 --------------------------
4745 -- Check_Right_Argument --
4746 --------------------------
4748 procedure Check_Right_Argument
(T
: Entity_Id
) is
4750 if not Is_Overloaded
(R
) then
4751 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
4753 Get_First_Interp
(R
, Index2
, It2
);
4754 while Present
(It2
.Typ
) loop
4755 Check_Arithmetic_Pair
(T
, It2
.Typ
, Op_Id
, N
);
4756 Get_Next_Interp
(Index2
, It2
);
4759 end Check_Right_Argument
;
4761 -- Start of processing for Find_Arithmetic_Types
4764 if not Is_Overloaded
(L
) then
4765 Check_Right_Argument
(Etype
(L
));
4768 Get_First_Interp
(L
, Index1
, It1
);
4769 while Present
(It1
.Typ
) loop
4770 Check_Right_Argument
(It1
.Typ
);
4771 Get_Next_Interp
(Index1
, It1
);
4775 end Find_Arithmetic_Types
;
4777 ------------------------
4778 -- Find_Boolean_Types --
4779 ------------------------
4781 procedure Find_Boolean_Types
4786 Index
: Interp_Index
;
4789 procedure Check_Numeric_Argument
(T
: Entity_Id
);
4790 -- Special case for logical operations one of whose operands is an
4791 -- integer literal. If both are literal the result is any modular type.
4793 ----------------------------
4794 -- Check_Numeric_Argument --
4795 ----------------------------
4797 procedure Check_Numeric_Argument
(T
: Entity_Id
) is
4799 if T
= Universal_Integer
then
4800 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
4802 elsif Is_Modular_Integer_Type
(T
) then
4803 Add_One_Interp
(N
, Op_Id
, T
);
4805 end Check_Numeric_Argument
;
4807 -- Start of processing for Find_Boolean_Types
4810 if not Is_Overloaded
(L
) then
4811 if Etype
(L
) = Universal_Integer
4812 or else Etype
(L
) = Any_Modular
4814 if not Is_Overloaded
(R
) then
4815 Check_Numeric_Argument
(Etype
(R
));
4818 Get_First_Interp
(R
, Index
, It
);
4819 while Present
(It
.Typ
) loop
4820 Check_Numeric_Argument
(It
.Typ
);
4821 Get_Next_Interp
(Index
, It
);
4825 -- If operands are aggregates, we must assume that they may be
4826 -- boolean arrays, and leave disambiguation for the second pass.
4827 -- If only one is an aggregate, verify that the other one has an
4828 -- interpretation as a boolean array
4830 elsif Nkind
(L
) = N_Aggregate
then
4831 if Nkind
(R
) = N_Aggregate
then
4832 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
4834 elsif not Is_Overloaded
(R
) then
4835 if Valid_Boolean_Arg
(Etype
(R
)) then
4836 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
4840 Get_First_Interp
(R
, Index
, It
);
4841 while Present
(It
.Typ
) loop
4842 if Valid_Boolean_Arg
(It
.Typ
) then
4843 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
4846 Get_Next_Interp
(Index
, It
);
4850 elsif Valid_Boolean_Arg
(Etype
(L
))
4851 and then Has_Compatible_Type
(R
, Etype
(L
))
4853 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
4857 Get_First_Interp
(L
, Index
, It
);
4858 while Present
(It
.Typ
) loop
4859 if Valid_Boolean_Arg
(It
.Typ
)
4860 and then Has_Compatible_Type
(R
, It
.Typ
)
4862 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
4865 Get_Next_Interp
(Index
, It
);
4868 end Find_Boolean_Types
;
4870 ---------------------------
4871 -- Find_Comparison_Types --
4872 ---------------------------
4874 procedure Find_Comparison_Types
4879 Index
: Interp_Index
;
4881 Found
: Boolean := False;
4884 Scop
: Entity_Id
:= Empty
;
4886 procedure Try_One_Interp
(T1
: Entity_Id
);
4887 -- Routine to try one proposed interpretation. Note that the context
4888 -- of the operator plays no role in resolving the arguments, so that
4889 -- if there is more than one interpretation of the operands that is
4890 -- compatible with comparison, the operation is ambiguous.
4892 --------------------
4893 -- Try_One_Interp --
4894 --------------------
4896 procedure Try_One_Interp
(T1
: Entity_Id
) is
4899 -- If the operator is an expanded name, then the type of the operand
4900 -- must be defined in the corresponding scope. If the type is
4901 -- universal, the context will impose the correct type.
4904 and then not Defined_In_Scope
(T1
, Scop
)
4905 and then T1
/= Universal_Integer
4906 and then T1
/= Universal_Real
4907 and then T1
/= Any_String
4908 and then T1
/= Any_Composite
4913 if Valid_Comparison_Arg
(T1
)
4914 and then Has_Compatible_Type
(R
, T1
)
4917 and then Base_Type
(T1
) /= Base_Type
(T_F
)
4919 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
4921 if It
= No_Interp
then
4922 Ambiguous_Operands
(N
);
4923 Set_Etype
(L
, Any_Type
);
4937 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
4942 -- Start of processing for Find_Comparison_Types
4945 -- If left operand is aggregate, the right operand has to
4946 -- provide a usable type for it.
4948 if Nkind
(L
) = N_Aggregate
4949 and then Nkind
(R
) /= N_Aggregate
4951 Find_Comparison_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
4955 if Nkind
(N
) = N_Function_Call
4956 and then Nkind
(Name
(N
)) = N_Expanded_Name
4958 Scop
:= Entity
(Prefix
(Name
(N
)));
4960 -- The prefix may be a package renaming, and the subsequent test
4961 -- requires the original package.
4963 if Ekind
(Scop
) = E_Package
4964 and then Present
(Renamed_Entity
(Scop
))
4966 Scop
:= Renamed_Entity
(Scop
);
4967 Set_Entity
(Prefix
(Name
(N
)), Scop
);
4971 if not Is_Overloaded
(L
) then
4972 Try_One_Interp
(Etype
(L
));
4975 Get_First_Interp
(L
, Index
, It
);
4976 while Present
(It
.Typ
) loop
4977 Try_One_Interp
(It
.Typ
);
4978 Get_Next_Interp
(Index
, It
);
4981 end Find_Comparison_Types
;
4983 ----------------------------------------
4984 -- Find_Non_Universal_Interpretations --
4985 ----------------------------------------
4987 procedure Find_Non_Universal_Interpretations
4993 Index
: Interp_Index
;
4997 if T1
= Universal_Integer
4998 or else T1
= Universal_Real
5000 if not Is_Overloaded
(R
) then
5002 (N
, Op_Id
, Standard_Boolean
, Base_Type
(Etype
(R
)));
5004 Get_First_Interp
(R
, Index
, It
);
5005 while Present
(It
.Typ
) loop
5006 if Covers
(It
.Typ
, T1
) then
5008 (N
, Op_Id
, Standard_Boolean
, Base_Type
(It
.Typ
));
5011 Get_Next_Interp
(Index
, It
);
5015 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(T1
));
5017 end Find_Non_Universal_Interpretations
;
5019 ------------------------------
5020 -- Find_Concatenation_Types --
5021 ------------------------------
5023 procedure Find_Concatenation_Types
5028 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
5031 if Is_Array_Type
(Op_Type
)
5032 and then not Is_Limited_Type
(Op_Type
)
5034 and then (Has_Compatible_Type
(L
, Op_Type
)
5036 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
5038 and then (Has_Compatible_Type
(R
, Op_Type
)
5040 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
5042 Add_One_Interp
(N
, Op_Id
, Op_Type
);
5044 end Find_Concatenation_Types
;
5046 -------------------------
5047 -- Find_Equality_Types --
5048 -------------------------
5050 procedure Find_Equality_Types
5055 Index
: Interp_Index
;
5057 Found
: Boolean := False;
5060 Scop
: Entity_Id
:= Empty
;
5062 procedure Try_One_Interp
(T1
: Entity_Id
);
5063 -- The context of the equality operator plays no role in resolving the
5064 -- arguments, so that if there is more than one interpretation of the
5065 -- operands that is compatible with equality, the construct is ambiguous
5066 -- and an error can be emitted now, after trying to disambiguate, i.e.
5067 -- applying preference rules.
5069 --------------------
5070 -- Try_One_Interp --
5071 --------------------
5073 procedure Try_One_Interp
(T1
: Entity_Id
) is
5074 Bas
: constant Entity_Id
:= Base_Type
(T1
);
5077 -- If the operator is an expanded name, then the type of the operand
5078 -- must be defined in the corresponding scope. If the type is
5079 -- universal, the context will impose the correct type. An anonymous
5080 -- type for a 'Access reference is also universal in this sense, as
5081 -- the actual type is obtained from context.
5082 -- In Ada 2005, the equality operator for anonymous access types
5083 -- is declared in Standard, and preference rules apply to it.
5085 if Present
(Scop
) then
5086 if Defined_In_Scope
(T1
, Scop
)
5087 or else T1
= Universal_Integer
5088 or else T1
= Universal_Real
5089 or else T1
= Any_Access
5090 or else T1
= Any_String
5091 or else T1
= Any_Composite
5092 or else (Ekind
(T1
) = E_Access_Subprogram_Type
5093 and then not Comes_From_Source
(T1
))
5097 elsif Ekind
(T1
) = E_Anonymous_Access_Type
5098 and then Scop
= Standard_Standard
5103 -- The scope does not contain an operator for the type
5108 -- If we have infix notation, the operator must be usable.
5109 -- Within an instance, if the type is already established we
5110 -- know it is correct.
5111 -- In Ada 2005, the equality on anonymous access types is declared
5112 -- in Standard, and is always visible.
5114 elsif In_Open_Scopes
(Scope
(Bas
))
5115 or else Is_Potentially_Use_Visible
(Bas
)
5116 or else In_Use
(Bas
)
5117 or else (In_Use
(Scope
(Bas
))
5118 and then not Is_Hidden
(Bas
))
5119 or else (In_Instance
5120 and then First_Subtype
(T1
) = First_Subtype
(Etype
(R
)))
5121 or else Ekind
(T1
) = E_Anonymous_Access_Type
5126 -- Save candidate type for subsquent error message, if any
5128 if not Is_Limited_Type
(T1
) then
5129 Candidate_Type
:= T1
;
5135 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
5136 -- Do not allow anonymous access types in equality operators.
5138 if Ada_Version
< Ada_05
5139 and then Ekind
(T1
) = E_Anonymous_Access_Type
5144 if T1
/= Standard_Void_Type
5145 and then not Is_Limited_Type
(T1
)
5146 and then not Is_Limited_Composite
(T1
)
5147 and then Has_Compatible_Type
(R
, T1
)
5150 and then Base_Type
(T1
) /= Base_Type
(T_F
)
5152 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
5154 if It
= No_Interp
then
5155 Ambiguous_Operands
(N
);
5156 Set_Etype
(L
, Any_Type
);
5169 if not Analyzed
(L
) then
5173 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
5175 -- Case of operator was not visible, Etype still set to Any_Type
5177 if Etype
(N
) = Any_Type
then
5181 elsif Scop
= Standard_Standard
5182 and then Ekind
(T1
) = E_Anonymous_Access_Type
5188 -- Start of processing for Find_Equality_Types
5191 -- If left operand is aggregate, the right operand has to
5192 -- provide a usable type for it.
5194 if Nkind
(L
) = N_Aggregate
5195 and then Nkind
(R
) /= N_Aggregate
5197 Find_Equality_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
5201 if Nkind
(N
) = N_Function_Call
5202 and then Nkind
(Name
(N
)) = N_Expanded_Name
5204 Scop
:= Entity
(Prefix
(Name
(N
)));
5206 -- The prefix may be a package renaming, and the subsequent test
5207 -- requires the original package.
5209 if Ekind
(Scop
) = E_Package
5210 and then Present
(Renamed_Entity
(Scop
))
5212 Scop
:= Renamed_Entity
(Scop
);
5213 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5217 if not Is_Overloaded
(L
) then
5218 Try_One_Interp
(Etype
(L
));
5221 Get_First_Interp
(L
, Index
, It
);
5222 while Present
(It
.Typ
) loop
5223 Try_One_Interp
(It
.Typ
);
5224 Get_Next_Interp
(Index
, It
);
5227 end Find_Equality_Types
;
5229 -------------------------
5230 -- Find_Negation_Types --
5231 -------------------------
5233 procedure Find_Negation_Types
5238 Index
: Interp_Index
;
5242 if not Is_Overloaded
(R
) then
5243 if Etype
(R
) = Universal_Integer
then
5244 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5245 elsif Valid_Boolean_Arg
(Etype
(R
)) then
5246 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5250 Get_First_Interp
(R
, Index
, It
);
5251 while Present
(It
.Typ
) loop
5252 if Valid_Boolean_Arg
(It
.Typ
) then
5253 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5256 Get_Next_Interp
(Index
, It
);
5259 end Find_Negation_Types
;
5261 ------------------------------
5262 -- Find_Primitive_Operation --
5263 ------------------------------
5265 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
5266 Obj
: constant Node_Id
:= Prefix
(N
);
5267 Op
: constant Node_Id
:= Selector_Name
(N
);
5274 Set_Etype
(Op
, Any_Type
);
5276 if Is_Access_Type
(Etype
(Obj
)) then
5277 Typ
:= Designated_Type
(Etype
(Obj
));
5282 if Is_Class_Wide_Type
(Typ
) then
5283 Typ
:= Root_Type
(Typ
);
5286 Prims
:= Primitive_Operations
(Typ
);
5288 Prim
:= First_Elmt
(Prims
);
5289 while Present
(Prim
) loop
5290 if Chars
(Node
(Prim
)) = Chars
(Op
) then
5291 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
5292 Set_Etype
(N
, Etype
(Node
(Prim
)));
5298 -- Now look for class-wide operations of the type or any of its
5299 -- ancestors by iterating over the homonyms of the selector.
5302 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
5306 Hom
:= Current_Entity
(Op
);
5307 while Present
(Hom
) loop
5308 if (Ekind
(Hom
) = E_Procedure
5310 Ekind
(Hom
) = E_Function
)
5311 and then Scope
(Hom
) = Scope
(Typ
)
5312 and then Present
(First_Formal
(Hom
))
5314 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
5316 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
5318 Ekind
(Etype
(First_Formal
(Hom
))) =
5319 E_Anonymous_Access_Type
5322 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
5325 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
5326 Set_Etype
(N
, Etype
(Hom
));
5329 Hom
:= Homonym
(Hom
);
5333 return Etype
(Op
) /= Any_Type
;
5334 end Find_Primitive_Operation
;
5336 ----------------------
5337 -- Find_Unary_Types --
5338 ----------------------
5340 procedure Find_Unary_Types
5345 Index
: Interp_Index
;
5349 if not Is_Overloaded
(R
) then
5350 if Is_Numeric_Type
(Etype
(R
)) then
5351 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
5355 Get_First_Interp
(R
, Index
, It
);
5356 while Present
(It
.Typ
) loop
5357 if Is_Numeric_Type
(It
.Typ
) then
5358 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
5361 Get_Next_Interp
(Index
, It
);
5364 end Find_Unary_Types
;
5370 function Junk_Operand
(N
: Node_Id
) return Boolean is
5374 if Error_Posted
(N
) then
5378 -- Get entity to be tested
5380 if Is_Entity_Name
(N
)
5381 and then Present
(Entity
(N
))
5385 -- An odd case, a procedure name gets converted to a very peculiar
5386 -- function call, and here is where we detect this happening.
5388 elsif Nkind
(N
) = N_Function_Call
5389 and then Is_Entity_Name
(Name
(N
))
5390 and then Present
(Entity
(Name
(N
)))
5394 -- Another odd case, there are at least some cases of selected
5395 -- components where the selected component is not marked as having
5396 -- an entity, even though the selector does have an entity
5398 elsif Nkind
(N
) = N_Selected_Component
5399 and then Present
(Entity
(Selector_Name
(N
)))
5401 Enode
:= Selector_Name
(N
);
5407 -- Now test the entity we got to see if it is a bad case
5409 case Ekind
(Entity
(Enode
)) is
5413 ("package name cannot be used as operand", Enode
);
5415 when Generic_Unit_Kind
=>
5417 ("generic unit name cannot be used as operand", Enode
);
5421 ("subtype name cannot be used as operand", Enode
);
5425 ("entry name cannot be used as operand", Enode
);
5429 ("procedure name cannot be used as operand", Enode
);
5433 ("exception name cannot be used as operand", Enode
);
5435 when E_Block | E_Label | E_Loop
=>
5437 ("label name cannot be used as operand", Enode
);
5447 --------------------
5448 -- Operator_Check --
5449 --------------------
5451 procedure Operator_Check
(N
: Node_Id
) is
5453 Remove_Abstract_Operations
(N
);
5455 -- Test for case of no interpretation found for operator
5457 if Etype
(N
) = Any_Type
then
5461 Op_Id
: Entity_Id
:= Empty
;
5464 R
:= Right_Opnd
(N
);
5466 if Nkind
(N
) in N_Binary_Op
then
5472 -- If either operand has no type, then don't complain further,
5473 -- since this simply means that we have a propagated error.
5476 or else Etype
(R
) = Any_Type
5477 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
5481 -- We explicitly check for the case of concatenation of component
5482 -- with component to avoid reporting spurious matching array types
5483 -- that might happen to be lurking in distant packages (such as
5484 -- run-time packages). This also prevents inconsistencies in the
5485 -- messages for certain ACVC B tests, which can vary depending on
5486 -- types declared in run-time interfaces. Another improvement when
5487 -- aggregates are present is to look for a well-typed operand.
5489 elsif Present
(Candidate_Type
)
5490 and then (Nkind
(N
) /= N_Op_Concat
5491 or else Is_Array_Type
(Etype
(L
))
5492 or else Is_Array_Type
(Etype
(R
)))
5495 if Nkind
(N
) = N_Op_Concat
then
5496 if Etype
(L
) /= Any_Composite
5497 and then Is_Array_Type
(Etype
(L
))
5499 Candidate_Type
:= Etype
(L
);
5501 elsif Etype
(R
) /= Any_Composite
5502 and then Is_Array_Type
(Etype
(R
))
5504 Candidate_Type
:= Etype
(R
);
5508 Error_Msg_NE
-- CODEFIX
5509 ("operator for} is not directly visible!",
5510 N
, First_Subtype
(Candidate_Type
));
5511 Error_Msg_N
-- CODEFIX
5512 ("use clause would make operation legal!", N
);
5515 -- If either operand is a junk operand (e.g. package name), then
5516 -- post appropriate error messages, but do not complain further.
5518 -- Note that the use of OR in this test instead of OR ELSE is
5519 -- quite deliberate, we may as well check both operands in the
5520 -- binary operator case.
5522 elsif Junk_Operand
(R
)
5523 or (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
5527 -- If we have a logical operator, one of whose operands is
5528 -- Boolean, then we know that the other operand cannot resolve to
5529 -- Boolean (since we got no interpretations), but in that case we
5530 -- pretty much know that the other operand should be Boolean, so
5531 -- resolve it that way (generating an error)
5533 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
) then
5534 if Etype
(L
) = Standard_Boolean
then
5535 Resolve
(R
, Standard_Boolean
);
5537 elsif Etype
(R
) = Standard_Boolean
then
5538 Resolve
(L
, Standard_Boolean
);
5542 -- For an arithmetic operator or comparison operator, if one
5543 -- of the operands is numeric, then we know the other operand
5544 -- is not the same numeric type. If it is a non-numeric type,
5545 -- then probably it is intended to match the other operand.
5547 elsif Nkind_In
(N
, N_Op_Add
,
5553 Nkind_In
(N
, N_Op_Lt
,
5559 if Is_Numeric_Type
(Etype
(L
))
5560 and then not Is_Numeric_Type
(Etype
(R
))
5562 Resolve
(R
, Etype
(L
));
5565 elsif Is_Numeric_Type
(Etype
(R
))
5566 and then not Is_Numeric_Type
(Etype
(L
))
5568 Resolve
(L
, Etype
(R
));
5572 -- Comparisons on A'Access are common enough to deserve a
5575 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
5576 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
5577 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
5580 ("two access attributes cannot be compared directly", N
);
5582 ("\use qualified expression for one of the operands",
5586 -- Another one for C programmers
5588 elsif Nkind
(N
) = N_Op_Concat
5589 and then Valid_Boolean_Arg
(Etype
(L
))
5590 and then Valid_Boolean_Arg
(Etype
(R
))
5592 Error_Msg_N
("invalid operands for concatenation", N
);
5593 Error_Msg_N
-- CODEFIX
5594 ("\maybe AND was meant", N
);
5597 -- A special case for comparison of access parameter with null
5599 elsif Nkind
(N
) = N_Op_Eq
5600 and then Is_Entity_Name
(L
)
5601 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
5602 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
5604 and then Nkind
(R
) = N_Null
5606 Error_Msg_N
("access parameter is not allowed to be null", L
);
5607 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
5610 -- Another special case for exponentiation, where the right
5611 -- operand must be Natural, independently of the base.
5613 elsif Nkind
(N
) = N_Op_Expon
5614 and then Is_Numeric_Type
(Etype
(L
))
5615 and then not Is_Overloaded
(R
)
5617 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
5618 and then Base_Type
(Etype
(R
)) /= Universal_Integer
5621 ("exponent must be of type Natural, found}", R
, Etype
(R
));
5625 -- If we fall through then just give general message. Note that in
5626 -- the following messages, if the operand is overloaded we choose
5627 -- an arbitrary type to complain about, but that is probably more
5628 -- useful than not giving a type at all.
5630 if Nkind
(N
) in N_Unary_Op
then
5631 Error_Msg_Node_2
:= Etype
(R
);
5632 Error_Msg_N
("operator& not defined for}", N
);
5636 if Nkind
(N
) in N_Binary_Op
then
5637 if not Is_Overloaded
(L
)
5638 and then not Is_Overloaded
(R
)
5639 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
5641 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
5642 Error_Msg_N
("there is no applicable operator& for}", N
);
5645 -- Another attempt to find a fix: one of the candidate
5646 -- interpretations may not be use-visible. This has
5647 -- already been checked for predefined operators, so
5648 -- we examine only user-defined functions.
5650 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
5652 while Present
(Op_Id
) loop
5653 if Ekind
(Op_Id
) /= E_Operator
5654 and then Is_Overloadable
(Op_Id
)
5656 if not Is_Immediately_Visible
(Op_Id
)
5657 and then not In_Use
(Scope
(Op_Id
))
5658 and then not Is_Abstract_Subprogram
(Op_Id
)
5659 and then not Is_Hidden
(Op_Id
)
5660 and then Ekind
(Scope
(Op_Id
)) = E_Package
5663 (L
, Etype
(First_Formal
(Op_Id
)))
5665 (Next_Formal
(First_Formal
(Op_Id
)))
5669 Etype
(Next_Formal
(First_Formal
(Op_Id
))))
5672 ("No legal interpretation for operator&", N
);
5674 ("\use clause on& would make operation legal",
5680 Op_Id
:= Homonym
(Op_Id
);
5684 Error_Msg_N
("invalid operand types for operator&", N
);
5686 if Nkind
(N
) /= N_Op_Concat
then
5687 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
5688 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
5698 -----------------------------------------
5699 -- Process_Implicit_Dereference_Prefix --
5700 -----------------------------------------
5702 function Process_Implicit_Dereference_Prefix
5704 P
: Entity_Id
) return Entity_Id
5707 Typ
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
5711 and then (Operating_Mode
= Check_Semantics
or else not Expander_Active
)
5713 -- We create a dummy reference to E to ensure that the reference
5714 -- is not considered as part of an assignment (an implicit
5715 -- dereference can never assign to its prefix). The Comes_From_Source
5716 -- attribute needs to be propagated for accurate warnings.
5718 Ref
:= New_Reference_To
(E
, Sloc
(P
));
5719 Set_Comes_From_Source
(Ref
, Comes_From_Source
(P
));
5720 Generate_Reference
(E
, Ref
);
5723 -- An implicit dereference is a legal occurrence of an
5724 -- incomplete type imported through a limited_with clause,
5725 -- if the full view is visible.
5727 if From_With_Type
(Typ
)
5728 and then not From_With_Type
(Scope
(Typ
))
5730 (Is_Immediately_Visible
(Scope
(Typ
))
5732 (Is_Child_Unit
(Scope
(Typ
))
5733 and then Is_Visible_Child_Unit
(Scope
(Typ
))))
5735 return Available_View
(Typ
);
5740 end Process_Implicit_Dereference_Prefix
;
5742 --------------------------------
5743 -- Remove_Abstract_Operations --
5744 --------------------------------
5746 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
5747 Abstract_Op
: Entity_Id
:= Empty
;
5748 Address_Kludge
: Boolean := False;
5752 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
5753 -- activate this if either extensions are enabled, or if the abstract
5754 -- operation in question comes from a predefined file. This latter test
5755 -- allows us to use abstract to make operations invisible to users. In
5756 -- particular, if type Address is non-private and abstract subprograms
5757 -- are used to hide its operators, they will be truly hidden.
5759 type Operand_Position
is (First_Op
, Second_Op
);
5760 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
5762 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
5763 -- Ambiguities may arise when the operands are literal and the address
5764 -- operations in s-auxdec are visible. In that case, remove the
5765 -- interpretation of a literal as Address, to retain the semantics of
5766 -- Address as a private type.
5768 ------------------------------------
5769 -- Remove_Address_Interpretations --
5770 ------------------------------------
5772 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
5776 if Is_Overloaded
(N
) then
5777 Get_First_Interp
(N
, I
, It
);
5778 while Present
(It
.Nam
) loop
5779 Formal
:= First_Entity
(It
.Nam
);
5781 if Op
= Second_Op
then
5782 Formal
:= Next_Entity
(Formal
);
5785 if Is_Descendent_Of_Address
(Etype
(Formal
)) then
5786 Address_Kludge
:= True;
5790 Get_Next_Interp
(I
, It
);
5793 end Remove_Address_Interpretations
;
5795 -- Start of processing for Remove_Abstract_Operations
5798 if Is_Overloaded
(N
) then
5799 Get_First_Interp
(N
, I
, It
);
5801 while Present
(It
.Nam
) loop
5802 if Is_Overloadable
(It
.Nam
)
5803 and then Is_Abstract_Subprogram
(It
.Nam
)
5804 and then not Is_Dispatching_Operation
(It
.Nam
)
5806 Abstract_Op
:= It
.Nam
;
5808 if Is_Descendent_Of_Address
(It
.Typ
) then
5809 Address_Kludge
:= True;
5813 -- In Ada 2005, this operation does not participate in Overload
5814 -- resolution. If the operation is defined in a predefined
5815 -- unit, it is one of the operations declared abstract in some
5816 -- variants of System, and it must be removed as well.
5818 elsif Ada_Version
>= Ada_05
5819 or else Is_Predefined_File_Name
5820 (Unit_File_Name
(Get_Source_Unit
(It
.Nam
)))
5827 Get_Next_Interp
(I
, It
);
5830 if No
(Abstract_Op
) then
5832 -- If some interpretation yields an integer type, it is still
5833 -- possible that there are address interpretations. Remove them
5834 -- if one operand is a literal, to avoid spurious ambiguities
5835 -- on systems where Address is a visible integer type.
5837 if Is_Overloaded
(N
)
5838 and then Nkind
(N
) in N_Op
5839 and then Is_Integer_Type
(Etype
(N
))
5841 if Nkind
(N
) in N_Binary_Op
then
5842 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
5843 Remove_Address_Interpretations
(Second_Op
);
5845 elsif Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
5846 Remove_Address_Interpretations
(First_Op
);
5851 elsif Nkind
(N
) in N_Op
then
5853 -- Remove interpretations that treat literals as addresses. This
5854 -- is never appropriate, even when Address is defined as a visible
5855 -- Integer type. The reason is that we would really prefer Address
5856 -- to behave as a private type, even in this case, which is there
5857 -- only to accommodate oddities of VMS address sizes. If Address
5858 -- is a visible integer type, we get lots of overload ambiguities.
5860 if Nkind
(N
) in N_Binary_Op
then
5862 U1
: constant Boolean :=
5863 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
5864 U2
: constant Boolean :=
5865 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
5869 Remove_Address_Interpretations
(Second_Op
);
5873 Remove_Address_Interpretations
(First_Op
);
5876 if not (U1
and U2
) then
5878 -- Remove corresponding predefined operator, which is
5879 -- always added to the overload set.
5881 Get_First_Interp
(N
, I
, It
);
5882 while Present
(It
.Nam
) loop
5883 if Scope
(It
.Nam
) = Standard_Standard
5884 and then Base_Type
(It
.Typ
) =
5885 Base_Type
(Etype
(Abstract_Op
))
5890 Get_Next_Interp
(I
, It
);
5893 elsif Is_Overloaded
(N
)
5894 and then Present
(Univ_Type
)
5896 -- If both operands have a universal interpretation,
5897 -- it is still necessary to remove interpretations that
5898 -- yield Address. Any remaining ambiguities will be
5899 -- removed in Disambiguate.
5901 Get_First_Interp
(N
, I
, It
);
5902 while Present
(It
.Nam
) loop
5903 if Is_Descendent_Of_Address
(It
.Typ
) then
5906 elsif not Is_Type
(It
.Nam
) then
5907 Set_Entity
(N
, It
.Nam
);
5910 Get_Next_Interp
(I
, It
);
5916 elsif Nkind
(N
) = N_Function_Call
5918 (Nkind
(Name
(N
)) = N_Operator_Symbol
5920 (Nkind
(Name
(N
)) = N_Expanded_Name
5922 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
5926 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
5927 U1
: constant Boolean :=
5928 Present
(Universal_Interpretation
(Arg1
));
5929 U2
: constant Boolean :=
5930 Present
(Next
(Arg1
)) and then
5931 Present
(Universal_Interpretation
(Next
(Arg1
)));
5935 Remove_Address_Interpretations
(First_Op
);
5939 Remove_Address_Interpretations
(Second_Op
);
5942 if not (U1
and U2
) then
5943 Get_First_Interp
(N
, I
, It
);
5944 while Present
(It
.Nam
) loop
5945 if Scope
(It
.Nam
) = Standard_Standard
5946 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
5951 Get_Next_Interp
(I
, It
);
5957 -- If the removal has left no valid interpretations, emit an error
5958 -- message now and label node as illegal.
5960 if Present
(Abstract_Op
) then
5961 Get_First_Interp
(N
, I
, It
);
5965 -- Removal of abstract operation left no viable candidate
5967 Set_Etype
(N
, Any_Type
);
5968 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
5970 ("cannot call abstract operation& declared#", N
, Abstract_Op
);
5972 -- In Ada 2005, an abstract operation may disable predefined
5973 -- operators. Since the context is not yet known, we mark the
5974 -- predefined operators as potentially hidden. Do not include
5975 -- predefined operators when addresses are involved since this
5976 -- case is handled separately.
5978 elsif Ada_Version
>= Ada_05
5979 and then not Address_Kludge
5981 while Present
(It
.Nam
) loop
5982 if Is_Numeric_Type
(It
.Typ
)
5983 and then Scope
(It
.Typ
) = Standard_Standard
5985 Set_Abstract_Op
(I
, Abstract_Op
);
5988 Get_Next_Interp
(I
, It
);
5993 end Remove_Abstract_Operations
;
5995 -----------------------
5996 -- Try_Indirect_Call --
5997 -----------------------
5999 function Try_Indirect_Call
6002 Typ
: Entity_Id
) return Boolean
6008 pragma Warnings
(Off
, Call_OK
);
6011 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
6013 Actual
:= First_Actual
(N
);
6014 Formal
:= First_Formal
(Designated_Type
(Typ
));
6015 while Present
(Actual
) and then Present
(Formal
) loop
6016 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
6021 Next_Formal
(Formal
);
6024 if No
(Actual
) and then No
(Formal
) then
6025 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
6027 -- Nam is a candidate interpretation for the name in the call,
6028 -- if it is not an indirect call.
6030 if not Is_Type
(Nam
)
6031 and then Is_Entity_Name
(Name
(N
))
6033 Set_Entity
(Name
(N
), Nam
);
6040 end Try_Indirect_Call
;
6042 ----------------------
6043 -- Try_Indexed_Call --
6044 ----------------------
6046 function Try_Indexed_Call
6050 Skip_First
: Boolean) return Boolean
6052 Loc
: constant Source_Ptr
:= Sloc
(N
);
6053 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
6058 Actual
:= First
(Actuals
);
6060 -- If the call was originally written in prefix form, skip the first
6061 -- actual, which is obviously not defaulted.
6067 Index
:= First_Index
(Typ
);
6068 while Present
(Actual
) and then Present
(Index
) loop
6070 -- If the parameter list has a named association, the expression
6071 -- is definitely a call and not an indexed component.
6073 if Nkind
(Actual
) = N_Parameter_Association
then
6077 if Is_Entity_Name
(Actual
)
6078 and then Is_Type
(Entity
(Actual
))
6079 and then No
(Next
(Actual
))
6083 Prefix
=> Make_Function_Call
(Loc
,
6084 Name
=> Relocate_Node
(Name
(N
))),
6086 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
6091 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
6099 if No
(Actual
) and then No
(Index
) then
6100 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
6102 -- Nam is a candidate interpretation for the name in the call,
6103 -- if it is not an indirect call.
6105 if not Is_Type
(Nam
)
6106 and then Is_Entity_Name
(Name
(N
))
6108 Set_Entity
(Name
(N
), Nam
);
6115 end Try_Indexed_Call
;
6117 --------------------------
6118 -- Try_Object_Operation --
6119 --------------------------
6121 function Try_Object_Operation
(N
: Node_Id
) return Boolean is
6122 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
6123 Is_Subprg_Call
: constant Boolean := Nkind_In
6124 (K
, N_Procedure_Call_Statement
,
6126 Loc
: constant Source_Ptr
:= Sloc
(N
);
6127 Obj
: constant Node_Id
:= Prefix
(N
);
6128 Subprog
: constant Node_Id
:=
6129 Make_Identifier
(Sloc
(Selector_Name
(N
)),
6130 Chars
=> Chars
(Selector_Name
(N
)));
6131 -- Identifier on which possible interpretations will be collected
6133 Report_Error
: Boolean := False;
6134 -- If no candidate interpretation matches the context, redo the
6135 -- analysis with error enabled to provide additional information.
6138 Candidate
: Entity_Id
:= Empty
;
6139 New_Call_Node
: Node_Id
:= Empty
;
6140 Node_To_Replace
: Node_Id
;
6141 Obj_Type
: Entity_Id
:= Etype
(Obj
);
6142 Success
: Boolean := False;
6144 function Valid_Candidate
6147 Subp
: Entity_Id
) return Entity_Id
;
6148 -- If the subprogram is a valid interpretation, record it, and add
6149 -- to the list of interpretations of Subprog.
6151 procedure Complete_Object_Operation
6152 (Call_Node
: Node_Id
;
6153 Node_To_Replace
: Node_Id
);
6154 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
6155 -- Call_Node, insert the object (or its dereference) as the first actual
6156 -- in the call, and complete the analysis of the call.
6158 procedure Report_Ambiguity
(Op
: Entity_Id
);
6159 -- If a prefixed procedure call is ambiguous, indicate whether the
6160 -- call includes an implicit dereference or an implicit 'Access.
6162 procedure Transform_Object_Operation
6163 (Call_Node
: out Node_Id
;
6164 Node_To_Replace
: out Node_Id
);
6165 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
6166 -- Call_Node is the resulting subprogram call, Node_To_Replace is
6167 -- either N or the parent of N, and Subprog is a reference to the
6168 -- subprogram we are trying to match.
6170 function Try_Class_Wide_Operation
6171 (Call_Node
: Node_Id
;
6172 Node_To_Replace
: Node_Id
) return Boolean;
6173 -- Traverse all ancestor types looking for a class-wide subprogram
6174 -- for which the current operation is a valid non-dispatching call.
6176 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
6177 -- If prefix is overloaded, its interpretation may include different
6178 -- tagged types, and we must examine the primitive operations and
6179 -- the class-wide operations of each in order to find candidate
6180 -- interpretations for the call as a whole.
6182 function Try_Primitive_Operation
6183 (Call_Node
: Node_Id
;
6184 Node_To_Replace
: Node_Id
) return Boolean;
6185 -- Traverse the list of primitive subprograms looking for a dispatching
6186 -- operation for which the current node is a valid call .
6188 ---------------------
6189 -- Valid_Candidate --
6190 ---------------------
6192 function Valid_Candidate
6195 Subp
: Entity_Id
) return Entity_Id
6197 Arr_Type
: Entity_Id
;
6198 Comp_Type
: Entity_Id
;
6201 -- If the subprogram is a valid interpretation, record it in global
6202 -- variable Subprog, to collect all possible overloadings.
6205 if Subp
/= Entity
(Subprog
) then
6206 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
6210 -- If the call may be an indexed call, retrieve component type of
6211 -- resulting expression, and add possible interpretation.
6216 if Nkind
(Call
) = N_Function_Call
6217 and then Nkind
(Parent
(N
)) = N_Indexed_Component
6218 and then Needs_One_Actual
(Subp
)
6220 if Is_Array_Type
(Etype
(Subp
)) then
6221 Arr_Type
:= Etype
(Subp
);
6223 elsif Is_Access_Type
(Etype
(Subp
))
6224 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
6226 Arr_Type
:= Designated_Type
(Etype
(Subp
));
6230 if Present
(Arr_Type
) then
6232 -- Verify that the actuals (excluding the object)
6233 -- match the types of the indices.
6240 Actual
:= Next
(First_Actual
(Call
));
6241 Index
:= First_Index
(Arr_Type
);
6242 while Present
(Actual
) and then Present
(Index
) loop
6243 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
6248 Next_Actual
(Actual
);
6254 and then Present
(Arr_Type
)
6256 Comp_Type
:= Component_Type
(Arr_Type
);
6260 if Present
(Comp_Type
)
6261 and then Etype
(Subprog
) /= Comp_Type
6263 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
6267 if Etype
(Call
) /= Any_Type
then
6272 end Valid_Candidate
;
6274 -------------------------------
6275 -- Complete_Object_Operation --
6276 -------------------------------
6278 procedure Complete_Object_Operation
6279 (Call_Node
: Node_Id
;
6280 Node_To_Replace
: Node_Id
)
6282 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
6283 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
6284 First_Actual
: Node_Id
;
6287 -- Place the name of the operation, with its interpretations,
6288 -- on the rewritten call.
6290 Set_Name
(Call_Node
, Subprog
);
6292 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
6294 -- For cross-reference purposes, treat the new node as being in
6295 -- the source if the original one is.
6297 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
6298 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
6300 if Nkind
(N
) = N_Selected_Component
6301 and then not Inside_A_Generic
6303 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
6306 -- If need be, rewrite first actual as an explicit dereference
6307 -- If the call is overloaded, the rewriting can only be done
6308 -- once the primitive operation is identified.
6310 if Is_Overloaded
(Subprog
) then
6312 -- The prefix itself may be overloaded, and its interpretations
6313 -- must be propagated to the new actual in the call.
6315 if Is_Overloaded
(Obj
) then
6316 Save_Interps
(Obj
, First_Actual
);
6319 Rewrite
(First_Actual
, Obj
);
6321 elsif not Is_Access_Type
(Formal_Type
)
6322 and then Is_Access_Type
(Etype
(Obj
))
6324 Rewrite
(First_Actual
,
6325 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
6326 Analyze
(First_Actual
);
6328 -- If we need to introduce an explicit dereference, verify that
6329 -- the resulting actual is compatible with the mode of the formal.
6331 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
6332 and then Is_Access_Constant
(Etype
(Obj
))
6335 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
6338 -- Conversely, if the formal is an access parameter and the object
6339 -- is not, replace the actual with a 'Access reference. Its analysis
6340 -- will check that the object is aliased.
6342 elsif Is_Access_Type
(Formal_Type
)
6343 and then not Is_Access_Type
(Etype
(Obj
))
6345 -- A special case: A.all'access is illegal if A is an access to a
6346 -- constant and the context requires an access to a variable.
6348 if not Is_Access_Constant
(Formal_Type
) then
6349 if (Nkind
(Obj
) = N_Explicit_Dereference
6350 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
6351 or else not Is_Variable
(Obj
)
6354 ("actual for& must be a variable", Obj
, Control
);
6358 Rewrite
(First_Actual
,
6359 Make_Attribute_Reference
(Loc
,
6360 Attribute_Name
=> Name_Access
,
6361 Prefix
=> Relocate_Node
(Obj
)));
6363 if not Is_Aliased_View
(Obj
) then
6365 ("object in prefixed call to& must be aliased"
6366 & " (RM-2005 4.3.1 (13))",
6367 Prefix
(First_Actual
), Subprog
);
6370 Analyze
(First_Actual
);
6373 if Is_Overloaded
(Obj
) then
6374 Save_Interps
(Obj
, First_Actual
);
6377 Rewrite
(First_Actual
, Obj
);
6380 Rewrite
(Node_To_Replace
, Call_Node
);
6382 -- Propagate the interpretations collected in subprog to the new
6383 -- function call node, to be resolved from context.
6385 if Is_Overloaded
(Subprog
) then
6386 Save_Interps
(Subprog
, Node_To_Replace
);
6389 Analyze
(Node_To_Replace
);
6391 -- If the operation has been rewritten into a call, which may
6392 -- get subsequently an explicit dereference, preserve the
6393 -- type on the original node (selected component or indexed
6394 -- component) for subsequent legality tests, e.g. Is_Variable.
6395 -- which examines the original node.
6397 if Nkind
(Node_To_Replace
) = N_Function_Call
then
6399 (Original_Node
(Node_To_Replace
), Etype
(Node_To_Replace
));
6402 end Complete_Object_Operation
;
6404 ----------------------
6405 -- Report_Ambiguity --
6406 ----------------------
6408 procedure Report_Ambiguity
(Op
: Entity_Id
) is
6409 Access_Formal
: constant Boolean :=
6410 Is_Access_Type
(Etype
(First_Formal
(Op
)));
6411 Access_Actual
: constant Boolean :=
6412 Is_Access_Type
(Etype
(Prefix
(N
)));
6415 Error_Msg_Sloc
:= Sloc
(Op
);
6417 if Access_Formal
and then not Access_Actual
then
6418 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6420 ("\possible interpretation"
6421 & " (inherited, with implicit 'Access) #", N
);
6424 ("\possible interpretation (with implicit 'Access) #", N
);
6427 elsif not Access_Formal
and then Access_Actual
then
6428 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6430 ("\possible interpretation"
6431 & " ( inherited, with implicit dereference) #", N
);
6434 ("\possible interpretation (with implicit dereference) #", N
);
6438 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
6439 Error_Msg_N
("\possible interpretation (inherited)#", N
);
6441 Error_Msg_N
-- CODEFIX
6442 ("\possible interpretation#", N
);
6445 end Report_Ambiguity
;
6447 --------------------------------
6448 -- Transform_Object_Operation --
6449 --------------------------------
6451 procedure Transform_Object_Operation
6452 (Call_Node
: out Node_Id
;
6453 Node_To_Replace
: out Node_Id
)
6455 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
6456 -- Placeholder used as a first parameter in the call, replaced
6457 -- eventually by the proper object.
6459 Parent_Node
: constant Node_Id
:= Parent
(N
);
6465 -- Common case covering 1) Call to a procedure and 2) Call to a
6466 -- function that has some additional actuals.
6468 if Nkind_In
(Parent_Node
, N_Function_Call
,
6469 N_Procedure_Call_Statement
)
6471 -- N is a selected component node containing the name of the
6472 -- subprogram. If N is not the name of the parent node we must
6473 -- not replace the parent node by the new construct. This case
6474 -- occurs when N is a parameterless call to a subprogram that
6475 -- is an actual parameter of a call to another subprogram. For
6477 -- Some_Subprogram (..., Obj.Operation, ...)
6479 and then Name
(Parent_Node
) = N
6481 Node_To_Replace
:= Parent_Node
;
6483 Actuals
:= Parameter_Associations
(Parent_Node
);
6485 if Present
(Actuals
) then
6486 Prepend
(Dummy
, Actuals
);
6488 Actuals
:= New_List
(Dummy
);
6491 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
6493 Make_Procedure_Call_Statement
(Loc
,
6494 Name
=> New_Copy
(Subprog
),
6495 Parameter_Associations
=> Actuals
);
6499 Make_Function_Call
(Loc
,
6500 Name
=> New_Copy
(Subprog
),
6501 Parameter_Associations
=> Actuals
);
6505 -- Before analysis, a function call appears as an indexed component
6506 -- if there are no named associations.
6508 elsif Nkind
(Parent_Node
) = N_Indexed_Component
6509 and then N
= Prefix
(Parent_Node
)
6511 Node_To_Replace
:= Parent_Node
;
6513 Actuals
:= Expressions
(Parent_Node
);
6515 Actual
:= First
(Actuals
);
6516 while Present
(Actual
) loop
6521 Prepend
(Dummy
, Actuals
);
6524 Make_Function_Call
(Loc
,
6525 Name
=> New_Copy
(Subprog
),
6526 Parameter_Associations
=> Actuals
);
6528 -- Parameterless call: Obj.F is rewritten as F (Obj)
6531 Node_To_Replace
:= N
;
6534 Make_Function_Call
(Loc
,
6535 Name
=> New_Copy
(Subprog
),
6536 Parameter_Associations
=> New_List
(Dummy
));
6538 end Transform_Object_Operation
;
6540 ------------------------------
6541 -- Try_Class_Wide_Operation --
6542 ------------------------------
6544 function Try_Class_Wide_Operation
6545 (Call_Node
: Node_Id
;
6546 Node_To_Replace
: Node_Id
) return Boolean
6548 Anc_Type
: Entity_Id
;
6549 Matching_Op
: Entity_Id
:= Empty
;
6552 procedure Traverse_Homonyms
6553 (Anc_Type
: Entity_Id
;
6554 Error
: out Boolean);
6555 -- Traverse the homonym chain of the subprogram searching for those
6556 -- homonyms whose first formal has the Anc_Type's class-wide type,
6557 -- or an anonymous access type designating the class-wide type. If
6558 -- an ambiguity is detected, then Error is set to True.
6560 procedure Traverse_Interfaces
6561 (Anc_Type
: Entity_Id
;
6562 Error
: out Boolean);
6563 -- Traverse the list of interfaces, if any, associated with Anc_Type
6564 -- and search for acceptable class-wide homonyms associated with each
6565 -- interface. If an ambiguity is detected, then Error is set to True.
6567 -----------------------
6568 -- Traverse_Homonyms --
6569 -----------------------
6571 procedure Traverse_Homonyms
6572 (Anc_Type
: Entity_Id
;
6573 Error
: out Boolean)
6575 Cls_Type
: Entity_Id
;
6583 Cls_Type
:= Class_Wide_Type
(Anc_Type
);
6585 Hom
:= Current_Entity
(Subprog
);
6587 -- Find operation whose first parameter is of the class-wide
6588 -- type, a subtype thereof, or an anonymous access to same.
6590 while Present
(Hom
) loop
6591 if (Ekind
(Hom
) = E_Procedure
6593 Ekind
(Hom
) = E_Function
)
6594 and then Scope
(Hom
) = Scope
(Anc_Type
)
6595 and then Present
(First_Formal
(Hom
))
6597 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
6599 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
6601 Ekind
(Etype
(First_Formal
(Hom
))) =
6602 E_Anonymous_Access_Type
6605 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
6608 Set_Etype
(Call_Node
, Any_Type
);
6609 Set_Is_Overloaded
(Call_Node
, False);
6612 if No
(Matching_Op
) then
6613 Hom_Ref
:= New_Reference_To
(Hom
, Sloc
(Subprog
));
6614 Set_Etype
(Call_Node
, Any_Type
);
6615 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
6617 Set_Name
(Call_Node
, Hom_Ref
);
6622 Report
=> Report_Error
,
6624 Skip_First
=> True);
6627 Valid_Candidate
(Success
, Call_Node
, Hom
);
6633 Report
=> Report_Error
,
6635 Skip_First
=> True);
6637 if Present
(Valid_Candidate
(Success
, Call_Node
, Hom
))
6638 and then Nkind
(Call_Node
) /= N_Function_Call
6640 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
6641 Report_Ambiguity
(Matching_Op
);
6642 Report_Ambiguity
(Hom
);
6649 Hom
:= Homonym
(Hom
);
6651 end Traverse_Homonyms
;
6653 -------------------------
6654 -- Traverse_Interfaces --
6655 -------------------------
6657 procedure Traverse_Interfaces
6658 (Anc_Type
: Entity_Id
;
6659 Error
: out Boolean)
6661 Intface_List
: constant List_Id
:=
6662 Abstract_Interface_List
(Anc_Type
);
6668 if Is_Non_Empty_List
(Intface_List
) then
6669 Intface
:= First
(Intface_List
);
6670 while Present
(Intface
) loop
6672 -- Look for acceptable class-wide homonyms associated with
6675 Traverse_Homonyms
(Etype
(Intface
), Error
);
6681 -- Continue the search by looking at each of the interface's
6682 -- associated interface ancestors.
6684 Traverse_Interfaces
(Etype
(Intface
), Error
);
6693 end Traverse_Interfaces
;
6695 -- Start of processing for Try_Class_Wide_Operation
6698 -- Loop through ancestor types (including interfaces), traversing
6699 -- the homonym chain of the subprogram, trying out those homonyms
6700 -- whose first formal has the class-wide type of the ancestor, or
6701 -- an anonymous access type designating the class-wide type.
6703 Anc_Type
:= Obj_Type
;
6705 -- Look for a match among homonyms associated with the ancestor
6707 Traverse_Homonyms
(Anc_Type
, Error
);
6713 -- Continue the search for matches among homonyms associated with
6714 -- any interfaces implemented by the ancestor.
6716 Traverse_Interfaces
(Anc_Type
, Error
);
6722 exit when Etype
(Anc_Type
) = Anc_Type
;
6723 Anc_Type
:= Etype
(Anc_Type
);
6726 if Present
(Matching_Op
) then
6727 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
6730 return Present
(Matching_Op
);
6731 end Try_Class_Wide_Operation
;
6733 -----------------------------------
6734 -- Try_One_Prefix_Interpretation --
6735 -----------------------------------
6737 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
6741 if Is_Access_Type
(Obj_Type
) then
6742 Obj_Type
:= Designated_Type
(Obj_Type
);
6745 if Ekind
(Obj_Type
) = E_Private_Subtype
then
6746 Obj_Type
:= Base_Type
(Obj_Type
);
6749 if Is_Class_Wide_Type
(Obj_Type
) then
6750 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
6753 -- The type may have be obtained through a limited_with clause,
6754 -- in which case the primitive operations are available on its
6755 -- non-limited view. If still incomplete, retrieve full view.
6757 if Ekind
(Obj_Type
) = E_Incomplete_Type
6758 and then From_With_Type
(Obj_Type
)
6760 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
6763 -- If the object is not tagged, or the type is still an incomplete
6764 -- type, this is not a prefixed call.
6766 if not Is_Tagged_Type
(Obj_Type
)
6767 or else Is_Incomplete_Type
(Obj_Type
)
6772 if Try_Primitive_Operation
6773 (Call_Node
=> New_Call_Node
,
6774 Node_To_Replace
=> Node_To_Replace
)
6776 Try_Class_Wide_Operation
6777 (Call_Node
=> New_Call_Node
,
6778 Node_To_Replace
=> Node_To_Replace
)
6782 end Try_One_Prefix_Interpretation
;
6784 -----------------------------
6785 -- Try_Primitive_Operation --
6786 -----------------------------
6788 function Try_Primitive_Operation
6789 (Call_Node
: Node_Id
;
6790 Node_To_Replace
: Node_Id
) return Boolean
6793 Prim_Op
: Entity_Id
;
6794 Matching_Op
: Entity_Id
:= Empty
;
6795 Prim_Op_Ref
: Node_Id
:= Empty
;
6797 Corr_Type
: Entity_Id
:= Empty
;
6798 -- If the prefix is a synchronized type, the controlling type of
6799 -- the primitive operation is the corresponding record type, else
6800 -- this is the object type itself.
6802 Success
: Boolean := False;
6804 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
6805 -- For tagged types the candidate interpretations are found in
6806 -- the list of primitive operations of the type and its ancestors.
6807 -- For formal tagged types we have to find the operations declared
6808 -- in the same scope as the type (including in the generic formal
6809 -- part) because the type itself carries no primitive operations,
6810 -- except for formal derived types that inherit the operations of
6811 -- the parent and progenitors.
6812 -- If the context is a generic subprogram body, the generic formals
6813 -- are visible by name, but are not in the entity list of the
6814 -- subprogram because that list starts with the subprogram formals.
6815 -- We retrieve the candidate operations from the generic declaration.
6817 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
6818 -- An operation that overrides an inherited operation in the private
6819 -- part of its package may be hidden, but if the inherited operation
6820 -- is visible a direct call to it will dispatch to the private one,
6821 -- which is therefore a valid candidate.
6823 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
6824 -- Verify that the prefix, dereferenced if need be, is a valid
6825 -- controlling argument in a call to Op. The remaining actuals
6826 -- are checked in the subsequent call to Analyze_One_Call.
6828 ------------------------------
6829 -- Collect_Generic_Type_Ops --
6830 ------------------------------
6832 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
6833 Bas
: constant Entity_Id
:= Base_Type
(T
);
6834 Candidates
: constant Elist_Id
:= New_Elmt_List
;
6838 procedure Check_Candidate
;
6839 -- The operation is a candidate if its first parameter is a
6840 -- controlling operand of the desired type.
6842 -----------------------
6843 -- Check_Candidate; --
6844 -----------------------
6846 procedure Check_Candidate
is
6848 Formal
:= First_Formal
(Subp
);
6851 and then Is_Controlling_Formal
(Formal
)
6853 (Base_Type
(Etype
(Formal
)) = Bas
6855 (Is_Access_Type
(Etype
(Formal
))
6856 and then Designated_Type
(Etype
(Formal
)) = Bas
))
6858 Append_Elmt
(Subp
, Candidates
);
6860 end Check_Candidate
;
6862 -- Start of processing for Collect_Generic_Type_Ops
6865 if Is_Derived_Type
(T
) then
6866 return Primitive_Operations
(T
);
6868 elsif Ekind_In
(Scope
(T
), E_Procedure
, E_Function
) then
6870 -- Scan the list of generic formals to find subprograms
6871 -- that may have a first controlling formal of the type.
6873 if Nkind
(Unit_Declaration_Node
(Scope
(T
)))
6874 = N_Generic_Subprogram_Declaration
6881 First
(Generic_Formal_Declarations
6882 (Unit_Declaration_Node
(Scope
(T
))));
6883 while Present
(Decl
) loop
6884 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
6885 Subp
:= Defining_Entity
(Decl
);
6896 -- Scan the list of entities declared in the same scope as
6897 -- the type. In general this will be an open scope, given that
6898 -- the call we are analyzing can only appear within a generic
6899 -- declaration or body (either the one that declares T, or a
6902 -- For a subtype representing a generic actual type, go to the
6905 if Is_Generic_Actual_Type
(T
) then
6906 Subp
:= First_Entity
(Scope
(Base_Type
(T
)));
6908 Subp
:= First_Entity
(Scope
(T
));
6911 while Present
(Subp
) loop
6912 if Is_Overloadable
(Subp
) then
6921 end Collect_Generic_Type_Ops
;
6923 ---------------------------
6924 -- Is_Private_Overriding --
6925 ---------------------------
6927 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
6928 Visible_Op
: constant Entity_Id
:= Homonym
(Op
);
6931 return Present
(Visible_Op
)
6932 and then Scope
(Op
) = Scope
(Visible_Op
)
6933 and then not Comes_From_Source
(Visible_Op
)
6934 and then Alias
(Visible_Op
) = Op
6935 and then not Is_Hidden
(Visible_Op
);
6936 end Is_Private_Overriding
;
6938 -----------------------------
6939 -- Valid_First_Argument_Of --
6940 -----------------------------
6942 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
6943 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
6946 if Is_Concurrent_Type
(Typ
)
6947 and then Present
(Corresponding_Record_Type
(Typ
))
6949 Typ
:= Corresponding_Record_Type
(Typ
);
6952 -- Simple case. Object may be a subtype of the tagged type or
6953 -- may be the corresponding record of a synchronized type.
6955 return Obj_Type
= Typ
6956 or else Base_Type
(Obj_Type
) = Typ
6957 or else Corr_Type
= Typ
6959 -- Prefix can be dereferenced
6962 (Is_Access_Type
(Corr_Type
)
6963 and then Designated_Type
(Corr_Type
) = Typ
)
6965 -- Formal is an access parameter, for which the object
6966 -- can provide an access.
6969 (Ekind
(Typ
) = E_Anonymous_Access_Type
6970 and then Designated_Type
(Typ
) = Base_Type
(Corr_Type
));
6971 end Valid_First_Argument_Of
;
6973 -- Start of processing for Try_Primitive_Operation
6976 -- Look for subprograms in the list of primitive operations. The name
6977 -- must be identical, and the kind of call indicates the expected
6978 -- kind of operation (function or procedure). If the type is a
6979 -- (tagged) synchronized type, the primitive ops are attached to the
6980 -- corresponding record (base) type.
6982 if Is_Concurrent_Type
(Obj_Type
) then
6983 if Present
(Corresponding_Record_Type
(Obj_Type
)) then
6984 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
6985 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
6987 Corr_Type
:= Obj_Type
;
6988 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
6991 elsif not Is_Generic_Type
(Obj_Type
) then
6992 Corr_Type
:= Obj_Type
;
6993 Elmt
:= First_Elmt
(Primitive_Operations
(Obj_Type
));
6996 Corr_Type
:= Obj_Type
;
6997 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
7000 while Present
(Elmt
) loop
7001 Prim_Op
:= Node
(Elmt
);
7003 if Chars
(Prim_Op
) = Chars
(Subprog
)
7004 and then Present
(First_Formal
(Prim_Op
))
7005 and then Valid_First_Argument_Of
(Prim_Op
)
7007 (Nkind
(Call_Node
) = N_Function_Call
)
7008 = (Ekind
(Prim_Op
) = E_Function
)
7010 -- Ada 2005 (AI-251): If this primitive operation corresponds
7011 -- with an immediate ancestor interface there is no need to add
7012 -- it to the list of interpretations; the corresponding aliased
7013 -- primitive is also in this list of primitive operations and
7014 -- will be used instead.
7016 if (Present
(Interface_Alias
(Prim_Op
))
7017 and then Is_Ancestor
(Find_Dispatching_Type
7018 (Alias
(Prim_Op
)), Corr_Type
))
7020 -- Do not consider hidden primitives unless the type is in an
7021 -- open scope or we are within an instance, where visibility
7022 -- is known to be correct, or else if this is an overriding
7023 -- operation in the private part for an inherited operation.
7025 or else (Is_Hidden
(Prim_Op
)
7026 and then not Is_Immediately_Visible
(Obj_Type
)
7027 and then not In_Instance
7028 and then not Is_Private_Overriding
(Prim_Op
))
7033 Set_Etype
(Call_Node
, Any_Type
);
7034 Set_Is_Overloaded
(Call_Node
, False);
7036 if No
(Matching_Op
) then
7037 Prim_Op_Ref
:= New_Reference_To
(Prim_Op
, Sloc
(Subprog
));
7038 Candidate
:= Prim_Op
;
7040 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
7042 Set_Name
(Call_Node
, Prim_Op_Ref
);
7048 Report
=> Report_Error
,
7050 Skip_First
=> True);
7052 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
7054 -- More than one interpretation, collect for subsequent
7055 -- disambiguation. If this is a procedure call and there
7056 -- is another match, report ambiguity now.
7062 Report
=> Report_Error
,
7064 Skip_First
=> True);
7066 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
7067 and then Nkind
(Call_Node
) /= N_Function_Call
7069 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
7070 Report_Ambiguity
(Matching_Op
);
7071 Report_Ambiguity
(Prim_Op
);
7081 if Present
(Matching_Op
) then
7082 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
7085 return Present
(Matching_Op
);
7086 end Try_Primitive_Operation
;
7088 -- Start of processing for Try_Object_Operation
7091 Analyze_Expression
(Obj
);
7093 -- Analyze the actuals if node is known to be a subprogram call
7095 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
7096 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
7097 while Present
(Actual
) loop
7098 Analyze_Expression
(Actual
);
7103 -- Build a subprogram call node, using a copy of Obj as its first
7104 -- actual. This is a placeholder, to be replaced by an explicit
7105 -- dereference when needed.
7107 Transform_Object_Operation
7108 (Call_Node
=> New_Call_Node
,
7109 Node_To_Replace
=> Node_To_Replace
);
7111 Set_Etype
(New_Call_Node
, Any_Type
);
7112 Set_Etype
(Subprog
, Any_Type
);
7113 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
7115 if not Is_Overloaded
(Obj
) then
7116 Try_One_Prefix_Interpretation
(Obj_Type
);
7123 Get_First_Interp
(Obj
, I
, It
);
7124 while Present
(It
.Nam
) loop
7125 Try_One_Prefix_Interpretation
(It
.Typ
);
7126 Get_Next_Interp
(I
, It
);
7131 if Etype
(New_Call_Node
) /= Any_Type
then
7132 Complete_Object_Operation
7133 (Call_Node
=> New_Call_Node
,
7134 Node_To_Replace
=> Node_To_Replace
);
7137 elsif Present
(Candidate
) then
7139 -- The argument list is not type correct. Re-analyze with error
7140 -- reporting enabled, and use one of the possible candidates.
7141 -- In All_Errors_Mode, re-analyze all failed interpretations.
7143 if All_Errors_Mode
then
7144 Report_Error
:= True;
7145 if Try_Primitive_Operation
7146 (Call_Node
=> New_Call_Node
,
7147 Node_To_Replace
=> Node_To_Replace
)
7150 Try_Class_Wide_Operation
7151 (Call_Node
=> New_Call_Node
,
7152 Node_To_Replace
=> Node_To_Replace
)
7159 (N
=> New_Call_Node
,
7163 Skip_First
=> True);
7166 -- No need for further errors
7171 -- There was no candidate operation, so report it as an error
7172 -- in the caller: Analyze_Selected_Component.
7176 end Try_Object_Operation
;
7182 procedure wpo
(T
: Entity_Id
) is
7187 if not Is_Tagged_Type
(T
) then
7191 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
7192 while Present
(E
) loop
7194 Write_Int
(Int
(Op
));
7195 Write_Str
(" === ");
7196 Write_Name
(Chars
(Op
));
7198 Write_Name
(Chars
(Scope
(Op
)));