1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Util
; use Exp_Util
;
33 with Fname
; use Fname
;
34 with Itypes
; use Itypes
;
36 with Lib
.Xref
; use Lib
.Xref
;
37 with Namet
; use Namet
;
38 with Namet
.Sp
; use Namet
.Sp
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Output
; use Output
;
43 with Restrict
; use Restrict
;
44 with Rident
; use Rident
;
46 with Sem_Aux
; use Sem_Aux
;
47 with Sem_Case
; use Sem_Case
;
48 with Sem_Cat
; use Sem_Cat
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch8
; use Sem_Ch8
;
52 with Sem_Dim
; use Sem_Dim
;
53 with Sem_Disp
; use Sem_Disp
;
54 with Sem_Dist
; use Sem_Dist
;
55 with Sem_Eval
; use Sem_Eval
;
56 with Sem_Res
; use Sem_Res
;
57 with Sem_Type
; use Sem_Type
;
58 with Sem_Util
; use Sem_Util
;
59 with Sem_Warn
; use Sem_Warn
;
60 with Stand
; use Stand
;
61 with Sinfo
; use Sinfo
;
62 with Snames
; use Snames
;
63 with Tbuild
; use Tbuild
;
64 with Uintp
; use Uintp
;
66 package body Sem_Ch4
is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Analyze_Concatenation_Rest
(N
: Node_Id
);
73 -- Does the "rest" of the work of Analyze_Concatenation, after the left
74 -- operand has been analyzed. See Analyze_Concatenation for details.
76 procedure Analyze_Expression
(N
: Node_Id
);
77 -- For expressions that are not names, this is just a call to analyze.
78 -- If the expression is a name, it may be a call to a parameterless
79 -- function, and if so must be converted into an explicit call node
80 -- and analyzed as such. This deproceduring must be done during the first
81 -- pass of overload resolution, because otherwise a procedure call with
82 -- overloaded actuals may fail to resolve.
84 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
);
85 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call
86 -- is an operator name or an expanded name whose selector is an operator
87 -- name, and one possible interpretation is as a predefined operator.
89 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
);
90 -- If the prefix of a selected_component is overloaded, the proper
91 -- interpretation that yields a record type with the proper selector
92 -- name must be selected.
94 procedure Analyze_User_Defined_Binary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
95 -- Procedure to analyze a user defined binary operator, which is resolved
96 -- like a function, but instead of a list of actuals it is presented
97 -- with the left and right operands of an operator node.
99 procedure Analyze_User_Defined_Unary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
100 -- Procedure to analyze a user defined unary operator, which is resolved
101 -- like a function, but instead of a list of actuals, it is presented with
102 -- the operand of the operator node.
104 procedure Ambiguous_Operands
(N
: Node_Id
);
105 -- For equality, membership, and comparison operators with overloaded
106 -- arguments, list possible interpretations.
108 procedure Analyze_One_Call
112 Success
: out Boolean;
113 Skip_First
: Boolean := False);
114 -- Check one interpretation of an overloaded subprogram name for
115 -- compatibility with the types of the actuals in a call. If there is a
116 -- single interpretation which does not match, post error if Report is
119 -- Nam is the entity that provides the formals against which the actuals
120 -- are checked. Nam is either the name of a subprogram, or the internal
121 -- subprogram type constructed for an access_to_subprogram. If the actuals
122 -- are compatible with Nam, then Nam is added to the list of candidate
123 -- interpretations for N, and Success is set to True.
125 -- The flag Skip_First is used when analyzing a call that was rewritten
126 -- from object notation. In this case the first actual may have to receive
127 -- an explicit dereference, depending on the first formal of the operation
128 -- being called. The caller will have verified that the object is legal
129 -- for the call. If the remaining parameters match, the first parameter
130 -- will rewritten as a dereference if needed, prior to completing analysis.
132 procedure Check_Misspelled_Selector
135 -- Give possible misspelling diagnostic if Sel is likely to be a mis-
136 -- spelling of one of the selectors of the Prefix. This is called by
137 -- Analyze_Selected_Component after producing an invalid selector error
140 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean;
141 -- Verify that type T is declared in scope S. Used to find interpretations
142 -- for operators given by expanded names. This is abstracted as a separate
143 -- function to handle extensions to System, where S is System, but T is
144 -- declared in the extension.
146 procedure Find_Arithmetic_Types
150 -- L and R are the operands of an arithmetic operator. Find
151 -- consistent pairs of interpretations for L and R that have a
152 -- numeric type consistent with the semantics of the operator.
154 procedure Find_Comparison_Types
158 -- L and R are operands of a comparison operator. Find consistent
159 -- pairs of interpretations for L and R.
161 procedure Find_Concatenation_Types
165 -- For the four varieties of concatenation
167 procedure Find_Equality_Types
171 -- Ditto for equality operators
173 procedure Find_Boolean_Types
177 -- Ditto for binary logical operations
179 procedure Find_Negation_Types
183 -- Find consistent interpretation for operand of negation operator
185 procedure Find_Non_Universal_Interpretations
190 -- For equality and comparison operators, the result is always boolean,
191 -- and the legality of the operation is determined from the visibility
192 -- of the operand types. If one of the operands has a universal interpre-
193 -- tation, the legality check uses some compatible non-universal
194 -- interpretation of the other operand. N can be an operator node, or
195 -- a function call whose name is an operator designator. Any_Access, which
196 -- is the initial type of the literal NULL, is a universal type for the
197 -- purpose of this routine.
199 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean;
200 -- Find candidate interpretations for the name Obj.Proc when it appears
201 -- in a subprogram renaming declaration.
203 procedure Find_Unary_Types
207 -- Unary arithmetic types: plus, minus, abs
209 procedure Check_Arithmetic_Pair
213 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
214 -- types for left and right operand. Determine whether they constitute
215 -- a valid pair for the given operator, and record the corresponding
216 -- interpretation of the operator node. The node N may be an operator
217 -- node (the usual case) or a function call whose prefix is an operator
218 -- designator. In both cases Op_Id is the operator name itself.
220 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
);
221 -- Give detailed information on overloaded call where none of the
222 -- interpretations match. N is the call node, Nam the designator for
223 -- the overloaded entity being called.
225 function Junk_Operand
(N
: Node_Id
) return Boolean;
226 -- Test for an operand that is an inappropriate entity (e.g. a package
227 -- name or a label). If so, issue an error message and return True. If
228 -- the operand is not an inappropriate entity kind, return False.
230 procedure Operator_Check
(N
: Node_Id
);
231 -- Verify that an operator has received some valid interpretation. If none
232 -- was found, determine whether a use clause would make the operation
233 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
234 -- every type compatible with the operator, even if the operator for the
235 -- type is not directly visible. The routine uses this type to emit a more
236 -- informative message.
238 function Process_Implicit_Dereference_Prefix
240 P
: Node_Id
) return Entity_Id
;
241 -- Called when P is the prefix of an implicit dereference, denoting an
242 -- object E. The function returns the designated type of the prefix, taking
243 -- into account that the designated type of an anonymous access type may be
244 -- a limited view, when the non-limited view is visible.
245 -- If in semantics only mode (-gnatc or generic), the function also records
246 -- that the prefix is a reference to E, if any. Normally, such a reference
247 -- is generated only when the implicit dereference is expanded into an
248 -- explicit one, but for consistency we must generate the reference when
249 -- expansion is disabled as well.
251 procedure Remove_Abstract_Operations
(N
: Node_Id
);
252 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
253 -- operation is not a candidate interpretation.
255 function Try_Container_Indexing
258 Exprs
: List_Id
) return Boolean;
259 -- AI05-0139: Generalized indexing to support iterators over containers
261 function Try_Indexed_Call
265 Skip_First
: Boolean) return Boolean;
266 -- If a function has defaults for all its actuals, a call to it may in fact
267 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
268 -- interpretation as an indexing, prior to analysis as a call. If both are
269 -- possible, the node is overloaded with both interpretations (same symbol
270 -- but two different types). If the call is written in prefix form, the
271 -- prefix becomes the first parameter in the call, and only the remaining
272 -- actuals must be checked for the presence of defaults.
274 function Try_Indirect_Call
277 Typ
: Entity_Id
) return Boolean;
278 -- Similarly, a function F that needs no actuals can return an access to a
279 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
280 -- the call may be overloaded with both interpretations.
282 function Try_Object_Operation
284 CW_Test_Only
: Boolean := False) return Boolean;
285 -- Ada 2005 (AI-252): Support the object.operation notation. If node N
286 -- is a call in this notation, it is transformed into a normal subprogram
287 -- call where the prefix is a parameter, and True is returned. If node
288 -- N is not of this form, it is unchanged, and False is returned. if
289 -- CW_Test_Only is true then N is an N_Selected_Component node which
290 -- is part of a call to an entry or procedure of a tagged concurrent
291 -- type and this routine is invoked to search for class-wide subprograms
292 -- conflicting with the target entity.
294 procedure wpo
(T
: Entity_Id
);
295 pragma Warnings
(Off
, wpo
);
296 -- Used for debugging: obtain list of primitive operations even if
297 -- type is not frozen and dispatch table is not built yet.
299 ------------------------
300 -- Ambiguous_Operands --
301 ------------------------
303 procedure Ambiguous_Operands
(N
: Node_Id
) is
304 procedure List_Operand_Interps
(Opnd
: Node_Id
);
306 --------------------------
307 -- List_Operand_Interps --
308 --------------------------
310 procedure List_Operand_Interps
(Opnd
: Node_Id
) is
315 if Is_Overloaded
(Opnd
) then
316 if Nkind
(Opnd
) in N_Op
then
318 elsif Nkind
(Opnd
) = N_Function_Call
then
320 elsif Ada_Version
>= Ada_2012
then
326 Get_First_Interp
(Opnd
, I
, It
);
327 while Present
(It
.Nam
) loop
328 if Has_Implicit_Dereference
(It
.Typ
) then
330 ("can be interpreted as implicit dereference", Opnd
);
334 Get_Next_Interp
(I
, It
);
345 if Opnd
= Left_Opnd
(N
) then
346 Error_Msg_N
("\left operand has the following interpretations", N
);
349 ("\right operand has the following interpretations", N
);
353 List_Interps
(Nam
, Err
);
354 end List_Operand_Interps
;
356 -- Start of processing for Ambiguous_Operands
359 if Nkind
(N
) in N_Membership_Test
then
360 Error_Msg_N
("ambiguous operands for membership", N
);
362 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
) then
363 Error_Msg_N
("ambiguous operands for equality", N
);
366 Error_Msg_N
("ambiguous operands for comparison", N
);
369 if All_Errors_Mode
then
370 List_Operand_Interps
(Left_Opnd
(N
));
371 List_Operand_Interps
(Right_Opnd
(N
));
373 Error_Msg_N
("\use -gnatf switch for details", N
);
375 end Ambiguous_Operands
;
377 -----------------------
378 -- Analyze_Aggregate --
379 -----------------------
381 -- Most of the analysis of Aggregates requires that the type be known,
382 -- and is therefore put off until resolution.
384 procedure Analyze_Aggregate
(N
: Node_Id
) is
386 if No
(Etype
(N
)) then
387 Set_Etype
(N
, Any_Composite
);
389 end Analyze_Aggregate
;
391 -----------------------
392 -- Analyze_Allocator --
393 -----------------------
395 procedure Analyze_Allocator
(N
: Node_Id
) is
396 Loc
: constant Source_Ptr
:= Sloc
(N
);
397 Sav_Errs
: constant Nat
:= Serious_Errors_Detected
;
398 E
: Node_Id
:= Expression
(N
);
399 Acc_Type
: Entity_Id
;
405 Check_SPARK_Restriction
("allocator is not allowed", N
);
407 -- Deal with allocator restrictions
409 -- In accordance with H.4(7), the No_Allocators restriction only applies
410 -- to user-written allocators. The same consideration applies to the
411 -- No_Allocators_Before_Elaboration restriction.
413 if Comes_From_Source
(N
) then
414 Check_Restriction
(No_Allocators
, N
);
416 -- Processing for No_Standard_Allocators_After_Elaboration, loop to
417 -- look at enclosing context, checking task/main subprogram case.
421 while Present
(P
) loop
423 -- In both cases we need a handled sequence of statements, where
424 -- the occurrence of the allocator is within the statements.
426 if Nkind
(P
) = N_Handled_Sequence_Of_Statements
427 and then Is_List_Member
(C
)
428 and then List_Containing
(C
) = Statements
(P
)
430 -- Check for allocator within task body, this is a definite
431 -- violation of No_Allocators_After_Elaboration we can detect.
433 if Nkind
(Original_Node
(Parent
(P
))) = N_Task_Body
then
435 (No_Standard_Allocators_After_Elaboration
, N
);
439 -- The other case is appearance in a subprogram body. This may
440 -- be a violation if this is a library level subprogram, and it
441 -- turns out to be used as the main program, but only the
442 -- binder knows that, so just record the occurrence.
444 if Nkind
(Original_Node
(Parent
(P
))) = N_Subprogram_Body
445 and then Nkind
(Parent
(Parent
(P
))) = N_Compilation_Unit
447 Set_Has_Allocator
(Current_Sem_Unit
);
456 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
457 -- any. The expected type for the name is any type. A non-overloading
458 -- rule then requires it to be of a type descended from
459 -- System.Storage_Pools.Subpools.Subpool_Handle.
461 -- This isn't exactly what the AI says, but it seems to be the right
462 -- rule. The AI should be fixed.???
465 Subpool
: constant Node_Id
:= Subpool_Handle_Name
(N
);
468 if Present
(Subpool
) then
471 if Is_Overloaded
(Subpool
) then
472 Error_Msg_N
("ambiguous subpool handle", Subpool
);
475 -- Check that Etype (Subpool) is descended from Subpool_Handle
481 -- Analyze the qualified expression or subtype indication
483 if Nkind
(E
) = N_Qualified_Expression
then
484 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
485 Set_Etype
(Acc_Type
, Acc_Type
);
486 Find_Type
(Subtype_Mark
(E
));
488 -- Analyze the qualified expression, and apply the name resolution
489 -- rule given in 4.7(3).
492 Type_Id
:= Etype
(E
);
493 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
495 Resolve
(Expression
(E
), Type_Id
);
497 -- Allocators generated by the build-in-place expansion mechanism
498 -- are explicitly marked as coming from source but do not need to be
499 -- checked for limited initialization. To exclude this case, ensure
500 -- that the parent of the allocator is a source node.
502 if Is_Limited_Type
(Type_Id
)
503 and then Comes_From_Source
(N
)
504 and then Comes_From_Source
(Parent
(N
))
505 and then not In_Instance_Body
507 if not OK_For_Limited_Init
(Type_Id
, Expression
(E
)) then
508 Error_Msg_N
("initialization not allowed for limited types", N
);
509 Explain_Limited_Type
(Type_Id
, N
);
513 -- A qualified expression requires an exact match of the type,
514 -- class-wide matching is not allowed.
516 -- if Is_Class_Wide_Type (Type_Id)
517 -- and then Base_Type
518 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
520 -- Wrong_Type (Expression (E), Type_Id);
523 Check_Non_Static_Context
(Expression
(E
));
525 -- We don't analyze the qualified expression itself because it's
526 -- part of the allocator
528 Set_Etype
(E
, Type_Id
);
530 -- Case where allocator has a subtype indication
535 Base_Typ
: Entity_Id
;
538 -- If the allocator includes a N_Subtype_Indication then a
539 -- constraint is present, otherwise the node is a subtype mark.
540 -- Introduce an explicit subtype declaration into the tree
541 -- defining some anonymous subtype and rewrite the allocator to
542 -- use this subtype rather than the subtype indication.
544 -- It is important to introduce the explicit subtype declaration
545 -- so that the bounds of the subtype indication are attached to
546 -- the tree in case the allocator is inside a generic unit.
548 if Nkind
(E
) = N_Subtype_Indication
then
550 -- A constraint is only allowed for a composite type in Ada
551 -- 95. In Ada 83, a constraint is also allowed for an
552 -- access-to-composite type, but the constraint is ignored.
554 Find_Type
(Subtype_Mark
(E
));
555 Base_Typ
:= Entity
(Subtype_Mark
(E
));
557 if Is_Elementary_Type
(Base_Typ
) then
558 if not (Ada_Version
= Ada_83
559 and then Is_Access_Type
(Base_Typ
))
561 Error_Msg_N
("constraint not allowed here", E
);
563 if Nkind
(Constraint
(E
)) =
564 N_Index_Or_Discriminant_Constraint
566 Error_Msg_N
-- CODEFIX
567 ("\if qualified expression was meant, " &
568 "use apostrophe", Constraint
(E
));
572 -- Get rid of the bogus constraint:
574 Rewrite
(E
, New_Copy_Tree
(Subtype_Mark
(E
)));
575 Analyze_Allocator
(N
);
579 if Expander_Active
then
580 Def_Id
:= Make_Temporary
(Loc
, 'S');
583 Make_Subtype_Declaration
(Loc
,
584 Defining_Identifier
=> Def_Id
,
585 Subtype_Indication
=> Relocate_Node
(E
)));
587 if Sav_Errs
/= Serious_Errors_Detected
588 and then Nkind
(Constraint
(E
)) =
589 N_Index_Or_Discriminant_Constraint
591 Error_Msg_N
-- CODEFIX
592 ("if qualified expression was meant, " &
593 "use apostrophe!", Constraint
(E
));
596 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
597 Rewrite
(Expression
(N
), E
);
601 Type_Id
:= Process_Subtype
(E
, N
);
602 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
603 Set_Etype
(Acc_Type
, Acc_Type
);
604 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
605 Check_Fully_Declared
(Type_Id
, N
);
607 -- Ada 2005 (AI-231): If the designated type is itself an access
608 -- type that excludes null, its default initialization will
609 -- be a null object, and we can insert an unconditional raise
610 -- before the allocator.
612 -- Ada 2012 (AI-104): A not null indication here is altogether
615 if Can_Never_Be_Null
(Type_Id
) then
617 Not_Null_Check
: constant Node_Id
:=
618 Make_Raise_Constraint_Error
(Sloc
(E
),
619 Reason
=> CE_Null_Not_Allowed
);
622 if Expander_Active
then
623 Insert_Action
(N
, Not_Null_Check
);
624 Analyze
(Not_Null_Check
);
626 elsif Warn_On_Ada_2012_Compatibility
then
628 ("null value not allowed here in Ada 2012?y?", E
);
633 -- Check restriction against dynamically allocated protected
634 -- objects. Note that when limited aggregates are supported,
635 -- a similar test should be applied to an allocator with a
636 -- qualified expression ???
638 if Is_Protected_Type
(Type_Id
) then
639 Check_Restriction
(No_Protected_Type_Allocators
, N
);
642 -- Check for missing initialization. Skip this check if we already
643 -- had errors on analyzing the allocator, since in that case these
644 -- are probably cascaded errors.
646 if Is_Indefinite_Subtype
(Type_Id
)
647 and then Serious_Errors_Detected
= Sav_Errs
649 -- The build-in-place machinery may produce an allocator when
650 -- the designated type is indefinite but the underlying type is
651 -- not. In this case the unknown discriminants are meaningless
652 -- and should not trigger error messages. Check the parent node
653 -- because the allocator is marked as coming from source.
655 if Present
(Underlying_Type
(Type_Id
))
656 and then not Is_Indefinite_Subtype
(Underlying_Type
(Type_Id
))
657 and then not Comes_From_Source
(Parent
(N
))
661 elsif Is_Class_Wide_Type
(Type_Id
) then
663 ("initialization required in class-wide allocation", N
);
666 if Ada_Version
< Ada_2005
667 and then Is_Limited_Type
(Type_Id
)
669 Error_Msg_N
("unconstrained allocation not allowed", N
);
671 if Is_Array_Type
(Type_Id
) then
673 ("\constraint with array bounds required", N
);
675 elsif Has_Unknown_Discriminants
(Type_Id
) then
678 else pragma Assert
(Has_Discriminants
(Type_Id
));
680 ("\constraint with discriminant values required", N
);
683 -- Limited Ada 2005 and general non-limited case
687 ("uninitialized unconstrained allocation not allowed",
690 if Is_Array_Type
(Type_Id
) then
692 ("\qualified expression or constraint with " &
693 "array bounds required", N
);
695 elsif Has_Unknown_Discriminants
(Type_Id
) then
696 Error_Msg_N
("\qualified expression required", N
);
698 else pragma Assert
(Has_Discriminants
(Type_Id
));
700 ("\qualified expression or constraint with " &
701 "discriminant values required", N
);
709 if Is_Abstract_Type
(Type_Id
) then
710 Error_Msg_N
("cannot allocate abstract object", E
);
713 if Has_Task
(Designated_Type
(Acc_Type
)) then
714 Check_Restriction
(No_Tasking
, N
);
715 Check_Restriction
(Max_Tasks
, N
);
716 Check_Restriction
(No_Task_Allocators
, N
);
719 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
720 -- type is nested, and the designated type needs finalization. The rule
721 -- is conservative in that class-wide types need finalization.
723 if Needs_Finalization
(Designated_Type
(Acc_Type
))
724 and then not Is_Library_Level_Entity
(Acc_Type
)
726 Check_Restriction
(No_Nested_Finalization
, N
);
729 -- Check that an allocator of a nested access type doesn't create a
730 -- protected object when restriction No_Local_Protected_Objects applies.
731 -- We don't have an equivalent to Has_Task for protected types, so only
732 -- cases where the designated type itself is a protected type are
733 -- currently checked. ???
735 if Is_Protected_Type
(Designated_Type
(Acc_Type
))
736 and then not Is_Library_Level_Entity
(Acc_Type
)
738 Check_Restriction
(No_Local_Protected_Objects
, N
);
741 -- If the No_Streams restriction is set, check that the type of the
742 -- object is not, and does not contain, any subtype derived from
743 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
744 -- Has_Stream just for efficiency reasons. There is no point in
745 -- spending time on a Has_Stream check if the restriction is not set.
747 if Restriction_Check_Required
(No_Streams
) then
748 if Has_Stream
(Designated_Type
(Acc_Type
)) then
749 Check_Restriction
(No_Streams
, N
);
753 Set_Etype
(N
, Acc_Type
);
755 if not Is_Library_Level_Entity
(Acc_Type
) then
756 Check_Restriction
(No_Local_Allocators
, N
);
759 if Serious_Errors_Detected
> Sav_Errs
then
760 Set_Error_Posted
(N
);
761 Set_Etype
(N
, Any_Type
);
763 end Analyze_Allocator
;
765 ---------------------------
766 -- Analyze_Arithmetic_Op --
767 ---------------------------
769 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
770 L
: constant Node_Id
:= Left_Opnd
(N
);
771 R
: constant Node_Id
:= Right_Opnd
(N
);
775 Candidate_Type
:= Empty
;
776 Analyze_Expression
(L
);
777 Analyze_Expression
(R
);
779 -- If the entity is already set, the node is the instantiation of a
780 -- generic node with a non-local reference, or was manufactured by a
781 -- call to Make_Op_xxx. In either case the entity is known to be valid,
782 -- and we do not need to collect interpretations, instead we just get
783 -- the single possible interpretation.
787 if Present
(Op_Id
) then
788 if Ekind
(Op_Id
) = E_Operator
then
790 if Nkind_In
(N
, N_Op_Divide
, N_Op_Mod
, N_Op_Multiply
, N_Op_Rem
)
791 and then Treat_Fixed_As_Integer
(N
)
795 Set_Etype
(N
, Any_Type
);
796 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
800 Set_Etype
(N
, Any_Type
);
801 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
804 -- Entity is not already set, so we do need to collect interpretations
807 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
808 Set_Etype
(N
, Any_Type
);
810 while Present
(Op_Id
) loop
811 if Ekind
(Op_Id
) = E_Operator
812 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
814 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
816 -- The following may seem superfluous, because an operator cannot
817 -- be generic, but this ignores the cleverness of the author of
820 elsif Is_Overloadable
(Op_Id
) then
821 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
824 Op_Id
:= Homonym
(Op_Id
);
829 end Analyze_Arithmetic_Op
;
835 -- Function, procedure, and entry calls are checked here. The Name in
836 -- the call may be overloaded. The actuals have been analyzed and may
837 -- themselves be overloaded. On exit from this procedure, the node N
838 -- may have zero, one or more interpretations. In the first case an
839 -- error message is produced. In the last case, the node is flagged
840 -- as overloaded and the interpretations are collected in All_Interp.
842 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
843 -- the type-checking is similar to that of other calls.
845 procedure Analyze_Call
(N
: Node_Id
) is
846 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
851 Success
: Boolean := False;
853 Deref
: Boolean := False;
854 -- Flag indicates whether an interpretation of the prefix is a
855 -- parameterless call that returns an access_to_subprogram.
857 procedure Check_Ghost_Subprogram_Call
;
858 -- Verify the legality of a call to a ghost subprogram. Such calls can
859 -- appear only in assertion expressions except subtype predicates or
860 -- from within another ghost subprogram.
862 procedure Check_Mixed_Parameter_And_Named_Associations
;
863 -- Check that parameter and named associations are not mixed. This is
864 -- a restriction in SPARK mode.
866 function Name_Denotes_Function
return Boolean;
867 -- If the type of the name is an access to subprogram, this may be the
868 -- type of a name, or the return type of the function being called. If
869 -- the name is not an entity then it can denote a protected function.
870 -- Until we distinguish Etype from Return_Type, we must use this routine
871 -- to resolve the meaning of the name in the call.
873 procedure No_Interpretation
;
874 -- Output error message when no valid interpretation exists
876 ---------------------------------
877 -- Check_Ghost_Subprogram_Call --
878 ---------------------------------
880 procedure Check_Ghost_Subprogram_Call
is
884 -- Do not perform the check while preanalyzing the enclosing context
885 -- because the call is not in its final place. Premature attempts to
886 -- verify the placement lead to bogus errors.
888 if In_Spec_Expression
then
891 -- The ghost subprogram appears inside an assertion expression
892 -- which is one of the allowed cases.
894 elsif In_Assertion_Expression
(N
) then
897 -- Otherwise see if it inside another ghost subprogram
900 -- Loop to climb scopes
903 while Present
(S
) and then S
/= Standard_Standard
loop
905 -- The call appears inside another ghost subprogram
907 if Is_Ghost_Subprogram
(S
) then
914 -- If we fall through the loop it was not within another
915 -- ghost subprogram, so we have bad placement.
918 ("call to ghost subprogram must appear in assertion expression "
919 & "or another ghost subprogram", N
);
921 end Check_Ghost_Subprogram_Call
;
923 --------------------------------------------------
924 -- Check_Mixed_Parameter_And_Named_Associations --
925 --------------------------------------------------
927 procedure Check_Mixed_Parameter_And_Named_Associations
is
929 Named_Seen
: Boolean;
934 Actual
:= First
(Actuals
);
935 while Present
(Actual
) loop
936 case Nkind
(Actual
) is
937 when N_Parameter_Association
=>
939 Check_SPARK_Restriction
940 ("named association cannot follow positional one",
950 end Check_Mixed_Parameter_And_Named_Associations
;
952 ---------------------------
953 -- Name_Denotes_Function --
954 ---------------------------
956 function Name_Denotes_Function
return Boolean is
958 if Is_Entity_Name
(Nam
) then
959 return Ekind
(Entity
(Nam
)) = E_Function
;
961 elsif Nkind
(Nam
) = N_Selected_Component
then
962 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
967 end Name_Denotes_Function
;
969 -----------------------
970 -- No_Interpretation --
971 -----------------------
973 procedure No_Interpretation
is
974 L
: constant Boolean := Is_List_Member
(N
);
975 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
978 -- If the node is in a list whose parent is not an expression then it
979 -- must be an attempted procedure call.
981 if L
and then K
not in N_Subexpr
then
982 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
984 ("must instantiate generic procedure& before call",
988 ("procedure or entry name expected", Nam
);
991 -- Check for tasking cases where only an entry call will do
994 and then Nkind_In
(K
, N_Entry_Call_Alternative
,
995 N_Triggering_Alternative
)
997 Error_Msg_N
("entry name expected", Nam
);
999 -- Otherwise give general error message
1002 Error_Msg_N
("invalid prefix in call", Nam
);
1004 end No_Interpretation
;
1006 -- Start of processing for Analyze_Call
1009 if Restriction_Check_Required
(SPARK_05
) then
1010 Check_Mixed_Parameter_And_Named_Associations
;
1013 -- Mark a function that appears inside an assertion expression
1015 if Nkind
(N
) = N_Function_Call
and then In_Assertion_Expr
> 0 then
1016 Set_In_Assertion_Expression
(N
);
1019 -- Initialize the type of the result of the call to the error type,
1020 -- which will be reset if the type is successfully resolved.
1022 Set_Etype
(N
, Any_Type
);
1026 if not Is_Overloaded
(Nam
) then
1028 -- Only one interpretation to check
1030 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
1031 Nam_Ent
:= Etype
(Nam
);
1033 -- If the prefix is an access_to_subprogram, this may be an indirect
1034 -- call. This is the case if the name in the call is not an entity
1035 -- name, or if it is a function name in the context of a procedure
1036 -- call. In this latter case, we have a call to a parameterless
1037 -- function that returns a pointer_to_procedure which is the entity
1038 -- being called. Finally, F (X) may be a call to a parameterless
1039 -- function that returns a pointer to a function with parameters.
1040 -- Note that if F returns an access-to-subprogram whose designated
1041 -- type is an array, F (X) cannot be interpreted as an indirect call
1042 -- through the result of the call to F.
1044 elsif Is_Access_Type
(Etype
(Nam
))
1045 and then Ekind
(Designated_Type
(Etype
(Nam
))) = E_Subprogram_Type
1047 (not Name_Denotes_Function
1048 or else Nkind
(N
) = N_Procedure_Call_Statement
1050 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1051 and then Is_Entity_Name
(Nam
)
1052 and then No
(First_Formal
(Entity
(Nam
)))
1054 Is_Array_Type
(Etype
(Designated_Type
(Etype
(Nam
))))
1055 and then Present
(Actuals
)))
1057 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
1058 Insert_Explicit_Dereference
(Nam
);
1060 -- Selected component case. Simple entry or protected operation,
1061 -- where the entry name is given by the selector name.
1063 elsif Nkind
(Nam
) = N_Selected_Component
then
1064 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
1066 if not Ekind_In
(Nam_Ent
, E_Entry
,
1071 Error_Msg_N
("name in call is not a callable entity", Nam
);
1072 Set_Etype
(N
, Any_Type
);
1076 -- If the name is an Indexed component, it can be a call to a member
1077 -- of an entry family. The prefix must be a selected component whose
1078 -- selector is the entry. Analyze_Procedure_Call normalizes several
1079 -- kinds of call into this form.
1081 elsif Nkind
(Nam
) = N_Indexed_Component
then
1082 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
1083 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
1085 Error_Msg_N
("name in call is not a callable entity", Nam
);
1086 Set_Etype
(N
, Any_Type
);
1090 elsif not Is_Entity_Name
(Nam
) then
1091 Error_Msg_N
("name in call is not a callable entity", Nam
);
1092 Set_Etype
(N
, Any_Type
);
1096 Nam_Ent
:= Entity
(Nam
);
1098 -- If no interpretations, give error message
1100 if not Is_Overloadable
(Nam_Ent
) then
1106 -- Operations generated for RACW stub types are called only through
1107 -- dispatching, and can never be the static interpretation of a call.
1109 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
1114 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
1116 -- If this is an indirect call, the return type of the access_to
1117 -- subprogram may be an incomplete type. At the point of the call,
1118 -- use the full type if available, and at the same time update the
1119 -- return type of the access_to_subprogram.
1122 and then Nkind
(Nam
) = N_Explicit_Dereference
1123 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
1124 and then Present
(Full_View
(Etype
(N
)))
1126 Set_Etype
(N
, Full_View
(Etype
(N
)));
1127 Set_Etype
(Nam_Ent
, Etype
(N
));
1133 -- An overloaded selected component must denote overloaded operations
1134 -- of a concurrent type. The interpretations are attached to the
1135 -- simple name of those operations.
1137 if Nkind
(Nam
) = N_Selected_Component
then
1138 Nam
:= Selector_Name
(Nam
);
1141 Get_First_Interp
(Nam
, X
, It
);
1143 while Present
(It
.Nam
) loop
1147 -- Name may be call that returns an access to subprogram, or more
1148 -- generally an overloaded expression one of whose interpretations
1149 -- yields an access to subprogram. If the name is an entity, we do
1150 -- not dereference, because the node is a call that returns the
1151 -- access type: note difference between f(x), where the call may
1152 -- return an access subprogram type, and f(x)(y), where the type
1153 -- returned by the call to f is implicitly dereferenced to analyze
1156 if Is_Access_Type
(Nam_Ent
) then
1157 Nam_Ent
:= Designated_Type
(Nam_Ent
);
1159 elsif Is_Access_Type
(Etype
(Nam_Ent
))
1161 (not Is_Entity_Name
(Nam
)
1162 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1163 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
1166 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
1168 if Is_Entity_Name
(Nam
) then
1173 -- If the call has been rewritten from a prefixed call, the first
1174 -- parameter has been analyzed, but may need a subsequent
1175 -- dereference, so skip its analysis now.
1177 if N
/= Original_Node
(N
)
1178 and then Nkind
(Original_Node
(N
)) = Nkind
(N
)
1179 and then Nkind
(Name
(N
)) /= Nkind
(Name
(Original_Node
(N
)))
1180 and then Present
(Parameter_Associations
(N
))
1181 and then Present
(Etype
(First
(Parameter_Associations
(N
))))
1184 (N
, Nam_Ent
, False, Success
, Skip_First
=> True);
1186 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
1189 -- If the interpretation succeeds, mark the proper type of the
1190 -- prefix (any valid candidate will do). If not, remove the
1191 -- candidate interpretation. This only needs to be done for
1192 -- overloaded protected operations, for other entities disambi-
1193 -- guation is done directly in Resolve.
1197 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1199 Set_Entity
(Nam
, It
.Nam
);
1200 Insert_Explicit_Dereference
(Nam
);
1201 Set_Etype
(Nam
, Nam_Ent
);
1204 Set_Etype
(Nam
, It
.Typ
);
1207 elsif Nkind_In
(Name
(N
), N_Selected_Component
,
1213 Get_Next_Interp
(X
, It
);
1216 -- If the name is the result of a function call, it can only be a
1217 -- call to a function returning an access to subprogram. Insert
1218 -- explicit dereference.
1220 if Nkind
(Nam
) = N_Function_Call
then
1221 Insert_Explicit_Dereference
(Nam
);
1224 if Etype
(N
) = Any_Type
then
1226 -- None of the interpretations is compatible with the actuals
1228 Diagnose_Call
(N
, Nam
);
1230 -- Special checks for uninstantiated put routines
1232 if Nkind
(N
) = N_Procedure_Call_Statement
1233 and then Is_Entity_Name
(Nam
)
1234 and then Chars
(Nam
) = Name_Put
1235 and then List_Length
(Actuals
) = 1
1238 Arg
: constant Node_Id
:= First
(Actuals
);
1242 if Nkind
(Arg
) = N_Parameter_Association
then
1243 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
1248 if Is_Signed_Integer_Type
(Typ
) then
1250 ("possible missing instantiation of " &
1251 "'Text_'I'O.'Integer_'I'O!", Nam
);
1253 elsif Is_Modular_Integer_Type
(Typ
) then
1255 ("possible missing instantiation of " &
1256 "'Text_'I'O.'Modular_'I'O!", Nam
);
1258 elsif Is_Floating_Point_Type
(Typ
) then
1260 ("possible missing instantiation of " &
1261 "'Text_'I'O.'Float_'I'O!", Nam
);
1263 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1265 ("possible missing instantiation of " &
1266 "'Text_'I'O.'Fixed_'I'O!", Nam
);
1268 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1270 ("possible missing instantiation of " &
1271 "'Text_'I'O.'Decimal_'I'O!", Nam
);
1273 elsif Is_Enumeration_Type
(Typ
) then
1275 ("possible missing instantiation of " &
1276 "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1281 elsif not Is_Overloaded
(N
)
1282 and then Is_Entity_Name
(Nam
)
1284 -- Resolution yields a single interpretation. Verify that the
1285 -- reference has capitalization consistent with the declaration.
1287 Set_Entity_With_Style_Check
(Nam
, Entity
(Nam
));
1288 Generate_Reference
(Entity
(Nam
), Nam
);
1290 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1292 Remove_Abstract_Operations
(N
);
1298 -- A call to a ghost subprogram is allowed only in assertion expressions
1299 -- excluding subtype predicates or from within another ghost subprogram.
1301 if Is_Ghost_Subprogram
(Get_Subprogram_Entity
(N
)) then
1302 Check_Ghost_Subprogram_Call
;
1306 -----------------------------
1307 -- Analyze_Case_Expression --
1308 -----------------------------
1310 procedure Analyze_Case_Expression
(N
: Node_Id
) is
1311 function Has_Static_Predicate
(Subtyp
: Entity_Id
) return Boolean;
1312 -- Determine whether subtype Subtyp has aspect Static_Predicate
1314 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
1315 -- Error routine invoked by the generic instantiation below when
1316 -- the case expression has a non static choice.
1318 package Case_Choices_Processing
is new
1319 Generic_Choices_Processing
1320 (Get_Alternatives
=> Alternatives
,
1321 Get_Choices
=> Discrete_Choices
,
1322 Process_Empty_Choice
=> No_OP
,
1323 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
1324 Process_Associated_Node
=> No_OP
);
1325 use Case_Choices_Processing
;
1327 --------------------------
1328 -- Has_Static_Predicate --
1329 --------------------------
1331 function Has_Static_Predicate
(Subtyp
: Entity_Id
) return Boolean is
1335 Item
:= First_Rep_Item
(Subtyp
);
1336 while Present
(Item
) loop
1337 if Nkind
(Item
) = N_Aspect_Specification
1338 and then Chars
(Identifier
(Item
)) = Name_Static_Predicate
1343 Next_Rep_Item
(Item
);
1347 end Has_Static_Predicate
;
1349 -----------------------------
1350 -- Non_Static_Choice_Error --
1351 -----------------------------
1353 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
1355 Flag_Non_Static_Expr
1356 ("choice given in case expression is not static!", Choice
);
1357 end Non_Static_Choice_Error
;
1361 Expr
: constant Node_Id
:= Expression
(N
);
1362 FirstX
: constant Node_Id
:= Expression
(First
(Alternatives
(N
)));
1364 Exp_Type
: Entity_Id
;
1365 Exp_Btype
: Entity_Id
;
1367 Dont_Care
: Boolean;
1368 Others_Present
: Boolean;
1370 -- Start of processing for Analyze_Case_Expression
1373 if Comes_From_Source
(N
) then
1374 Check_Compiler_Unit
(N
);
1377 Analyze_And_Resolve
(Expr
, Any_Discrete
);
1378 Check_Unset_Reference
(Expr
);
1379 Exp_Type
:= Etype
(Expr
);
1380 Exp_Btype
:= Base_Type
(Exp_Type
);
1382 Alt
:= First
(Alternatives
(N
));
1383 while Present
(Alt
) loop
1384 Analyze
(Expression
(Alt
));
1388 if not Is_Overloaded
(FirstX
) then
1389 Set_Etype
(N
, Etype
(FirstX
));
1397 Set_Etype
(N
, Any_Type
);
1399 Get_First_Interp
(FirstX
, I
, It
);
1400 while Present
(It
.Nam
) loop
1402 -- For each interpretation of the first expression, we only
1403 -- add the interpretation if every other expression in the
1404 -- case expression alternatives has a compatible type.
1406 Alt
:= Next
(First
(Alternatives
(N
)));
1407 while Present
(Alt
) loop
1408 exit when not Has_Compatible_Type
(Expression
(Alt
), It
.Typ
);
1413 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1416 Get_Next_Interp
(I
, It
);
1421 Exp_Btype
:= Base_Type
(Exp_Type
);
1423 -- The expression must be of a discrete type which must be determinable
1424 -- independently of the context in which the expression occurs, but
1425 -- using the fact that the expression must be of a discrete type.
1426 -- Moreover, the type this expression must not be a character literal
1427 -- (which is always ambiguous).
1429 -- If error already reported by Resolve, nothing more to do
1431 if Exp_Btype
= Any_Discrete
1432 or else Exp_Btype
= Any_Type
1436 elsif Exp_Btype
= Any_Character
then
1438 ("character literal as case expression is ambiguous", Expr
);
1442 -- If the case expression is a formal object of mode in out, then
1443 -- treat it as having a nonstatic subtype by forcing use of the base
1444 -- type (which has to get passed to Check_Case_Choices below). Also
1445 -- use base type when the case expression is parenthesized.
1447 if Paren_Count
(Expr
) > 0
1448 or else (Is_Entity_Name
(Expr
)
1449 and then Ekind
(Entity
(Expr
)) = E_Generic_In_Out_Parameter
)
1451 Exp_Type
:= Exp_Btype
;
1454 -- The case expression alternatives cover the range of a static subtype
1455 -- subject to aspect Static_Predicate. Do not check the choices when the
1456 -- case expression has not been fully analyzed yet because this may lead
1459 if Is_Static_Subtype
(Exp_Type
)
1460 and then Has_Static_Predicate
(Exp_Type
)
1461 and then In_Spec_Expression
1465 -- Call instantiated Analyze_Choices which does the rest of the work
1468 Analyze_Choices
(N
, Exp_Type
, Dont_Care
, Others_Present
);
1471 if Exp_Type
= Universal_Integer
and then not Others_Present
then
1473 ("case on universal integer requires OTHERS choice", Expr
);
1475 end Analyze_Case_Expression
;
1477 ---------------------------
1478 -- Analyze_Comparison_Op --
1479 ---------------------------
1481 procedure Analyze_Comparison_Op
(N
: Node_Id
) is
1482 L
: constant Node_Id
:= Left_Opnd
(N
);
1483 R
: constant Node_Id
:= Right_Opnd
(N
);
1484 Op_Id
: Entity_Id
:= Entity
(N
);
1487 Set_Etype
(N
, Any_Type
);
1488 Candidate_Type
:= Empty
;
1490 Analyze_Expression
(L
);
1491 Analyze_Expression
(R
);
1493 if Present
(Op_Id
) then
1494 if Ekind
(Op_Id
) = E_Operator
then
1495 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1497 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1500 if Is_Overloaded
(L
) then
1501 Set_Etype
(L
, Intersect_Types
(L
, R
));
1505 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1506 while Present
(Op_Id
) loop
1507 if Ekind
(Op_Id
) = E_Operator
then
1508 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1510 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1513 Op_Id
:= Homonym
(Op_Id
);
1518 end Analyze_Comparison_Op
;
1520 ---------------------------
1521 -- Analyze_Concatenation --
1522 ---------------------------
1524 procedure Analyze_Concatenation
(N
: Node_Id
) is
1526 -- We wish to avoid deep recursion, because concatenations are often
1527 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1528 -- operands nonrecursively until we find something that is not a
1529 -- concatenation (A in this case), or has already been analyzed. We
1530 -- analyze that, and then walk back up the tree following Parent
1531 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1532 -- work at each level. The Parent pointers allow us to avoid recursion,
1533 -- and thus avoid running out of memory.
1539 Candidate_Type
:= Empty
;
1541 -- The following code is equivalent to:
1543 -- Set_Etype (N, Any_Type);
1544 -- Analyze_Expression (Left_Opnd (N));
1545 -- Analyze_Concatenation_Rest (N);
1547 -- where the Analyze_Expression call recurses back here if the left
1548 -- operand is a concatenation.
1550 -- Walk down left operands
1553 Set_Etype
(NN
, Any_Type
);
1554 L
:= Left_Opnd
(NN
);
1555 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1559 -- Now (given the above example) NN is A&B and L is A
1561 -- First analyze L ...
1563 Analyze_Expression
(L
);
1565 -- ... then walk NN back up until we reach N (where we started), calling
1566 -- Analyze_Concatenation_Rest along the way.
1569 Analyze_Concatenation_Rest
(NN
);
1573 end Analyze_Concatenation
;
1575 --------------------------------
1576 -- Analyze_Concatenation_Rest --
1577 --------------------------------
1579 -- If the only one-dimensional array type in scope is String,
1580 -- this is the resulting type of the operation. Otherwise there
1581 -- will be a concatenation operation defined for each user-defined
1582 -- one-dimensional array.
1584 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1585 L
: constant Node_Id
:= Left_Opnd
(N
);
1586 R
: constant Node_Id
:= Right_Opnd
(N
);
1587 Op_Id
: Entity_Id
:= Entity
(N
);
1592 Analyze_Expression
(R
);
1594 -- If the entity is present, the node appears in an instance, and
1595 -- denotes a predefined concatenation operation. The resulting type is
1596 -- obtained from the arguments when possible. If the arguments are
1597 -- aggregates, the array type and the concatenation type must be
1600 if Present
(Op_Id
) then
1601 if Ekind
(Op_Id
) = E_Operator
then
1602 LT
:= Base_Type
(Etype
(L
));
1603 RT
:= Base_Type
(Etype
(R
));
1605 if Is_Array_Type
(LT
)
1606 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1608 Add_One_Interp
(N
, Op_Id
, LT
);
1610 elsif Is_Array_Type
(RT
)
1611 and then LT
= Base_Type
(Component_Type
(RT
))
1613 Add_One_Interp
(N
, Op_Id
, RT
);
1615 -- If one operand is a string type or a user-defined array type,
1616 -- and the other is a literal, result is of the specific type.
1619 (Root_Type
(LT
) = Standard_String
1620 or else Scope
(LT
) /= Standard_Standard
)
1621 and then Etype
(R
) = Any_String
1623 Add_One_Interp
(N
, Op_Id
, LT
);
1626 (Root_Type
(RT
) = Standard_String
1627 or else Scope
(RT
) /= Standard_Standard
)
1628 and then Etype
(L
) = Any_String
1630 Add_One_Interp
(N
, Op_Id
, RT
);
1632 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
1633 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1636 -- Type and its operations must be visible
1638 Set_Entity
(N
, Empty
);
1639 Analyze_Concatenation
(N
);
1643 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1647 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
1648 while Present
(Op_Id
) loop
1649 if Ekind
(Op_Id
) = E_Operator
then
1651 -- Do not consider operators declared in dead code, they can
1652 -- not be part of the resolution.
1654 if Is_Eliminated
(Op_Id
) then
1657 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
1661 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1664 Op_Id
:= Homonym
(Op_Id
);
1669 end Analyze_Concatenation_Rest
;
1671 -------------------------
1672 -- Analyze_Equality_Op --
1673 -------------------------
1675 procedure Analyze_Equality_Op
(N
: Node_Id
) is
1676 Loc
: constant Source_Ptr
:= Sloc
(N
);
1677 L
: constant Node_Id
:= Left_Opnd
(N
);
1678 R
: constant Node_Id
:= Right_Opnd
(N
);
1682 Set_Etype
(N
, Any_Type
);
1683 Candidate_Type
:= Empty
;
1685 Analyze_Expression
(L
);
1686 Analyze_Expression
(R
);
1688 -- If the entity is set, the node is a generic instance with a non-local
1689 -- reference to the predefined operator or to a user-defined function.
1690 -- It can also be an inequality that is expanded into the negation of a
1691 -- call to a user-defined equality operator.
1693 -- For the predefined case, the result is Boolean, regardless of the
1694 -- type of the operands. The operands may even be limited, if they are
1695 -- generic actuals. If they are overloaded, label the left argument with
1696 -- the common type that must be present, or with the type of the formal
1697 -- of the user-defined function.
1699 if Present
(Entity
(N
)) then
1700 Op_Id
:= Entity
(N
);
1702 if Ekind
(Op_Id
) = E_Operator
then
1703 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
1705 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1708 if Is_Overloaded
(L
) then
1709 if Ekind
(Op_Id
) = E_Operator
then
1710 Set_Etype
(L
, Intersect_Types
(L
, R
));
1712 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
1717 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1718 while Present
(Op_Id
) loop
1719 if Ekind
(Op_Id
) = E_Operator
then
1720 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1722 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1725 Op_Id
:= Homonym
(Op_Id
);
1729 -- If there was no match, and the operator is inequality, this may
1730 -- be a case where inequality has not been made explicit, as for
1731 -- tagged types. Analyze the node as the negation of an equality
1732 -- operation. This cannot be done earlier, because before analysis
1733 -- we cannot rule out the presence of an explicit inequality.
1735 if Etype
(N
) = Any_Type
1736 and then Nkind
(N
) = N_Op_Ne
1738 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
1739 while Present
(Op_Id
) loop
1740 if Ekind
(Op_Id
) = E_Operator
then
1741 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1743 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1746 Op_Id
:= Homonym
(Op_Id
);
1749 if Etype
(N
) /= Any_Type
then
1750 Op_Id
:= Entity
(N
);
1756 Left_Opnd
=> Left_Opnd
(N
),
1757 Right_Opnd
=> Right_Opnd
(N
))));
1759 Set_Entity
(Right_Opnd
(N
), Op_Id
);
1765 end Analyze_Equality_Op
;
1767 ----------------------------------
1768 -- Analyze_Explicit_Dereference --
1769 ----------------------------------
1771 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
1772 Loc
: constant Source_Ptr
:= Sloc
(N
);
1773 P
: constant Node_Id
:= Prefix
(N
);
1779 function Is_Function_Type
return Boolean;
1780 -- Check whether node may be interpreted as an implicit function call
1782 ----------------------
1783 -- Is_Function_Type --
1784 ----------------------
1786 function Is_Function_Type
return Boolean is
1791 if not Is_Overloaded
(N
) then
1792 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
1793 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
1796 Get_First_Interp
(N
, I
, It
);
1797 while Present
(It
.Nam
) loop
1798 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
1799 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
1804 Get_Next_Interp
(I
, It
);
1809 end Is_Function_Type
;
1811 -- Start of processing for Analyze_Explicit_Dereference
1814 -- If source node, check SPARK restriction. We guard this with the
1815 -- source node check, because ???
1817 if Comes_From_Source
(N
) then
1818 Check_SPARK_Restriction
("explicit dereference is not allowed", N
);
1821 -- In formal verification mode, keep track of all reads and writes
1822 -- through explicit dereferences.
1825 SPARK_Specific
.Generate_Dereference
(N
);
1829 Set_Etype
(N
, Any_Type
);
1831 -- Test for remote access to subprogram type, and if so return
1832 -- after rewriting the original tree.
1834 if Remote_AST_E_Dereference
(P
) then
1838 -- Normal processing for other than remote access to subprogram type
1840 if not Is_Overloaded
(P
) then
1841 if Is_Access_Type
(Etype
(P
)) then
1843 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
1844 -- avoid other problems caused by the Private_Subtype and it is
1845 -- safe to go to the Base_Type because this is the same as
1846 -- converting the access value to its Base_Type.
1849 DT
: Entity_Id
:= Designated_Type
(Etype
(P
));
1852 if Ekind
(DT
) = E_Private_Subtype
1853 and then Is_For_Access_Subtype
(DT
)
1855 DT
:= Base_Type
(DT
);
1858 -- An explicit dereference is a legal occurrence of an
1859 -- incomplete type imported through a limited_with clause,
1860 -- if the full view is visible.
1862 if From_With_Type
(DT
)
1863 and then not From_With_Type
(Scope
(DT
))
1865 (Is_Immediately_Visible
(Scope
(DT
))
1867 (Is_Child_Unit
(Scope
(DT
))
1868 and then Is_Visible_Lib_Unit
(Scope
(DT
))))
1870 Set_Etype
(N
, Available_View
(DT
));
1877 elsif Etype
(P
) /= Any_Type
then
1878 Error_Msg_N
("prefix of dereference must be an access type", N
);
1883 Get_First_Interp
(P
, I
, It
);
1884 while Present
(It
.Nam
) loop
1887 if Is_Access_Type
(T
) then
1888 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
1891 Get_Next_Interp
(I
, It
);
1894 -- Error if no interpretation of the prefix has an access type
1896 if Etype
(N
) = Any_Type
then
1898 ("access type required in prefix of explicit dereference", P
);
1899 Set_Etype
(N
, Any_Type
);
1905 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
1907 and then (Nkind
(Parent
(N
)) /= N_Function_Call
1908 or else N
/= Name
(Parent
(N
)))
1910 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1911 or else N
/= Name
(Parent
(N
)))
1913 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
1914 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
1916 (Attribute_Name
(Parent
(N
)) /= Name_Address
1918 Attribute_Name
(Parent
(N
)) /= Name_Access
))
1920 -- Name is a function call with no actuals, in a context that
1921 -- requires deproceduring (including as an actual in an enclosing
1922 -- function or procedure call). There are some pathological cases
1923 -- where the prefix might include functions that return access to
1924 -- subprograms and others that return a regular type. Disambiguation
1925 -- of those has to take place in Resolve.
1928 Make_Function_Call
(Loc
,
1929 Name
=> Make_Explicit_Dereference
(Loc
, P
),
1930 Parameter_Associations
=> New_List
);
1932 -- If the prefix is overloaded, remove operations that have formals,
1933 -- we know that this is a parameterless call.
1935 if Is_Overloaded
(P
) then
1936 Get_First_Interp
(P
, I
, It
);
1937 while Present
(It
.Nam
) loop
1940 if No
(First_Formal
(Base_Type
(Designated_Type
(T
)))) then
1946 Get_Next_Interp
(I
, It
);
1953 elsif not Is_Function_Type
1954 and then Is_Overloaded
(N
)
1956 -- The prefix may include access to subprograms and other access
1957 -- types. If the context selects the interpretation that is a
1958 -- function call (not a procedure call) we cannot rewrite the node
1959 -- yet, but we include the result of the call interpretation.
1961 Get_First_Interp
(N
, I
, It
);
1962 while Present
(It
.Nam
) loop
1963 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
1964 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
1965 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1967 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
1970 Get_Next_Interp
(I
, It
);
1974 -- A value of remote access-to-class-wide must not be dereferenced
1977 Validate_Remote_Access_To_Class_Wide_Type
(N
);
1978 end Analyze_Explicit_Dereference
;
1980 ------------------------
1981 -- Analyze_Expression --
1982 ------------------------
1984 procedure Analyze_Expression
(N
: Node_Id
) is
1987 Check_Parameterless_Call
(N
);
1988 end Analyze_Expression
;
1990 -------------------------------------
1991 -- Analyze_Expression_With_Actions --
1992 -------------------------------------
1994 procedure Analyze_Expression_With_Actions
(N
: Node_Id
) is
1998 A
:= First
(Actions
(N
));
1999 while Present
(A
) loop
2004 -- We currently hijack Expression_With_Actions with a VOID type and
2005 -- a NULL statement in the Expression. This will ultimately be replaced
2006 -- by a proper separate N_Compound_Statement node, at which point the
2007 -- test below can go away???
2009 if Nkind
(Expression
(N
)) = N_Null_Statement
then
2010 Set_Etype
(N
, Standard_Void_Type
);
2012 Analyze_Expression
(Expression
(N
));
2013 Set_Etype
(N
, Etype
(Expression
(N
)));
2015 end Analyze_Expression_With_Actions
;
2017 ---------------------------
2018 -- Analyze_If_Expression --
2019 ---------------------------
2021 procedure Analyze_If_Expression
(N
: Node_Id
) is
2022 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2023 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2024 Else_Expr
: Node_Id
;
2027 -- Defend against error of missing expressions from previous error
2029 if No
(Then_Expr
) then
2030 Check_Error_Detected
;
2034 Check_SPARK_Restriction
("if expression is not allowed", N
);
2036 Else_Expr
:= Next
(Then_Expr
);
2038 if Comes_From_Source
(N
) then
2039 Check_Compiler_Unit
(N
);
2042 Analyze_Expression
(Condition
);
2043 Analyze_Expression
(Then_Expr
);
2045 if Present
(Else_Expr
) then
2046 Analyze_Expression
(Else_Expr
);
2049 -- If then expression not overloaded, then that decides the type
2051 if not Is_Overloaded
(Then_Expr
) then
2052 Set_Etype
(N
, Etype
(Then_Expr
));
2054 -- Case where then expression is overloaded
2062 Set_Etype
(N
, Any_Type
);
2064 -- Shouldn't the following statement be down in the ELSE of the
2065 -- following loop? ???
2067 Get_First_Interp
(Then_Expr
, I
, It
);
2069 -- if no Else_Expression the conditional must be boolean
2071 if No
(Else_Expr
) then
2072 Set_Etype
(N
, Standard_Boolean
);
2074 -- Else_Expression Present. For each possible intepretation of
2075 -- the Then_Expression, add it only if the Else_Expression has
2076 -- a compatible type.
2079 while Present
(It
.Nam
) loop
2080 if Has_Compatible_Type
(Else_Expr
, It
.Typ
) then
2081 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
2084 Get_Next_Interp
(I
, It
);
2089 end Analyze_If_Expression
;
2091 ------------------------------------
2092 -- Analyze_Indexed_Component_Form --
2093 ------------------------------------
2095 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
2096 P
: constant Node_Id
:= Prefix
(N
);
2097 Exprs
: constant List_Id
:= Expressions
(N
);
2103 procedure Process_Function_Call
;
2104 -- Prefix in indexed component form is an overloadable entity,
2105 -- so the node is a function call. Reformat it as such.
2107 procedure Process_Indexed_Component
;
2108 -- Prefix in indexed component form is actually an indexed component.
2109 -- This routine processes it, knowing that the prefix is already
2112 procedure Process_Indexed_Component_Or_Slice
;
2113 -- An indexed component with a single index may designate a slice if
2114 -- the index is a subtype mark. This routine disambiguates these two
2115 -- cases by resolving the prefix to see if it is a subtype mark.
2117 procedure Process_Overloaded_Indexed_Component
;
2118 -- If the prefix of an indexed component is overloaded, the proper
2119 -- interpretation is selected by the index types and the context.
2121 ---------------------------
2122 -- Process_Function_Call --
2123 ---------------------------
2125 procedure Process_Function_Call
is
2129 Change_Node
(N
, N_Function_Call
);
2131 Set_Parameter_Associations
(N
, Exprs
);
2133 -- Analyze actuals prior to analyzing the call itself
2135 Actual
:= First
(Parameter_Associations
(N
));
2136 while Present
(Actual
) loop
2138 Check_Parameterless_Call
(Actual
);
2140 -- Move to next actual. Note that we use Next, not Next_Actual
2141 -- here. The reason for this is a bit subtle. If a function call
2142 -- includes named associations, the parser recognizes the node as
2143 -- a call, and it is analyzed as such. If all associations are
2144 -- positional, the parser builds an indexed_component node, and
2145 -- it is only after analysis of the prefix that the construct
2146 -- is recognized as a call, in which case Process_Function_Call
2147 -- rewrites the node and analyzes the actuals. If the list of
2148 -- actuals is malformed, the parser may leave the node as an
2149 -- indexed component (despite the presence of named associations).
2150 -- The iterator Next_Actual is equivalent to Next if the list is
2151 -- positional, but follows the normalized chain of actuals when
2152 -- named associations are present. In this case normalization has
2153 -- not taken place, and actuals remain unanalyzed, which leads to
2154 -- subsequent crashes or loops if there is an attempt to continue
2155 -- analysis of the program.
2161 end Process_Function_Call
;
2163 -------------------------------
2164 -- Process_Indexed_Component --
2165 -------------------------------
2167 procedure Process_Indexed_Component
is
2169 Array_Type
: Entity_Id
;
2171 Pent
: Entity_Id
:= Empty
;
2174 Exp
:= First
(Exprs
);
2176 if Is_Overloaded
(P
) then
2177 Process_Overloaded_Indexed_Component
;
2180 Array_Type
:= Etype
(P
);
2182 if Is_Entity_Name
(P
) then
2184 elsif Nkind
(P
) = N_Selected_Component
2185 and then Is_Entity_Name
(Selector_Name
(P
))
2187 Pent
:= Entity
(Selector_Name
(P
));
2190 -- Prefix must be appropriate for an array type, taking into
2191 -- account a possible implicit dereference.
2193 if Is_Access_Type
(Array_Type
) then
2195 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2196 Array_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, P
);
2199 if Is_Array_Type
(Array_Type
) then
2202 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
2204 Set_Etype
(N
, Any_Type
);
2206 if not Has_Compatible_Type
2207 (Exp
, Entry_Index_Type
(Pent
))
2209 Error_Msg_N
("invalid index type in entry name", N
);
2211 elsif Present
(Next
(Exp
)) then
2212 Error_Msg_N
("too many subscripts in entry reference", N
);
2215 Set_Etype
(N
, Etype
(P
));
2220 elsif Is_Record_Type
(Array_Type
)
2221 and then Remote_AST_I_Dereference
(P
)
2225 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2228 elsif Array_Type
= Any_Type
then
2229 Set_Etype
(N
, Any_Type
);
2231 -- In most cases the analysis of the prefix will have emitted
2232 -- an error already, but if the prefix may be interpreted as a
2233 -- call in prefixed notation, the report is left to the caller.
2234 -- To prevent cascaded errors, report only if no previous ones.
2236 if Serious_Errors_Detected
= 0 then
2237 Error_Msg_N
("invalid prefix in indexed component", P
);
2239 if Nkind
(P
) = N_Expanded_Name
then
2240 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
2246 -- Here we definitely have a bad indexing
2249 if Nkind
(Parent
(N
)) = N_Requeue_Statement
2250 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
2253 ("REQUEUE does not permit parameters", First
(Exprs
));
2255 elsif Is_Entity_Name
(P
)
2256 and then Etype
(P
) = Standard_Void_Type
2258 Error_Msg_NE
("incorrect use of&", P
, Entity
(P
));
2261 Error_Msg_N
("array type required in indexed component", P
);
2264 Set_Etype
(N
, Any_Type
);
2268 Index
:= First_Index
(Array_Type
);
2269 while Present
(Index
) and then Present
(Exp
) loop
2270 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2271 Wrong_Type
(Exp
, Etype
(Index
));
2272 Set_Etype
(N
, Any_Type
);
2280 Set_Etype
(N
, Component_Type
(Array_Type
));
2281 Check_Implicit_Dereference
(N
, Etype
(N
));
2283 if Present
(Index
) then
2285 ("too few subscripts in array reference", First
(Exprs
));
2287 elsif Present
(Exp
) then
2288 Error_Msg_N
("too many subscripts in array reference", Exp
);
2291 end Process_Indexed_Component
;
2293 ----------------------------------------
2294 -- Process_Indexed_Component_Or_Slice --
2295 ----------------------------------------
2297 procedure Process_Indexed_Component_Or_Slice
is
2299 Exp
:= First
(Exprs
);
2300 while Present
(Exp
) loop
2301 Analyze_Expression
(Exp
);
2305 Exp
:= First
(Exprs
);
2307 -- If one index is present, and it is a subtype name, then the
2308 -- node denotes a slice (note that the case of an explicit range
2309 -- for a slice was already built as an N_Slice node in the first
2310 -- place, so that case is not handled here).
2312 -- We use a replace rather than a rewrite here because this is one
2313 -- of the cases in which the tree built by the parser is plain wrong.
2316 and then Is_Entity_Name
(Exp
)
2317 and then Is_Type
(Entity
(Exp
))
2320 Make_Slice
(Sloc
(N
),
2322 Discrete_Range
=> New_Copy
(Exp
)));
2325 -- Otherwise (more than one index present, or single index is not
2326 -- a subtype name), then we have the indexed component case.
2329 Process_Indexed_Component
;
2331 end Process_Indexed_Component_Or_Slice
;
2333 ------------------------------------------
2334 -- Process_Overloaded_Indexed_Component --
2335 ------------------------------------------
2337 procedure Process_Overloaded_Indexed_Component
is
2346 Set_Etype
(N
, Any_Type
);
2348 Get_First_Interp
(P
, I
, It
);
2349 while Present
(It
.Nam
) loop
2352 if Is_Access_Type
(Typ
) then
2353 Typ
:= Designated_Type
(Typ
);
2355 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2358 if Is_Array_Type
(Typ
) then
2360 -- Got a candidate: verify that index types are compatible
2362 Index
:= First_Index
(Typ
);
2364 Exp
:= First
(Exprs
);
2365 while Present
(Index
) and then Present
(Exp
) loop
2366 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2378 if Found
and then No
(Index
) and then No
(Exp
) then
2380 CT
: constant Entity_Id
:=
2381 Base_Type
(Component_Type
(Typ
));
2383 Add_One_Interp
(N
, CT
, CT
);
2384 Check_Implicit_Dereference
(N
, CT
);
2388 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2393 Get_Next_Interp
(I
, It
);
2396 if Etype
(N
) = Any_Type
then
2397 Error_Msg_N
("no legal interpretation for indexed component", N
);
2398 Set_Is_Overloaded
(N
, False);
2402 end Process_Overloaded_Indexed_Component
;
2404 -- Start of processing for Analyze_Indexed_Component_Form
2407 -- Get name of array, function or type
2411 -- If P is an explicit dereference whose prefix is of a remote access-
2412 -- to-subprogram type, then N has already been rewritten as a subprogram
2413 -- call and analyzed.
2415 if Nkind
(N
) in N_Subprogram_Call
then
2418 -- When the prefix is attribute 'Loop_Entry and the sole expression of
2419 -- the indexed component denotes a loop name, the indexed form is turned
2420 -- into an attribute reference.
2422 elsif Nkind
(N
) = N_Attribute_Reference
2423 and then Attribute_Name
(N
) = Name_Loop_Entry
2428 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
2430 P_T
:= Base_Type
(Etype
(P
));
2432 if Is_Entity_Name
(P
) and then Present
(Entity
(P
)) then
2435 if Is_Type
(U_N
) then
2437 -- Reformat node as a type conversion
2439 E
:= Remove_Head
(Exprs
);
2441 if Present
(First
(Exprs
)) then
2443 ("argument of type conversion must be single expression", N
);
2446 Change_Node
(N
, N_Type_Conversion
);
2447 Set_Subtype_Mark
(N
, P
);
2449 Set_Expression
(N
, E
);
2451 -- After changing the node, call for the specific Analysis
2452 -- routine directly, to avoid a double call to the expander.
2454 Analyze_Type_Conversion
(N
);
2458 if Is_Overloadable
(U_N
) then
2459 Process_Function_Call
;
2461 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
2462 or else (Is_Access_Type
(Etype
(P
))
2464 Ekind
(Designated_Type
(Etype
(P
))) =
2467 -- Call to access_to-subprogram with possible implicit dereference
2469 Process_Function_Call
;
2471 elsif Is_Generic_Subprogram
(U_N
) then
2473 -- A common beginner's (or C++ templates fan) error
2475 Error_Msg_N
("generic subprogram cannot be called", N
);
2476 Set_Etype
(N
, Any_Type
);
2480 Process_Indexed_Component_Or_Slice
;
2483 -- If not an entity name, prefix is an expression that may denote
2484 -- an array or an access-to-subprogram.
2487 if Ekind
(P_T
) = E_Subprogram_Type
2488 or else (Is_Access_Type
(P_T
)
2490 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
2492 Process_Function_Call
;
2494 elsif Nkind
(P
) = N_Selected_Component
2495 and then Present
(Entity
(Selector_Name
(P
)))
2496 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
2498 Process_Function_Call
;
2500 -- In ASIS mode within a generic, a prefixed call is analyzed and
2501 -- partially rewritten but the original indexed component has not
2502 -- yet been rewritten as a call. Perform the replacement now.
2504 elsif Nkind
(P
) = N_Selected_Component
2505 and then Nkind
(Parent
(P
)) = N_Function_Call
2508 Rewrite
(N
, Parent
(P
));
2512 -- Indexed component, slice, or a call to a member of a family
2513 -- entry, which will be converted to an entry call later.
2515 Process_Indexed_Component_Or_Slice
;
2519 Analyze_Dimension
(N
);
2520 end Analyze_Indexed_Component_Form
;
2522 ------------------------
2523 -- Analyze_Logical_Op --
2524 ------------------------
2526 procedure Analyze_Logical_Op
(N
: Node_Id
) is
2527 L
: constant Node_Id
:= Left_Opnd
(N
);
2528 R
: constant Node_Id
:= Right_Opnd
(N
);
2529 Op_Id
: Entity_Id
:= Entity
(N
);
2532 Set_Etype
(N
, Any_Type
);
2533 Candidate_Type
:= Empty
;
2535 Analyze_Expression
(L
);
2536 Analyze_Expression
(R
);
2538 if Present
(Op_Id
) then
2540 if Ekind
(Op_Id
) = E_Operator
then
2541 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2543 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2547 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2548 while Present
(Op_Id
) loop
2549 if Ekind
(Op_Id
) = E_Operator
then
2550 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2552 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2555 Op_Id
:= Homonym
(Op_Id
);
2560 end Analyze_Logical_Op
;
2562 ---------------------------
2563 -- Analyze_Membership_Op --
2564 ---------------------------
2566 procedure Analyze_Membership_Op
(N
: Node_Id
) is
2567 Loc
: constant Source_Ptr
:= Sloc
(N
);
2568 L
: constant Node_Id
:= Left_Opnd
(N
);
2569 R
: constant Node_Id
:= Right_Opnd
(N
);
2571 Index
: Interp_Index
;
2573 Found
: Boolean := False;
2577 procedure Try_One_Interp
(T1
: Entity_Id
);
2578 -- Routine to try one proposed interpretation. Note that the context
2579 -- of the operation plays no role in resolving the arguments, so that
2580 -- if there is more than one interpretation of the operands that is
2581 -- compatible with a membership test, the operation is ambiguous.
2583 --------------------
2584 -- Try_One_Interp --
2585 --------------------
2587 procedure Try_One_Interp
(T1
: Entity_Id
) is
2589 if Has_Compatible_Type
(R
, T1
) then
2591 and then Base_Type
(T1
) /= Base_Type
(T_F
)
2593 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
2595 if It
= No_Interp
then
2596 Ambiguous_Operands
(N
);
2597 Set_Etype
(L
, Any_Type
);
2614 procedure Analyze_Set_Membership
;
2615 -- If a set of alternatives is present, analyze each and find the
2616 -- common type to which they must all resolve.
2618 ----------------------------
2619 -- Analyze_Set_Membership --
2620 ----------------------------
2622 procedure Analyze_Set_Membership
is
2624 Index
: Interp_Index
;
2626 Candidate_Interps
: Node_Id
;
2627 Common_Type
: Entity_Id
:= Empty
;
2631 Candidate_Interps
:= L
;
2633 if not Is_Overloaded
(L
) then
2634 Common_Type
:= Etype
(L
);
2636 Alt
:= First
(Alternatives
(N
));
2637 while Present
(Alt
) loop
2640 if not Has_Compatible_Type
(Alt
, Common_Type
) then
2641 Wrong_Type
(Alt
, Common_Type
);
2648 Alt
:= First
(Alternatives
(N
));
2649 while Present
(Alt
) loop
2651 if not Is_Overloaded
(Alt
) then
2652 Common_Type
:= Etype
(Alt
);
2655 Get_First_Interp
(Alt
, Index
, It
);
2656 while Present
(It
.Typ
) loop
2658 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
2660 Remove_Interp
(Index
);
2663 Get_Next_Interp
(Index
, It
);
2666 Get_First_Interp
(Alt
, Index
, It
);
2669 Error_Msg_N
("alternative has no legal type", Alt
);
2673 -- If alternative is not overloaded, we have a unique type
2676 Set_Etype
(Alt
, It
.Typ
);
2677 Get_Next_Interp
(Index
, It
);
2680 Set_Is_Overloaded
(Alt
, False);
2681 Common_Type
:= Etype
(Alt
);
2684 Candidate_Interps
:= Alt
;
2691 Set_Etype
(N
, Standard_Boolean
);
2693 if Present
(Common_Type
) then
2694 Set_Etype
(L
, Common_Type
);
2695 Set_Is_Overloaded
(L
, False);
2698 Error_Msg_N
("cannot resolve membership operation", N
);
2700 end Analyze_Set_Membership
;
2702 -- Start of processing for Analyze_Membership_Op
2705 Analyze_Expression
(L
);
2708 and then Ada_Version
>= Ada_2012
2710 Analyze_Set_Membership
;
2714 if Nkind
(R
) = N_Range
2715 or else (Nkind
(R
) = N_Attribute_Reference
2716 and then Attribute_Name
(R
) = Name_Range
)
2720 if not Is_Overloaded
(L
) then
2721 Try_One_Interp
(Etype
(L
));
2724 Get_First_Interp
(L
, Index
, It
);
2725 while Present
(It
.Typ
) loop
2726 Try_One_Interp
(It
.Typ
);
2727 Get_Next_Interp
(Index
, It
);
2731 -- If not a range, it can be a subtype mark, or else it is a degenerate
2732 -- membership test with a singleton value, i.e. a test for equality,
2733 -- if the types are compatible.
2738 if Is_Entity_Name
(R
)
2739 and then Is_Type
(Entity
(R
))
2742 Check_Fully_Declared
(Entity
(R
), R
);
2744 elsif Ada_Version
>= Ada_2012
2745 and then Has_Compatible_Type
(R
, Etype
(L
))
2747 if Nkind
(N
) = N_In
then
2763 -- In all versions of the language, if we reach this point there
2764 -- is a previous error that will be diagnosed below.
2770 -- Compatibility between expression and subtype mark or range is
2771 -- checked during resolution. The result of the operation is Boolean
2774 Set_Etype
(N
, Standard_Boolean
);
2776 if Comes_From_Source
(N
)
2777 and then Present
(Right_Opnd
(N
))
2778 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
2780 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
2782 end Analyze_Membership_Op
;
2788 procedure Analyze_Mod
(N
: Node_Id
) is
2790 -- A special warning check, if we have an expression of the form:
2791 -- expr mod 2 * literal
2792 -- where literal is 64 or less, then probably what was meant was
2793 -- expr mod 2 ** literal
2794 -- so issue an appropriate warning.
2796 if Warn_On_Suspicious_Modulus_Value
2797 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
2798 and then Intval
(Right_Opnd
(N
)) = Uint_2
2799 and then Nkind
(Parent
(N
)) = N_Op_Multiply
2800 and then Nkind
(Right_Opnd
(Parent
(N
))) = N_Integer_Literal
2801 and then Intval
(Right_Opnd
(Parent
(N
))) <= Uint_64
2804 ("suspicious MOD value, was '*'* intended'??M?", Parent
(N
));
2807 -- Remaining processing is same as for other arithmetic operators
2809 Analyze_Arithmetic_Op
(N
);
2812 ----------------------
2813 -- Analyze_Negation --
2814 ----------------------
2816 procedure Analyze_Negation
(N
: Node_Id
) is
2817 R
: constant Node_Id
:= Right_Opnd
(N
);
2818 Op_Id
: Entity_Id
:= Entity
(N
);
2821 Set_Etype
(N
, Any_Type
);
2822 Candidate_Type
:= Empty
;
2824 Analyze_Expression
(R
);
2826 if Present
(Op_Id
) then
2827 if Ekind
(Op_Id
) = E_Operator
then
2828 Find_Negation_Types
(R
, Op_Id
, N
);
2830 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2834 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2835 while Present
(Op_Id
) loop
2836 if Ekind
(Op_Id
) = E_Operator
then
2837 Find_Negation_Types
(R
, Op_Id
, N
);
2839 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
2842 Op_Id
:= Homonym
(Op_Id
);
2847 end Analyze_Negation
;
2853 procedure Analyze_Null
(N
: Node_Id
) is
2855 Check_SPARK_Restriction
("null is not allowed", N
);
2857 Set_Etype
(N
, Any_Access
);
2860 ----------------------
2861 -- Analyze_One_Call --
2862 ----------------------
2864 procedure Analyze_One_Call
2868 Success
: out Boolean;
2869 Skip_First
: Boolean := False)
2871 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2872 Prev_T
: constant Entity_Id
:= Etype
(N
);
2874 Must_Skip
: constant Boolean := Skip_First
2875 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
2877 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
2878 and then Nkind
(Prefix
(Original_Node
(N
)))
2879 = N_Selected_Component
);
2880 -- The first formal must be omitted from the match when trying to find
2881 -- a primitive operation that is a possible interpretation, and also
2882 -- after the call has been rewritten, because the corresponding actual
2883 -- is already known to be compatible, and because this may be an
2884 -- indexing of a call with default parameters.
2888 Is_Indexed
: Boolean := False;
2889 Is_Indirect
: Boolean := False;
2890 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
2893 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
2894 -- There may be a user-defined operator that hides the current
2895 -- interpretation. We must check for this independently of the
2896 -- analysis of the call with the user-defined operation, because
2897 -- the parameter names may be wrong and yet the hiding takes place.
2898 -- This fixes a problem with ACATS test B34014O.
2900 -- When the type Address is a visible integer type, and the DEC
2901 -- system extension is visible, the predefined operator may be
2902 -- hidden as well, by one of the address operations in auxdec.
2903 -- Finally, The abstract operations on address do not hide the
2904 -- predefined operator (this is the purpose of making them abstract).
2906 procedure Indicate_Name_And_Type
;
2907 -- If candidate interpretation matches, indicate name and type of
2908 -- result on call node.
2910 ----------------------------
2911 -- Indicate_Name_And_Type --
2912 ----------------------------
2914 procedure Indicate_Name_And_Type
is
2916 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
2917 Check_Implicit_Dereference
(N
, Etype
(Nam
));
2920 -- If the prefix of the call is a name, indicate the entity
2921 -- being called. If it is not a name, it is an expression that
2922 -- denotes an access to subprogram or else an entry or family. In
2923 -- the latter case, the name is a selected component, and the entity
2924 -- being called is noted on the selector.
2926 if not Is_Type
(Nam
) then
2927 if Is_Entity_Name
(Name
(N
)) then
2928 Set_Entity
(Name
(N
), Nam
);
2930 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
2931 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
2935 if Debug_Flag_E
and not Report
then
2936 Write_Str
(" Overloaded call ");
2937 Write_Int
(Int
(N
));
2938 Write_Str
(" compatible with ");
2939 Write_Int
(Int
(Nam
));
2942 end Indicate_Name_And_Type
;
2944 ------------------------
2945 -- Operator_Hidden_By --
2946 ------------------------
2948 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
2949 Act1
: constant Node_Id
:= First_Actual
(N
);
2950 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2951 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
2952 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
2955 if Ekind
(Fun
) /= E_Function
2956 or else Is_Abstract_Subprogram
(Fun
)
2960 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
2963 elsif Present
(Form2
) then
2965 No
(Act2
) or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
2970 elsif Present
(Act2
) then
2974 -- Now we know that the arity of the operator matches the function,
2975 -- and the function call is a valid interpretation. The function
2976 -- hides the operator if it has the right signature, or if one of
2977 -- its operands is a non-abstract operation on Address when this is
2978 -- a visible integer type.
2980 return Hides_Op
(Fun
, Nam
)
2981 or else Is_Descendent_Of_Address
(Etype
(Form1
))
2984 and then Is_Descendent_Of_Address
(Etype
(Form2
)));
2985 end Operator_Hidden_By
;
2987 -- Start of processing for Analyze_One_Call
2992 -- If the subprogram has no formals or if all the formals have defaults,
2993 -- and the return type is an array type, the node may denote an indexing
2994 -- of the result of a parameterless call. In Ada 2005, the subprogram
2995 -- may have one non-defaulted formal, and the call may have been written
2996 -- in prefix notation, so that the rebuilt parameter list has more than
2999 if not Is_Overloadable
(Nam
)
3000 and then Ekind
(Nam
) /= E_Subprogram_Type
3001 and then Ekind
(Nam
) /= E_Entry_Family
3006 -- An indexing requires at least one actual. The name of the call cannot
3007 -- be an implicit indirect call, so it cannot be a generated explicit
3010 if not Is_Empty_List
(Actuals
)
3012 (Needs_No_Actuals
(Nam
)
3014 (Needs_One_Actual
(Nam
)
3015 and then Present
(Next_Actual
(First
(Actuals
)))))
3017 if Is_Array_Type
(Subp_Type
)
3019 (Nkind
(Name
(N
)) /= N_Explicit_Dereference
3020 or else Comes_From_Source
(Name
(N
)))
3022 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
3024 elsif Is_Access_Type
(Subp_Type
)
3025 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
3029 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
3031 -- The prefix can also be a parameterless function that returns an
3032 -- access to subprogram, in which case this is an indirect call.
3033 -- If this succeeds, an explicit dereference is added later on,
3034 -- in Analyze_Call or Resolve_Call.
3036 elsif Is_Access_Type
(Subp_Type
)
3037 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
3039 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
3044 -- If the call has been transformed into a slice, it is of the form
3045 -- F (Subtype) where F is parameterless. The node has been rewritten in
3046 -- Try_Indexed_Call and there is nothing else to do.
3049 and then Nkind
(N
) = N_Slice
3055 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
3059 -- If an indirect call is a possible interpretation, indicate
3060 -- success to the caller. This may be an indexing of an explicit
3061 -- dereference of a call that returns an access type (see above).
3065 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
3066 and then Comes_From_Source
(Name
(N
)))
3071 -- Mismatch in number or names of parameters
3073 elsif Debug_Flag_E
then
3074 Write_Str
(" normalization fails in call ");
3075 Write_Int
(Int
(N
));
3076 Write_Str
(" with subprogram ");
3077 Write_Int
(Int
(Nam
));
3081 -- If the context expects a function call, discard any interpretation
3082 -- that is a procedure. If the node is not overloaded, leave as is for
3083 -- better error reporting when type mismatch is found.
3085 elsif Nkind
(N
) = N_Function_Call
3086 and then Is_Overloaded
(Name
(N
))
3087 and then Ekind
(Nam
) = E_Procedure
3091 -- Ditto for function calls in a procedure context
3093 elsif Nkind
(N
) = N_Procedure_Call_Statement
3094 and then Is_Overloaded
(Name
(N
))
3095 and then Etype
(Nam
) /= Standard_Void_Type
3099 elsif No
(Actuals
) then
3101 -- If Normalize succeeds, then there are default parameters for
3104 Indicate_Name_And_Type
;
3106 elsif Ekind
(Nam
) = E_Operator
then
3107 if Nkind
(N
) = N_Procedure_Call_Statement
then
3111 -- This can occur when the prefix of the call is an operator
3112 -- name or an expanded name whose selector is an operator name.
3114 Analyze_Operator_Call
(N
, Nam
);
3116 if Etype
(N
) /= Prev_T
then
3118 -- Check that operator is not hidden by a function interpretation
3120 if Is_Overloaded
(Name
(N
)) then
3126 Get_First_Interp
(Name
(N
), I
, It
);
3127 while Present
(It
.Nam
) loop
3128 if Operator_Hidden_By
(It
.Nam
) then
3129 Set_Etype
(N
, Prev_T
);
3133 Get_Next_Interp
(I
, It
);
3138 -- If operator matches formals, record its name on the call.
3139 -- If the operator is overloaded, Resolve will select the
3140 -- correct one from the list of interpretations. The call
3141 -- node itself carries the first candidate.
3143 Set_Entity
(Name
(N
), Nam
);
3146 elsif Report
and then Etype
(N
) = Any_Type
then
3147 Error_Msg_N
("incompatible arguments for operator", N
);
3151 -- Normalize_Actuals has chained the named associations in the
3152 -- correct order of the formals.
3154 Actual
:= First_Actual
(N
);
3155 Formal
:= First_Formal
(Nam
);
3157 -- If we are analyzing a call rewritten from object notation, skip
3158 -- first actual, which may be rewritten later as an explicit
3162 Next_Actual
(Actual
);
3163 Next_Formal
(Formal
);
3166 while Present
(Actual
) and then Present
(Formal
) loop
3167 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
3168 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
3170 -- The actual can be compatible with the formal, but we must
3171 -- also check that the context is not an address type that is
3172 -- visibly an integer type, as is the case in VMS_64. In this
3173 -- case the use of literals is illegal, except in the body of
3174 -- descendents of system, where arithmetic operations on
3175 -- address are of course used.
3177 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
3179 (Etype
(Actual
) /= Universal_Integer
3180 or else not Is_Descendent_Of_Address
(Etype
(Formal
))
3182 Is_Predefined_File_Name
3183 (Unit_File_Name
(Get_Source_Unit
(N
))))
3185 Next_Actual
(Actual
);
3186 Next_Formal
(Formal
);
3189 if Debug_Flag_E
then
3190 Write_Str
(" type checking fails in call ");
3191 Write_Int
(Int
(N
));
3192 Write_Str
(" with formal ");
3193 Write_Int
(Int
(Formal
));
3194 Write_Str
(" in subprogram ");
3195 Write_Int
(Int
(Nam
));
3199 if Report
and not Is_Indexed
and not Is_Indirect
then
3201 -- Ada 2005 (AI-251): Complete the error notification
3202 -- to help new Ada 2005 users.
3204 if Is_Class_Wide_Type
(Etype
(Formal
))
3205 and then Is_Interface
(Etype
(Etype
(Formal
)))
3206 and then not Interface_Present_In_Ancestor
3207 (Typ
=> Etype
(Actual
),
3208 Iface
=> Etype
(Etype
(Formal
)))
3211 ("(Ada 2005) does not implement interface }",
3212 Actual
, Etype
(Etype
(Formal
)));
3215 Wrong_Type
(Actual
, Etype
(Formal
));
3217 if Nkind
(Actual
) = N_Op_Eq
3218 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
3220 Formal
:= First_Formal
(Nam
);
3221 while Present
(Formal
) loop
3222 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
3223 Error_Msg_N
-- CODEFIX
3224 ("possible misspelling of `='>`!", Actual
);
3228 Next_Formal
(Formal
);
3232 if All_Errors_Mode
then
3233 Error_Msg_Sloc
:= Sloc
(Nam
);
3235 if Etype
(Formal
) = Any_Type
then
3237 ("there is no legal actual parameter", Actual
);
3240 if Is_Overloadable
(Nam
)
3241 and then Present
(Alias
(Nam
))
3242 and then not Comes_From_Source
(Nam
)
3245 ("\\ =='> in call to inherited operation & #!",
3248 elsif Ekind
(Nam
) = E_Subprogram_Type
then
3250 Access_To_Subprogram_Typ
:
3251 constant Entity_Id
:=
3253 (Associated_Node_For_Itype
(Nam
));
3256 "\\ =='> in call to dereference of &#!",
3257 Actual
, Access_To_Subprogram_Typ
);
3262 ("\\ =='> in call to &#!", Actual
, Nam
);
3272 -- Normalize_Actuals has verified that a default value exists
3273 -- for this formal. Current actual names a subsequent formal.
3275 Next_Formal
(Formal
);
3279 -- On exit, all actuals match
3281 Indicate_Name_And_Type
;
3283 end Analyze_One_Call
;
3285 ---------------------------
3286 -- Analyze_Operator_Call --
3287 ---------------------------
3289 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
3290 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
3291 Act1
: constant Node_Id
:= First_Actual
(N
);
3292 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
3295 -- Binary operator case
3297 if Present
(Act2
) then
3299 -- If more than two operands, then not binary operator after all
3301 if Present
(Next_Actual
(Act2
)) then
3305 -- Otherwise action depends on operator
3315 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
3320 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
3326 Find_Comparison_Types
(Act1
, Act2
, Op_Id
, N
);
3330 Find_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
3332 when Name_Op_Concat
=>
3333 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
3335 -- Is this when others, or should it be an abort???
3341 -- Unary operator case
3345 when Name_Op_Subtract |
3348 Find_Unary_Types
(Act1
, Op_Id
, N
);
3351 Find_Negation_Types
(Act1
, Op_Id
, N
);
3353 -- Is this when others correct, or should it be an abort???
3359 end Analyze_Operator_Call
;
3361 -------------------------------------------
3362 -- Analyze_Overloaded_Selected_Component --
3363 -------------------------------------------
3365 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
3366 Nam
: constant Node_Id
:= Prefix
(N
);
3367 Sel
: constant Node_Id
:= Selector_Name
(N
);
3374 Set_Etype
(Sel
, Any_Type
);
3376 Get_First_Interp
(Nam
, I
, It
);
3377 while Present
(It
.Typ
) loop
3378 if Is_Access_Type
(It
.Typ
) then
3379 T
:= Designated_Type
(It
.Typ
);
3380 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
3385 -- Locate the component. For a private prefix the selector can denote
3388 if Is_Record_Type
(T
) or else Is_Private_Type
(T
) then
3390 -- If the prefix is a class-wide type, the visible components are
3391 -- those of the base type.
3393 if Is_Class_Wide_Type
(T
) then
3397 Comp
:= First_Entity
(T
);
3398 while Present
(Comp
) loop
3399 if Chars
(Comp
) = Chars
(Sel
)
3400 and then Is_Visible_Component
(Comp
)
3403 -- AI05-105: if the context is an object renaming with
3404 -- an anonymous access type, the expected type of the
3405 -- object must be anonymous. This is a name resolution rule.
3407 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
3408 or else No
(Access_Definition
(Parent
(N
)))
3409 or else Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Type
3411 Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Subprogram_Type
3413 Set_Entity
(Sel
, Comp
);
3414 Set_Etype
(Sel
, Etype
(Comp
));
3415 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
3416 Check_Implicit_Dereference
(N
, Etype
(Comp
));
3418 -- This also specifies a candidate to resolve the name.
3419 -- Further overloading will be resolved from context.
3420 -- The selector name itself does not carry overloading
3423 Set_Etype
(Nam
, It
.Typ
);
3426 -- Named access type in the context of a renaming
3427 -- declaration with an access definition. Remove
3428 -- inapplicable candidate.
3437 elsif Is_Concurrent_Type
(T
) then
3438 Comp
:= First_Entity
(T
);
3439 while Present
(Comp
)
3440 and then Comp
/= First_Private_Entity
(T
)
3442 if Chars
(Comp
) = Chars
(Sel
) then
3443 if Is_Overloadable
(Comp
) then
3444 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3446 Set_Entity_With_Style_Check
(Sel
, Comp
);
3447 Generate_Reference
(Comp
, Sel
);
3450 Set_Etype
(Sel
, Etype
(Comp
));
3451 Set_Etype
(N
, Etype
(Comp
));
3452 Set_Etype
(Nam
, It
.Typ
);
3454 -- For access type case, introduce explicit dereference for
3455 -- more uniform treatment of entry calls. Do this only once
3456 -- if several interpretations yield an access type.
3458 if Is_Access_Type
(Etype
(Nam
))
3459 and then Nkind
(Nam
) /= N_Explicit_Dereference
3461 Insert_Explicit_Dereference
(Nam
);
3463 (Warn_On_Dereference
, "?d?implicit dereference", N
);
3470 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3473 Get_Next_Interp
(I
, It
);
3476 if Etype
(N
) = Any_Type
3477 and then not Try_Object_Operation
(N
)
3479 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
3480 Set_Entity
(Sel
, Any_Id
);
3481 Set_Etype
(Sel
, Any_Type
);
3483 end Analyze_Overloaded_Selected_Component
;
3485 ----------------------------------
3486 -- Analyze_Qualified_Expression --
3487 ----------------------------------
3489 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
3490 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
3491 Expr
: constant Node_Id
:= Expression
(N
);
3497 Analyze_Expression
(Expr
);
3499 Set_Etype
(N
, Any_Type
);
3504 if T
= Any_Type
then
3508 Check_Fully_Declared
(T
, N
);
3510 -- If expected type is class-wide, check for exact match before
3511 -- expansion, because if the expression is a dispatching call it
3512 -- may be rewritten as explicit dereference with class-wide result.
3513 -- If expression is overloaded, retain only interpretations that
3514 -- will yield exact matches.
3516 if Is_Class_Wide_Type
(T
) then
3517 if not Is_Overloaded
(Expr
) then
3518 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
) then
3519 if Nkind
(Expr
) = N_Aggregate
then
3520 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
3522 Wrong_Type
(Expr
, T
);
3527 Get_First_Interp
(Expr
, I
, It
);
3529 while Present
(It
.Nam
) loop
3530 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
3534 Get_Next_Interp
(I
, It
);
3540 end Analyze_Qualified_Expression
;
3542 -----------------------------------
3543 -- Analyze_Quantified_Expression --
3544 -----------------------------------
3546 procedure Analyze_Quantified_Expression
(N
: Node_Id
) is
3547 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean;
3548 -- If the iterator is part of a quantified expression, and the range is
3549 -- known to be statically empty, emit a warning and replace expression
3550 -- with its static value. Returns True if the replacement occurs.
3552 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean;
3553 -- Determine whether if expression If_Expr lacks an else part or if it
3554 -- has one, it evaluates to True.
3556 --------------------
3557 -- Is_Empty_Range --
3558 --------------------
3560 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean is
3561 Loc
: constant Source_Ptr
:= Sloc
(N
);
3564 if Is_Array_Type
(Typ
)
3565 and then Compile_Time_Known_Bounds
(Typ
)
3567 (Expr_Value
(Type_Low_Bound
(Etype
(First_Index
(Typ
)))) >
3568 Expr_Value
(Type_High_Bound
(Etype
(First_Index
(Typ
)))))
3570 Preanalyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
3572 if All_Present
(N
) then
3574 ("??quantified expression with ALL "
3575 & "over a null range has value True", N
);
3576 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3580 ("??quantified expression with SOME "
3581 & "over a null range has value False", N
);
3582 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
3593 -----------------------------
3594 -- No_Else_Or_Trivial_True --
3595 -----------------------------
3597 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean is
3598 Else_Expr
: constant Node_Id
:=
3599 Next
(Next
(First
(Expressions
(If_Expr
))));
3603 or else (Compile_Time_Known_Value
(Else_Expr
)
3604 and then Is_True
(Expr_Value
(Else_Expr
)));
3605 end No_Else_Or_Trivial_True
;
3609 Cond
: constant Node_Id
:= Condition
(N
);
3610 Loop_Id
: Entity_Id
;
3611 QE_Scop
: Entity_Id
;
3613 -- Start of processing for Analyze_Quantified_Expression
3616 Check_SPARK_Restriction
("quantified expression is not allowed", N
);
3618 -- Create a scope to emulate the loop-like behavior of the quantified
3619 -- expression. The scope is needed to provide proper visibility of the
3622 QE_Scop
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Sloc
(N
), 'L');
3623 Set_Etype
(QE_Scop
, Standard_Void_Type
);
3624 Set_Scope
(QE_Scop
, Current_Scope
);
3625 Set_Parent
(QE_Scop
, N
);
3627 Push_Scope
(QE_Scop
);
3629 -- All constituents are preanalyzed and resolved to avoid untimely
3630 -- generation of various temporaries and types. Full analysis and
3631 -- expansion is carried out when the quantified expression is
3632 -- transformed into an expression with actions.
3634 if Present
(Iterator_Specification
(N
)) then
3635 Preanalyze
(Iterator_Specification
(N
));
3637 -- Do not proceed with the analysis when the range of iteration is
3638 -- empty. The appropriate error is issued by Is_Empty_Range.
3640 if Is_Entity_Name
(Name
(Iterator_Specification
(N
)))
3641 and then Is_Empty_Range
(Etype
(Name
(Iterator_Specification
(N
))))
3646 else pragma Assert
(Present
(Loop_Parameter_Specification
(N
)));
3647 Preanalyze
(Loop_Parameter_Specification
(N
));
3650 Preanalyze_And_Resolve
(Cond
, Standard_Boolean
);
3653 Set_Etype
(N
, Standard_Boolean
);
3655 -- Verify that the loop variable is used within the condition of the
3656 -- quantified expression.
3658 if Present
(Iterator_Specification
(N
)) then
3659 Loop_Id
:= Defining_Identifier
(Iterator_Specification
(N
));
3661 Loop_Id
:= Defining_Identifier
(Loop_Parameter_Specification
(N
));
3664 if Warn_On_Suspicious_Contract
3665 and then not Referenced
(Loop_Id
, Cond
)
3667 Error_Msg_N
("?T?unused variable &", Loop_Id
);
3670 -- Diagnose a possible misuse of the "some" existential quantifier. When
3671 -- we have a quantified expression of the form:
3673 -- for some X => (if P then Q [else True])
3675 -- the if expression will not hold and render the quantified expression
3678 if Formal_Extensions
3679 and then not All_Present
(N
)
3680 and then Nkind
(Cond
) = N_If_Expression
3681 and then No_Else_Or_Trivial_True
(Cond
)
3683 Error_Msg_N
("?suspicious expression", N
);
3684 Error_Msg_N
("\\did you mean (for all X ='> (if P then Q))", N
);
3685 Error_Msg_N
("\\or (for some X ='> P and then Q) instead'?", N
);
3687 end Analyze_Quantified_Expression
;
3693 procedure Analyze_Range
(N
: Node_Id
) is
3694 L
: constant Node_Id
:= Low_Bound
(N
);
3695 H
: constant Node_Id
:= High_Bound
(N
);
3696 I1
, I2
: Interp_Index
;
3699 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
3700 -- Verify the compatibility of two types, and choose the
3701 -- non universal one if the other is universal.
3703 procedure Check_High_Bound
(T
: Entity_Id
);
3704 -- Test one interpretation of the low bound against all those
3705 -- of the high bound.
3707 procedure Check_Universal_Expression
(N
: Node_Id
);
3708 -- In Ada 83, reject bounds of a universal range that are not literals
3711 -----------------------
3712 -- Check_Common_Type --
3713 -----------------------
3715 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
3717 if Covers
(T1
=> T1
, T2
=> T2
)
3719 Covers
(T1
=> T2
, T2
=> T1
)
3721 if T1
= Universal_Integer
3722 or else T1
= Universal_Real
3723 or else T1
= Any_Character
3725 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
3728 Add_One_Interp
(N
, T1
, T1
);
3731 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
3734 end Check_Common_Type
;
3736 ----------------------
3737 -- Check_High_Bound --
3738 ----------------------
3740 procedure Check_High_Bound
(T
: Entity_Id
) is
3742 if not Is_Overloaded
(H
) then
3743 Check_Common_Type
(T
, Etype
(H
));
3745 Get_First_Interp
(H
, I2
, It2
);
3746 while Present
(It2
.Typ
) loop
3747 Check_Common_Type
(T
, It2
.Typ
);
3748 Get_Next_Interp
(I2
, It2
);
3751 end Check_High_Bound
;
3753 -----------------------------
3754 -- Is_Universal_Expression --
3755 -----------------------------
3757 procedure Check_Universal_Expression
(N
: Node_Id
) is
3759 if Etype
(N
) = Universal_Integer
3760 and then Nkind
(N
) /= N_Integer_Literal
3761 and then not Is_Entity_Name
(N
)
3762 and then Nkind
(N
) /= N_Attribute_Reference
3764 Error_Msg_N
("illegal bound in discrete range", N
);
3766 end Check_Universal_Expression
;
3768 -- Start of processing for Analyze_Range
3771 Set_Etype
(N
, Any_Type
);
3772 Analyze_Expression
(L
);
3773 Analyze_Expression
(H
);
3775 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
3779 if not Is_Overloaded
(L
) then
3780 Check_High_Bound
(Etype
(L
));
3782 Get_First_Interp
(L
, I1
, It1
);
3783 while Present
(It1
.Typ
) loop
3784 Check_High_Bound
(It1
.Typ
);
3785 Get_Next_Interp
(I1
, It1
);
3789 -- If result is Any_Type, then we did not find a compatible pair
3791 if Etype
(N
) = Any_Type
then
3792 Error_Msg_N
("incompatible types in range ", N
);
3796 if Ada_Version
= Ada_83
3798 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
3799 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
3801 Check_Universal_Expression
(L
);
3802 Check_Universal_Expression
(H
);
3805 Check_Function_Writable_Actuals
(N
);
3808 -----------------------
3809 -- Analyze_Reference --
3810 -----------------------
3812 procedure Analyze_Reference
(N
: Node_Id
) is
3813 P
: constant Node_Id
:= Prefix
(N
);
3816 Acc_Type
: Entity_Id
;
3821 -- An interesting error check, if we take the 'Reference of an object
3822 -- for which a pragma Atomic or Volatile has been given, and the type
3823 -- of the object is not Atomic or Volatile, then we are in trouble. The
3824 -- problem is that no trace of the atomic/volatile status will remain
3825 -- for the backend to respect when it deals with the resulting pointer,
3826 -- since the pointer type will not be marked atomic (it is a pointer to
3827 -- the base type of the object).
3829 -- It is not clear if that can ever occur, but in case it does, we will
3830 -- generate an error message. Not clear if this message can ever be
3831 -- generated, and pretty clear that it represents a bug if it is, still
3832 -- seems worth checking, except in CodePeer mode where we do not really
3833 -- care and don't want to bother the user.
3837 if Is_Entity_Name
(P
)
3838 and then Is_Object_Reference
(P
)
3839 and then not CodePeer_Mode
3844 if (Has_Atomic_Components
(E
)
3845 and then not Has_Atomic_Components
(T
))
3847 (Has_Volatile_Components
(E
)
3848 and then not Has_Volatile_Components
(T
))
3849 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
3850 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
3852 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
3856 -- Carry on with normal processing
3858 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
3859 Set_Etype
(Acc_Type
, Acc_Type
);
3860 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
3861 Set_Etype
(N
, Acc_Type
);
3862 end Analyze_Reference
;
3864 --------------------------------
3865 -- Analyze_Selected_Component --
3866 --------------------------------
3868 -- Prefix is a record type or a task or protected type. In the latter case,
3869 -- the selector must denote a visible entry.
3871 procedure Analyze_Selected_Component
(N
: Node_Id
) is
3872 Name
: constant Node_Id
:= Prefix
(N
);
3873 Sel
: constant Node_Id
:= Selector_Name
(N
);
3876 Has_Candidate
: Boolean := False;
3879 Pent
: Entity_Id
:= Empty
;
3880 Prefix_Type
: Entity_Id
;
3882 Type_To_Use
: Entity_Id
;
3883 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
3884 -- a class-wide type, we use its root type, whose components are
3885 -- present in the class-wide type.
3887 Is_Single_Concurrent_Object
: Boolean;
3888 -- Set True if the prefix is a single task or a single protected object
3890 procedure Find_Component_In_Instance
(Rec
: Entity_Id
);
3891 -- In an instance, a component of a private extension may not be visible
3892 -- while it was visible in the generic. Search candidate scope for a
3893 -- component with the proper identifier. This is only done if all other
3894 -- searches have failed. When the match is found (it always will be),
3895 -- the Etype of both N and Sel are set from this component, and the
3896 -- entity of Sel is set to reference this component.
3898 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
3899 -- It is known that the parent of N denotes a subprogram call. Comp
3900 -- is an overloadable component of the concurrent type of the prefix.
3901 -- Determine whether all formals of the parent of N and Comp are mode
3902 -- conformant. If the parent node is not analyzed yet it may be an
3903 -- indexed component rather than a function call.
3905 --------------------------------
3906 -- Find_Component_In_Instance --
3907 --------------------------------
3909 procedure Find_Component_In_Instance
(Rec
: Entity_Id
) is
3913 Comp
:= First_Component
(Rec
);
3914 while Present
(Comp
) loop
3915 if Chars
(Comp
) = Chars
(Sel
) then
3916 Set_Entity_With_Style_Check
(Sel
, Comp
);
3917 Set_Etype
(Sel
, Etype
(Comp
));
3918 Set_Etype
(N
, Etype
(Comp
));
3922 Next_Component
(Comp
);
3925 -- This must succeed because code was legal in the generic
3927 raise Program_Error
;
3928 end Find_Component_In_Instance
;
3930 ------------------------------
3931 -- Has_Mode_Conformant_Spec --
3932 ------------------------------
3934 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
3935 Comp_Param
: Entity_Id
;
3937 Param_Typ
: Entity_Id
;
3940 Comp_Param
:= First_Formal
(Comp
);
3942 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
3943 Param
:= First
(Expressions
(Parent
(N
)));
3945 Param
:= First
(Parameter_Associations
(Parent
(N
)));
3948 while Present
(Comp_Param
)
3949 and then Present
(Param
)
3951 Param_Typ
:= Find_Parameter_Type
(Param
);
3953 if Present
(Param_Typ
)
3955 not Conforming_Types
3956 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
3961 Next_Formal
(Comp_Param
);
3965 -- One of the specs has additional formals
3967 if Present
(Comp_Param
) or else Present
(Param
) then
3972 end Has_Mode_Conformant_Spec
;
3974 -- Start of processing for Analyze_Selected_Component
3977 Set_Etype
(N
, Any_Type
);
3979 if Is_Overloaded
(Name
) then
3980 Analyze_Overloaded_Selected_Component
(N
);
3983 elsif Etype
(Name
) = Any_Type
then
3984 Set_Entity
(Sel
, Any_Id
);
3985 Set_Etype
(Sel
, Any_Type
);
3989 Prefix_Type
:= Etype
(Name
);
3992 if Is_Access_Type
(Prefix_Type
) then
3994 -- A RACW object can never be used as prefix of a selected component
3995 -- since that means it is dereferenced without being a controlling
3996 -- operand of a dispatching operation (RM E.2.2(16/1)). Before
3997 -- reporting an error, we must check whether this is actually a
3998 -- dispatching call in prefix form.
4000 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
4001 and then Comes_From_Source
(N
)
4003 if Try_Object_Operation
(N
) then
4007 ("invalid dereference of a remote access-to-class-wide value",
4011 -- Normal case of selected component applied to access type
4014 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4016 if Is_Entity_Name
(Name
) then
4017 Pent
:= Entity
(Name
);
4018 elsif Nkind
(Name
) = N_Selected_Component
4019 and then Is_Entity_Name
(Selector_Name
(Name
))
4021 Pent
:= Entity
(Selector_Name
(Name
));
4024 Prefix_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, Name
);
4027 -- If we have an explicit dereference of a remote access-to-class-wide
4028 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
4029 -- have to check for the case of a prefix that is a controlling operand
4030 -- of a prefixed dispatching call, as the dereference is legal in that
4031 -- case. Normally this condition is checked in Validate_Remote_Access_
4032 -- To_Class_Wide_Type, but we have to defer the checking for selected
4033 -- component prefixes because of the prefixed dispatching call case.
4034 -- Note that implicit dereferences are checked for this just above.
4036 elsif Nkind
(Name
) = N_Explicit_Dereference
4037 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Name
)))
4038 and then Comes_From_Source
(N
)
4040 if Try_Object_Operation
(N
) then
4044 ("invalid dereference of a remote access-to-class-wide value",
4049 -- (Ada 2005): if the prefix is the limited view of a type, and
4050 -- the context already includes the full view, use the full view
4051 -- in what follows, either to retrieve a component of to find
4052 -- a primitive operation. If the prefix is an explicit dereference,
4053 -- set the type of the prefix to reflect this transformation.
4054 -- If the non-limited view is itself an incomplete type, get the
4055 -- full view if available.
4057 if Is_Incomplete_Type
(Prefix_Type
)
4058 and then From_With_Type
(Prefix_Type
)
4059 and then Present
(Non_Limited_View
(Prefix_Type
))
4061 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
4063 if Nkind
(N
) = N_Explicit_Dereference
then
4064 Set_Etype
(Prefix
(N
), Prefix_Type
);
4067 elsif Ekind
(Prefix_Type
) = E_Class_Wide_Type
4068 and then From_With_Type
(Prefix_Type
)
4069 and then Present
(Non_Limited_View
(Etype
(Prefix_Type
)))
4072 Class_Wide_Type
(Non_Limited_View
(Etype
(Prefix_Type
)));
4074 if Nkind
(N
) = N_Explicit_Dereference
then
4075 Set_Etype
(Prefix
(N
), Prefix_Type
);
4079 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
4080 Prefix_Type
:= Base_Type
(Prefix_Type
);
4083 Type_To_Use
:= Prefix_Type
;
4085 -- For class-wide types, use the entity list of the root type. This
4086 -- indirection is specially important for private extensions because
4087 -- only the root type get switched (not the class-wide type).
4089 if Is_Class_Wide_Type
(Prefix_Type
) then
4090 Type_To_Use
:= Root_Type
(Prefix_Type
);
4093 -- If the prefix is a single concurrent object, use its name in error
4094 -- messages, rather than that of its anonymous type.
4096 Is_Single_Concurrent_Object
:=
4097 Is_Concurrent_Type
(Prefix_Type
)
4098 and then Is_Internal_Name
(Chars
(Prefix_Type
))
4099 and then not Is_Derived_Type
(Prefix_Type
)
4100 and then Is_Entity_Name
(Name
);
4102 Comp
:= First_Entity
(Type_To_Use
);
4104 -- If the selector has an original discriminant, the node appears in
4105 -- an instance. Replace the discriminant with the corresponding one
4106 -- in the current discriminated type. For nested generics, this must
4107 -- be done transitively, so note the new original discriminant.
4109 if Nkind
(Sel
) = N_Identifier
4110 and then In_Instance
4111 and then Present
(Original_Discriminant
(Sel
))
4113 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
4115 -- Mark entity before rewriting, for completeness and because
4116 -- subsequent semantic checks might examine the original node.
4118 Set_Entity
(Sel
, Comp
);
4119 Rewrite
(Selector_Name
(N
), New_Occurrence_Of
(Comp
, Sloc
(N
)));
4120 Set_Original_Discriminant
(Selector_Name
(N
), Comp
);
4121 Set_Etype
(N
, Etype
(Comp
));
4122 Check_Implicit_Dereference
(N
, Etype
(Comp
));
4124 if Is_Access_Type
(Etype
(Name
)) then
4125 Insert_Explicit_Dereference
(Name
);
4126 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4129 elsif Is_Record_Type
(Prefix_Type
) then
4131 -- Find component with given name. In an instance, if the node is
4132 -- known as a prefixed call, do not examine components whose
4133 -- visibility may be accidental.
4135 while Present
(Comp
) and then not Is_Prefixed_Call
(N
) loop
4136 if Chars
(Comp
) = Chars
(Sel
)
4137 and then Is_Visible_Component
(Comp
, N
)
4139 Set_Entity_With_Style_Check
(Sel
, Comp
);
4140 Set_Etype
(Sel
, Etype
(Comp
));
4142 if Ekind
(Comp
) = E_Discriminant
then
4143 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
4145 ("cannot reference discriminant of unchecked union",
4149 if Is_Generic_Type
(Prefix_Type
)
4151 Is_Generic_Type
(Root_Type
(Prefix_Type
))
4153 Set_Original_Discriminant
(Sel
, Comp
);
4157 -- Resolve the prefix early otherwise it is not possible to
4158 -- build the actual subtype of the component: it may need
4159 -- to duplicate this prefix and duplication is only allowed
4160 -- on fully resolved expressions.
4164 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
4165 -- subtypes in a package specification.
4168 -- limited with Pkg;
4170 -- type Acc_Inc is access Pkg.T;
4172 -- N : Natural := X.all.Comp; -- ERROR, limited view
4173 -- end Pkg; -- Comp is not visible
4175 if Nkind
(Name
) = N_Explicit_Dereference
4176 and then From_With_Type
(Etype
(Prefix
(Name
)))
4177 and then not Is_Potentially_Use_Visible
(Etype
(Name
))
4178 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
4179 N_Package_Specification
4182 ("premature usage of incomplete}", Prefix
(Name
),
4183 Etype
(Prefix
(Name
)));
4186 -- We never need an actual subtype for the case of a selection
4187 -- for a indexed component of a non-packed array, since in
4188 -- this case gigi generates all the checks and can find the
4189 -- necessary bounds information.
4191 -- We also do not need an actual subtype for the case of a
4192 -- first, last, length, or range attribute applied to a
4193 -- non-packed array, since gigi can again get the bounds in
4194 -- these cases (gigi cannot handle the packed case, since it
4195 -- has the bounds of the packed array type, not the original
4196 -- bounds of the type). However, if the prefix is itself a
4197 -- selected component, as in a.b.c (i), gigi may regard a.b.c
4198 -- as a dynamic-sized temporary, so we do generate an actual
4199 -- subtype for this case.
4201 Parent_N
:= Parent
(N
);
4203 if not Is_Packed
(Etype
(Comp
))
4205 ((Nkind
(Parent_N
) = N_Indexed_Component
4206 and then Nkind
(Name
) /= N_Selected_Component
)
4208 (Nkind
(Parent_N
) = N_Attribute_Reference
4210 Nam_In
(Attribute_Name
(Parent_N
), Name_First
,
4215 Set_Etype
(N
, Etype
(Comp
));
4217 -- If full analysis is not enabled, we do not generate an
4218 -- actual subtype, because in the absence of expansion
4219 -- reference to a formal of a protected type, for example,
4220 -- will not be properly transformed, and will lead to
4221 -- out-of-scope references in gigi.
4223 -- In all other cases, we currently build an actual subtype.
4224 -- It seems likely that many of these cases can be avoided,
4225 -- but right now, the front end makes direct references to the
4226 -- bounds (e.g. in generating a length check), and if we do
4227 -- not make an actual subtype, we end up getting a direct
4228 -- reference to a discriminant, which will not do.
4230 elsif Full_Analysis
then
4232 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
4233 Insert_Action
(N
, Act_Decl
);
4235 if No
(Act_Decl
) then
4236 Set_Etype
(N
, Etype
(Comp
));
4239 -- Component type depends on discriminants. Enter the
4240 -- main attributes of the subtype.
4243 Subt
: constant Entity_Id
:=
4244 Defining_Identifier
(Act_Decl
);
4247 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
4248 Set_Ekind
(Subt
, Ekind
(Etype
(Comp
)));
4249 Set_Etype
(N
, Subt
);
4253 -- If Full_Analysis not enabled, just set the Etype
4256 Set_Etype
(N
, Etype
(Comp
));
4259 Check_Implicit_Dereference
(N
, Etype
(N
));
4263 -- If the prefix is a private extension, check only the visible
4264 -- components of the partial view. This must include the tag,
4265 -- which can appear in expanded code in a tag check.
4267 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
4268 and then Chars
(Selector_Name
(N
)) /= Name_uTag
4270 exit when Comp
= Last_Entity
(Type_To_Use
);
4276 -- Ada 2005 (AI-252): The selected component can be interpreted as
4277 -- a prefixed view of a subprogram. Depending on the context, this is
4278 -- either a name that can appear in a renaming declaration, or part
4279 -- of an enclosing call given in prefix form.
4281 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
4282 -- selected component should resolve to a name.
4284 if Ada_Version
>= Ada_2005
4285 and then Is_Tagged_Type
(Prefix_Type
)
4286 and then not Is_Concurrent_Type
(Prefix_Type
)
4288 if Nkind
(Parent
(N
)) = N_Generic_Association
4289 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
4290 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
4292 if Find_Primitive_Operation
(N
) then
4296 elsif Try_Object_Operation
(N
) then
4300 -- If the transformation fails, it will be necessary to redo the
4301 -- analysis with all errors enabled, to indicate candidate
4302 -- interpretations and reasons for each failure ???
4306 elsif Is_Private_Type
(Prefix_Type
) then
4308 -- Allow access only to discriminants of the type. If the type has
4309 -- no full view, gigi uses the parent type for the components, so we
4310 -- do the same here.
4312 if No
(Full_View
(Prefix_Type
)) then
4313 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
4314 Comp
:= First_Entity
(Type_To_Use
);
4317 while Present
(Comp
) loop
4318 if Chars
(Comp
) = Chars
(Sel
) then
4319 if Ekind
(Comp
) = E_Discriminant
then
4320 Set_Entity_With_Style_Check
(Sel
, Comp
);
4321 Generate_Reference
(Comp
, Sel
);
4323 Set_Etype
(Sel
, Etype
(Comp
));
4324 Set_Etype
(N
, Etype
(Comp
));
4325 Check_Implicit_Dereference
(N
, Etype
(N
));
4327 if Is_Generic_Type
(Prefix_Type
)
4328 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
4330 Set_Original_Discriminant
(Sel
, Comp
);
4333 -- Before declaring an error, check whether this is tagged
4334 -- private type and a call to a primitive operation.
4336 elsif Ada_Version
>= Ada_2005
4337 and then Is_Tagged_Type
(Prefix_Type
)
4338 and then Try_Object_Operation
(N
)
4343 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4344 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
4345 Set_Entity
(Sel
, Any_Id
);
4346 Set_Etype
(N
, Any_Type
);
4355 elsif Is_Concurrent_Type
(Prefix_Type
) then
4357 -- Find visible operation with given name. For a protected type,
4358 -- the possible candidates are discriminants, entries or protected
4359 -- procedures. For a task type, the set can only include entries or
4360 -- discriminants if the task type is not an enclosing scope. If it
4361 -- is an enclosing scope (e.g. in an inner task) then all entities
4362 -- are visible, but the prefix must denote the enclosing scope, i.e.
4363 -- can only be a direct name or an expanded name.
4365 Set_Etype
(Sel
, Any_Type
);
4366 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
4368 while Present
(Comp
) loop
4369 if Chars
(Comp
) = Chars
(Sel
) then
4370 if Is_Overloadable
(Comp
) then
4371 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
4373 -- If the prefix is tagged, the correct interpretation may
4374 -- lie in the primitive or class-wide operations of the
4375 -- type. Perform a simple conformance check to determine
4376 -- whether Try_Object_Operation should be invoked even if
4377 -- a visible entity is found.
4379 if Is_Tagged_Type
(Prefix_Type
)
4381 Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
4383 N_Indexed_Component
)
4384 and then Has_Mode_Conformant_Spec
(Comp
)
4386 Has_Candidate
:= True;
4389 -- Note: a selected component may not denote a component of a
4390 -- protected type (4.1.3(7)).
4392 elsif Ekind_In
(Comp
, E_Discriminant
, E_Entry_Family
)
4394 and then not Is_Protected_Type
(Prefix_Type
)
4395 and then Is_Entity_Name
(Name
))
4397 Set_Entity_With_Style_Check
(Sel
, Comp
);
4398 Generate_Reference
(Comp
, Sel
);
4400 -- The selector is not overloadable, so we have a candidate
4403 Has_Candidate
:= True;
4409 Set_Etype
(Sel
, Etype
(Comp
));
4410 Set_Etype
(N
, Etype
(Comp
));
4412 if Ekind
(Comp
) = E_Discriminant
then
4413 Set_Original_Discriminant
(Sel
, Comp
);
4416 -- For access type case, introduce explicit dereference for
4417 -- more uniform treatment of entry calls.
4419 if Is_Access_Type
(Etype
(Name
)) then
4420 Insert_Explicit_Dereference
(Name
);
4422 (Warn_On_Dereference
, "?d?implicit dereference", N
);
4428 exit when not In_Scope
4430 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
4433 -- If there is no visible entity with the given name or none of the
4434 -- visible entities are plausible interpretations, check whether
4435 -- there is some other primitive operation with that name.
4437 if Ada_Version
>= Ada_2005
4438 and then Is_Tagged_Type
(Prefix_Type
)
4440 if (Etype
(N
) = Any_Type
4441 or else not Has_Candidate
)
4442 and then Try_Object_Operation
(N
)
4446 -- If the context is not syntactically a procedure call, it
4447 -- may be a call to a primitive function declared outside of
4448 -- the synchronized type.
4450 -- If the context is a procedure call, there might still be
4451 -- an overloading between an entry and a primitive procedure
4452 -- declared outside of the synchronized type, called in prefix
4453 -- notation. This is harder to disambiguate because in one case
4454 -- the controlling formal is implicit ???
4456 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
4457 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
4458 and then Try_Object_Operation
(N
)
4463 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
4464 -- entry or procedure of a tagged concurrent type we must check
4465 -- if there are class-wide subprograms covering the primitive. If
4466 -- true then Try_Object_Operation reports the error.
4469 and then Is_Concurrent_Type
(Prefix_Type
)
4470 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
4472 -- Duplicate the call. This is required to avoid problems with
4473 -- the tree transformations performed by Try_Object_Operation.
4474 -- Set properly the parent of the copied call, because it is
4475 -- about to be reanalyzed.
4479 Par
: constant Node_Id
:= New_Copy_Tree
(Parent
(N
));
4482 Set_Parent
(Par
, Parent
(Parent
(N
)));
4484 if Try_Object_Operation
4485 (Sinfo
.Name
(Par
), CW_Test_Only
=> True)
4493 if Etype
(N
) = Any_Type
and then Is_Protected_Type
(Prefix_Type
) then
4495 -- Case of a prefix of a protected type: selector might denote
4496 -- an invisible private component.
4498 Comp
:= First_Private_Entity
(Base_Type
(Prefix_Type
));
4499 while Present
(Comp
) and then Chars
(Comp
) /= Chars
(Sel
) loop
4503 if Present
(Comp
) then
4504 if Is_Single_Concurrent_Object
then
4505 Error_Msg_Node_2
:= Entity
(Name
);
4506 Error_Msg_NE
("invisible selector& for &", N
, Sel
);
4509 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4510 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
4516 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
4521 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
4524 -- If N still has no type, the component is not defined in the prefix
4526 if Etype
(N
) = Any_Type
then
4528 if Is_Single_Concurrent_Object
then
4529 Error_Msg_Node_2
:= Entity
(Name
);
4530 Error_Msg_NE
("no selector& for&", N
, Sel
);
4532 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
4534 elsif Is_Generic_Type
(Prefix_Type
)
4535 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
4536 and then Prefix_Type
/= Etype
(Prefix_Type
)
4537 and then Is_Record_Type
(Etype
(Prefix_Type
))
4539 -- If this is a derived formal type, the parent may have
4540 -- different visibility at this point. Try for an inherited
4541 -- component before reporting an error.
4543 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
4544 Analyze_Selected_Component
(N
);
4547 -- Similarly, if this is the actual for a formal derived type, the
4548 -- component inherited from the generic parent may not be visible
4549 -- in the actual, but the selected component is legal.
4551 elsif Ekind
(Prefix_Type
) = E_Record_Subtype_With_Private
4552 and then Is_Generic_Actual_Type
(Prefix_Type
)
4553 and then Present
(Full_View
(Prefix_Type
))
4556 Find_Component_In_Instance
4557 (Generic_Parent_Type
(Parent
(Prefix_Type
)));
4560 -- Finally, the formal and the actual may be private extensions,
4561 -- but the generic is declared in a child unit of the parent, and
4562 -- an additional step is needed to retrieve the proper scope.
4565 and then Present
(Parent_Subtype
(Etype
(Base_Type
(Prefix_Type
))))
4567 Find_Component_In_Instance
4568 (Parent_Subtype
(Etype
(Base_Type
(Prefix_Type
))));
4571 -- Component not found, specialize error message when appropriate
4574 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
4576 -- Check whether this is a component of the base type which
4577 -- is absent from a statically constrained subtype. This will
4578 -- raise constraint error at run time, but is not a compile-
4579 -- time error. When the selector is illegal for base type as
4580 -- well fall through and generate a compilation error anyway.
4582 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
4583 while Present
(Comp
) loop
4584 if Chars
(Comp
) = Chars
(Sel
)
4585 and then Is_Visible_Component
(Comp
)
4587 Set_Entity_With_Style_Check
(Sel
, Comp
);
4588 Generate_Reference
(Comp
, Sel
);
4589 Set_Etype
(Sel
, Etype
(Comp
));
4590 Set_Etype
(N
, Etype
(Comp
));
4592 -- Emit appropriate message. Gigi will replace the
4593 -- node subsequently with the appropriate Raise.
4595 -- In SPARK mode, this is made into an error to simplify
4596 -- the processing of the formal verification backend.
4599 Apply_Compile_Time_Constraint_Error
4600 (N
, "component not present in }",
4601 CE_Discriminant_Check_Failed
,
4602 Ent
=> Prefix_Type
, Rep
=> False);
4604 Apply_Compile_Time_Constraint_Error
4605 (N
, "component not present in }??",
4606 CE_Discriminant_Check_Failed
,
4607 Ent
=> Prefix_Type
, Rep
=> False);
4610 Set_Raises_Constraint_Error
(N
);
4614 Next_Component
(Comp
);
4619 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4620 Error_Msg_NE
("no selector& for}", N
, Sel
);
4622 -- Add information in the case of an incomplete prefix
4624 if Is_Incomplete_Type
(Type_To_Use
) then
4626 Inc
: constant Entity_Id
:= First_Subtype
(Type_To_Use
);
4629 if From_With_Type
(Scope
(Type_To_Use
)) then
4631 ("\limited view of& has no components", N
, Inc
);
4635 ("\premature usage of incomplete type&", N
, Inc
);
4637 if Nkind
(Parent
(Inc
)) =
4638 N_Incomplete_Type_Declaration
4640 -- Record location of premature use in entity so that
4641 -- a continuation message is generated when the
4642 -- completion is seen.
4644 Set_Premature_Use
(Parent
(Inc
), N
);
4650 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
4653 Set_Entity
(Sel
, Any_Id
);
4654 Set_Etype
(Sel
, Any_Type
);
4656 end Analyze_Selected_Component
;
4658 ---------------------------
4659 -- Analyze_Short_Circuit --
4660 ---------------------------
4662 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
4663 L
: constant Node_Id
:= Left_Opnd
(N
);
4664 R
: constant Node_Id
:= Right_Opnd
(N
);
4669 Analyze_Expression
(L
);
4670 Analyze_Expression
(R
);
4671 Set_Etype
(N
, Any_Type
);
4673 if not Is_Overloaded
(L
) then
4674 if Root_Type
(Etype
(L
)) = Standard_Boolean
4675 and then Has_Compatible_Type
(R
, Etype
(L
))
4677 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
4681 Get_First_Interp
(L
, Ind
, It
);
4682 while Present
(It
.Typ
) loop
4683 if Root_Type
(It
.Typ
) = Standard_Boolean
4684 and then Has_Compatible_Type
(R
, It
.Typ
)
4686 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
4689 Get_Next_Interp
(Ind
, It
);
4693 -- Here we have failed to find an interpretation. Clearly we know that
4694 -- it is not the case that both operands can have an interpretation of
4695 -- Boolean, but this is by far the most likely intended interpretation.
4696 -- So we simply resolve both operands as Booleans, and at least one of
4697 -- these resolutions will generate an error message, and we do not need
4698 -- to give another error message on the short circuit operation itself.
4700 if Etype
(N
) = Any_Type
then
4701 Resolve
(L
, Standard_Boolean
);
4702 Resolve
(R
, Standard_Boolean
);
4703 Set_Etype
(N
, Standard_Boolean
);
4705 end Analyze_Short_Circuit
;
4711 procedure Analyze_Slice
(N
: Node_Id
) is
4712 D
: constant Node_Id
:= Discrete_Range
(N
);
4713 P
: constant Node_Id
:= Prefix
(N
);
4714 Array_Type
: Entity_Id
;
4715 Index_Type
: Entity_Id
;
4717 procedure Analyze_Overloaded_Slice
;
4718 -- If the prefix is overloaded, select those interpretations that
4719 -- yield a one-dimensional array type.
4721 ------------------------------
4722 -- Analyze_Overloaded_Slice --
4723 ------------------------------
4725 procedure Analyze_Overloaded_Slice
is
4731 Set_Etype
(N
, Any_Type
);
4733 Get_First_Interp
(P
, I
, It
);
4734 while Present
(It
.Nam
) loop
4737 if Is_Access_Type
(Typ
) then
4738 Typ
:= Designated_Type
(Typ
);
4740 (Warn_On_Dereference
, "?d?implicit dereference", N
);
4743 if Is_Array_Type
(Typ
)
4744 and then Number_Dimensions
(Typ
) = 1
4745 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
4747 Add_One_Interp
(N
, Typ
, Typ
);
4750 Get_Next_Interp
(I
, It
);
4753 if Etype
(N
) = Any_Type
then
4754 Error_Msg_N
("expect array type in prefix of slice", N
);
4756 end Analyze_Overloaded_Slice
;
4758 -- Start of processing for Analyze_Slice
4761 if Comes_From_Source
(N
) then
4762 Check_SPARK_Restriction
("slice is not allowed", N
);
4768 if Is_Overloaded
(P
) then
4769 Analyze_Overloaded_Slice
;
4772 Array_Type
:= Etype
(P
);
4773 Set_Etype
(N
, Any_Type
);
4775 if Is_Access_Type
(Array_Type
) then
4776 Array_Type
:= Designated_Type
(Array_Type
);
4777 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4780 if not Is_Array_Type
(Array_Type
) then
4781 Wrong_Type
(P
, Any_Array
);
4783 elsif Number_Dimensions
(Array_Type
) > 1 then
4785 ("type is not one-dimensional array in slice prefix", N
);
4788 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
4789 Index_Type
:= Etype
(String_Literal_Low_Bound
(Array_Type
));
4791 Index_Type
:= Etype
(First_Index
(Array_Type
));
4794 if not Has_Compatible_Type
(D
, Index_Type
) then
4795 Wrong_Type
(D
, Index_Type
);
4797 Set_Etype
(N
, Array_Type
);
4803 -----------------------------
4804 -- Analyze_Type_Conversion --
4805 -----------------------------
4807 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
4808 Expr
: constant Node_Id
:= Expression
(N
);
4812 -- If Conversion_OK is set, then the Etype is already set, and the
4813 -- only processing required is to analyze the expression. This is
4814 -- used to construct certain "illegal" conversions which are not
4815 -- allowed by Ada semantics, but can be handled OK by Gigi, see
4816 -- Sinfo for further details.
4818 if Conversion_OK
(N
) then
4823 -- Otherwise full type analysis is required, as well as some semantic
4824 -- checks to make sure the argument of the conversion is appropriate.
4826 Find_Type
(Subtype_Mark
(N
));
4827 T
:= Entity
(Subtype_Mark
(N
));
4829 Check_Fully_Declared
(T
, N
);
4830 Analyze_Expression
(Expr
);
4831 Validate_Remote_Type_Type_Conversion
(N
);
4833 -- Only remaining step is validity checks on the argument. These
4834 -- are skipped if the conversion does not come from the source.
4836 if not Comes_From_Source
(N
) then
4839 -- If there was an error in a generic unit, no need to replicate the
4840 -- error message. Conversely, constant-folding in the generic may
4841 -- transform the argument of a conversion into a string literal, which
4842 -- is legal. Therefore the following tests are not performed in an
4845 elsif In_Instance
then
4848 elsif Nkind
(Expr
) = N_Null
then
4849 Error_Msg_N
("argument of conversion cannot be null", N
);
4850 Error_Msg_N
("\use qualified expression instead", N
);
4851 Set_Etype
(N
, Any_Type
);
4853 elsif Nkind
(Expr
) = N_Aggregate
then
4854 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
4855 Error_Msg_N
("\use qualified expression instead", N
);
4857 elsif Nkind
(Expr
) = N_Allocator
then
4858 Error_Msg_N
("argument of conversion cannot be an allocator", N
);
4859 Error_Msg_N
("\use qualified expression instead", N
);
4861 elsif Nkind
(Expr
) = N_String_Literal
then
4862 Error_Msg_N
("argument of conversion cannot be string literal", N
);
4863 Error_Msg_N
("\use qualified expression instead", N
);
4865 elsif Nkind
(Expr
) = N_Character_Literal
then
4866 if Ada_Version
= Ada_83
then
4869 Error_Msg_N
("argument of conversion cannot be character literal",
4871 Error_Msg_N
("\use qualified expression instead", N
);
4874 elsif Nkind
(Expr
) = N_Attribute_Reference
4876 Nam_In
(Attribute_Name
(Expr
), Name_Access
,
4877 Name_Unchecked_Access
,
4878 Name_Unrestricted_Access
)
4880 Error_Msg_N
("argument of conversion cannot be access", N
);
4881 Error_Msg_N
("\use qualified expression instead", N
);
4883 end Analyze_Type_Conversion
;
4885 ----------------------
4886 -- Analyze_Unary_Op --
4887 ----------------------
4889 procedure Analyze_Unary_Op
(N
: Node_Id
) is
4890 R
: constant Node_Id
:= Right_Opnd
(N
);
4891 Op_Id
: Entity_Id
:= Entity
(N
);
4894 Set_Etype
(N
, Any_Type
);
4895 Candidate_Type
:= Empty
;
4897 Analyze_Expression
(R
);
4899 if Present
(Op_Id
) then
4900 if Ekind
(Op_Id
) = E_Operator
then
4901 Find_Unary_Types
(R
, Op_Id
, N
);
4903 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4907 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
4908 while Present
(Op_Id
) loop
4909 if Ekind
(Op_Id
) = E_Operator
then
4910 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
4911 Find_Unary_Types
(R
, Op_Id
, N
);
4914 elsif Is_Overloadable
(Op_Id
) then
4915 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
4918 Op_Id
:= Homonym
(Op_Id
);
4923 end Analyze_Unary_Op
;
4925 ----------------------------------
4926 -- Analyze_Unchecked_Expression --
4927 ----------------------------------
4929 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
4931 Analyze
(Expression
(N
), Suppress
=> All_Checks
);
4932 Set_Etype
(N
, Etype
(Expression
(N
)));
4933 Save_Interps
(Expression
(N
), N
);
4934 end Analyze_Unchecked_Expression
;
4936 ---------------------------------------
4937 -- Analyze_Unchecked_Type_Conversion --
4938 ---------------------------------------
4940 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
4942 Find_Type
(Subtype_Mark
(N
));
4943 Analyze_Expression
(Expression
(N
));
4944 Set_Etype
(N
, Entity
(Subtype_Mark
(N
)));
4945 end Analyze_Unchecked_Type_Conversion
;
4947 ------------------------------------
4948 -- Analyze_User_Defined_Binary_Op --
4949 ------------------------------------
4951 procedure Analyze_User_Defined_Binary_Op
4956 -- Only do analysis if the operator Comes_From_Source, since otherwise
4957 -- the operator was generated by the expander, and all such operators
4958 -- always refer to the operators in package Standard.
4960 if Comes_From_Source
(N
) then
4962 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
4963 F2
: constant Entity_Id
:= Next_Formal
(F1
);
4966 -- Verify that Op_Id is a visible binary function. Note that since
4967 -- we know Op_Id is overloaded, potentially use visible means use
4968 -- visible for sure (RM 9.4(11)).
4970 if Ekind
(Op_Id
) = E_Function
4971 and then Present
(F2
)
4972 and then (Is_Immediately_Visible
(Op_Id
)
4973 or else Is_Potentially_Use_Visible
(Op_Id
))
4974 and then Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
4975 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
4977 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4979 -- If the left operand is overloaded, indicate that the
4980 -- current type is a viable candidate. This is redundant
4981 -- in most cases, but for equality and comparison operators
4982 -- where the context does not impose a type on the operands,
4983 -- setting the proper type is necessary to avoid subsequent
4984 -- ambiguities during resolution, when both user-defined and
4985 -- predefined operators may be candidates.
4987 if Is_Overloaded
(Left_Opnd
(N
)) then
4988 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
4991 if Debug_Flag_E
then
4992 Write_Str
("user defined operator ");
4993 Write_Name
(Chars
(Op_Id
));
4994 Write_Str
(" on node ");
4995 Write_Int
(Int
(N
));
5001 end Analyze_User_Defined_Binary_Op
;
5003 -----------------------------------
5004 -- Analyze_User_Defined_Unary_Op --
5005 -----------------------------------
5007 procedure Analyze_User_Defined_Unary_Op
5012 -- Only do analysis if the operator Comes_From_Source, since otherwise
5013 -- the operator was generated by the expander, and all such operators
5014 -- always refer to the operators in package Standard.
5016 if Comes_From_Source
(N
) then
5018 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
5021 -- Verify that Op_Id is a visible unary function. Note that since
5022 -- we know Op_Id is overloaded, potentially use visible means use
5023 -- visible for sure (RM 9.4(11)).
5025 if Ekind
(Op_Id
) = E_Function
5026 and then No
(Next_Formal
(F
))
5027 and then (Is_Immediately_Visible
(Op_Id
)
5028 or else Is_Potentially_Use_Visible
(Op_Id
))
5029 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
5031 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
5035 end Analyze_User_Defined_Unary_Op
;
5037 ---------------------------
5038 -- Check_Arithmetic_Pair --
5039 ---------------------------
5041 procedure Check_Arithmetic_Pair
5042 (T1
, T2
: Entity_Id
;
5046 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
5048 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
5049 -- Check whether the fixed-point type Typ has a user-defined operator
5050 -- (multiplication or division) that should hide the corresponding
5051 -- predefined operator. Used to implement Ada 2005 AI-264, to make
5052 -- such operators more visible and therefore useful.
5054 -- If the name of the operation is an expanded name with prefix
5055 -- Standard, the predefined universal fixed operator is available,
5056 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
5058 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
5059 -- Get specific type (i.e. non-universal type if there is one)
5065 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
5066 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
5072 -- If the universal_fixed operation is given explicitly the rule
5073 -- concerning primitive operations of the type do not apply.
5075 if Nkind
(N
) = N_Function_Call
5076 and then Nkind
(Name
(N
)) = N_Expanded_Name
5077 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
5082 -- The operation is treated as primitive if it is declared in the
5083 -- same scope as the type, and therefore on the same entity chain.
5085 Ent
:= Next_Entity
(Typ
);
5086 while Present
(Ent
) loop
5087 if Chars
(Ent
) = Chars
(Op
) then
5088 F1
:= First_Formal
(Ent
);
5089 F2
:= Next_Formal
(F1
);
5091 -- The operation counts as primitive if either operand or
5092 -- result are of the given base type, and both operands are
5093 -- fixed point types.
5095 if (Base_Type
(Etype
(F1
)) = Bas
5096 and then Is_Fixed_Point_Type
(Etype
(F2
)))
5099 (Base_Type
(Etype
(F2
)) = Bas
5100 and then Is_Fixed_Point_Type
(Etype
(F1
)))
5103 (Base_Type
(Etype
(Ent
)) = Bas
5104 and then Is_Fixed_Point_Type
(Etype
(F1
))
5105 and then Is_Fixed_Point_Type
(Etype
(F2
)))
5121 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
5123 if T1
= Universal_Integer
or else T1
= Universal_Real
then
5124 return Base_Type
(T2
);
5126 return Base_Type
(T1
);
5130 -- Start of processing for Check_Arithmetic_Pair
5133 if Nam_In
(Op_Name
, Name_Op_Add
, Name_Op_Subtract
) then
5134 if Is_Numeric_Type
(T1
)
5135 and then Is_Numeric_Type
(T2
)
5136 and then (Covers
(T1
=> T1
, T2
=> T2
)
5138 Covers
(T1
=> T2
, T2
=> T1
))
5140 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5143 elsif Nam_In
(Op_Name
, Name_Op_Multiply
, Name_Op_Divide
) then
5144 if Is_Fixed_Point_Type
(T1
)
5145 and then (Is_Fixed_Point_Type
(T2
) or else T2
= Universal_Real
)
5147 -- If Treat_Fixed_As_Integer is set then the Etype is already set
5148 -- and no further processing is required (this is the case of an
5149 -- operator constructed by Exp_Fixd for a fixed point operation)
5150 -- Otherwise add one interpretation with universal fixed result
5151 -- If the operator is given in functional notation, it comes
5152 -- from source and Fixed_As_Integer cannot apply.
5154 if (Nkind
(N
) not in N_Op
5155 or else not Treat_Fixed_As_Integer
(N
))
5157 (not Has_Fixed_Op
(T1
, Op_Id
)
5158 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
5160 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
5163 elsif Is_Fixed_Point_Type
(T2
)
5164 and then (Nkind
(N
) not in N_Op
5165 or else not Treat_Fixed_As_Integer
(N
))
5166 and then T1
= Universal_Real
5168 (not Has_Fixed_Op
(T1
, Op_Id
)
5169 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
5171 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
5173 elsif Is_Numeric_Type
(T1
)
5174 and then Is_Numeric_Type
(T2
)
5175 and then (Covers
(T1
=> T1
, T2
=> T2
)
5177 Covers
(T1
=> T2
, T2
=> T1
))
5179 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5181 elsif Is_Fixed_Point_Type
(T1
)
5182 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5183 or else T2
= Universal_Integer
)
5185 Add_One_Interp
(N
, Op_Id
, T1
);
5187 elsif T2
= Universal_Real
5188 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5189 and then Op_Name
= Name_Op_Multiply
5191 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5193 elsif T1
= Universal_Real
5194 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5196 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5198 elsif Is_Fixed_Point_Type
(T2
)
5199 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5200 or else T1
= Universal_Integer
)
5201 and then Op_Name
= Name_Op_Multiply
5203 Add_One_Interp
(N
, Op_Id
, T2
);
5205 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
5206 Add_One_Interp
(N
, Op_Id
, T1
);
5208 elsif T2
= Universal_Real
5209 and then T1
= Universal_Integer
5210 and then Op_Name
= Name_Op_Multiply
5212 Add_One_Interp
(N
, Op_Id
, T2
);
5215 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
5217 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
5218 -- set does not require any special processing, since the Etype is
5219 -- already set (case of operation constructed by Exp_Fixed).
5221 if Is_Integer_Type
(T1
)
5222 and then (Covers
(T1
=> T1
, T2
=> T2
)
5224 Covers
(T1
=> T2
, T2
=> T1
))
5226 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5229 elsif Op_Name
= Name_Op_Expon
then
5230 if Is_Numeric_Type
(T1
)
5231 and then not Is_Fixed_Point_Type
(T1
)
5232 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5233 or else T2
= Universal_Integer
)
5235 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5238 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
5240 -- If not one of the predefined operators, the node may be one
5241 -- of the intrinsic functions. Its kind is always specific, and
5242 -- we can use it directly, rather than the name of the operation.
5244 if Is_Integer_Type
(T1
)
5245 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5246 or else T2
= Universal_Integer
)
5248 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5251 end Check_Arithmetic_Pair
;
5253 -------------------------------
5254 -- Check_Misspelled_Selector --
5255 -------------------------------
5257 procedure Check_Misspelled_Selector
5258 (Prefix
: Entity_Id
;
5261 Max_Suggestions
: constant := 2;
5262 Nr_Of_Suggestions
: Natural := 0;
5264 Suggestion_1
: Entity_Id
:= Empty
;
5265 Suggestion_2
: Entity_Id
:= Empty
;
5270 -- All the components of the prefix of selector Sel are matched
5271 -- against Sel and a count is maintained of possible misspellings.
5272 -- When at the end of the analysis there are one or two (not more!)
5273 -- possible misspellings, these misspellings will be suggested as
5274 -- possible correction.
5276 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
5278 -- Concurrent types should be handled as well ???
5283 Comp
:= First_Entity
(Prefix
);
5284 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
5285 if Is_Visible_Component
(Comp
) then
5286 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
5287 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
5289 case Nr_Of_Suggestions
is
5290 when 1 => Suggestion_1
:= Comp
;
5291 when 2 => Suggestion_2
:= Comp
;
5292 when others => exit;
5297 Comp
:= Next_Entity
(Comp
);
5300 -- Report at most two suggestions
5302 if Nr_Of_Suggestions
= 1 then
5303 Error_Msg_NE
-- CODEFIX
5304 ("\possible misspelling of&", Sel
, Suggestion_1
);
5306 elsif Nr_Of_Suggestions
= 2 then
5307 Error_Msg_Node_2
:= Suggestion_2
;
5308 Error_Msg_NE
-- CODEFIX
5309 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
5311 end Check_Misspelled_Selector
;
5313 ----------------------
5314 -- Defined_In_Scope --
5315 ----------------------
5317 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean
5319 S1
: constant Entity_Id
:= Scope
(Base_Type
(T
));
5322 or else (S1
= System_Aux_Id
and then S
= Scope
(S1
));
5323 end Defined_In_Scope
;
5329 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
5335 Void_Interp_Seen
: Boolean := False;
5338 pragma Warnings
(Off
, Boolean);
5341 if Ada_Version
>= Ada_2005
then
5342 Actual
:= First_Actual
(N
);
5343 while Present
(Actual
) loop
5345 -- Ada 2005 (AI-50217): Post an error in case of premature
5346 -- usage of an entity from the limited view.
5348 if not Analyzed
(Etype
(Actual
))
5349 and then From_With_Type
(Etype
(Actual
))
5351 Error_Msg_Qual_Level
:= 1;
5353 ("missing with_clause for scope of imported type&",
5354 Actual
, Etype
(Actual
));
5355 Error_Msg_Qual_Level
:= 0;
5358 Next_Actual
(Actual
);
5362 -- Analyze each candidate call again, with full error reporting
5366 ("no candidate interpretations match the actuals:!", Nam
);
5367 Err_Mode
:= All_Errors_Mode
;
5368 All_Errors_Mode
:= True;
5370 -- If this is a call to an operation of a concurrent type,
5371 -- the failed interpretations have been removed from the
5372 -- name. Recover them to provide full diagnostics.
5374 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
5375 Set_Entity
(Nam
, Empty
);
5376 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
5377 Set_Is_Overloaded
(New_Nam
, False);
5378 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
5379 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
5380 Analyze_Selected_Component
(New_Nam
);
5381 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
5383 Get_First_Interp
(Nam
, X
, It
);
5386 while Present
(It
.Nam
) loop
5387 if Etype
(It
.Nam
) = Standard_Void_Type
then
5388 Void_Interp_Seen
:= True;
5391 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
5392 Get_Next_Interp
(X
, It
);
5395 if Nkind
(N
) = N_Function_Call
then
5396 Get_First_Interp
(Nam
, X
, It
);
5397 while Present
(It
.Nam
) loop
5398 if Ekind_In
(It
.Nam
, E_Function
, E_Operator
) then
5401 Get_Next_Interp
(X
, It
);
5405 -- If all interpretations are procedures, this deserves a
5406 -- more precise message. Ditto if this appears as the prefix
5407 -- of a selected component, which may be a lexical error.
5410 ("\context requires function call, found procedure name", Nam
);
5412 if Nkind
(Parent
(N
)) = N_Selected_Component
5413 and then N
= Prefix
(Parent
(N
))
5415 Error_Msg_N
-- CODEFIX
5416 ("\period should probably be semicolon", Parent
(N
));
5419 elsif Nkind
(N
) = N_Procedure_Call_Statement
5420 and then not Void_Interp_Seen
5423 "\function name found in procedure call", Nam
);
5426 All_Errors_Mode
:= Err_Mode
;
5429 ---------------------------
5430 -- Find_Arithmetic_Types --
5431 ---------------------------
5433 procedure Find_Arithmetic_Types
5438 Index1
: Interp_Index
;
5439 Index2
: Interp_Index
;
5443 procedure Check_Right_Argument
(T
: Entity_Id
);
5444 -- Check right operand of operator
5446 --------------------------
5447 -- Check_Right_Argument --
5448 --------------------------
5450 procedure Check_Right_Argument
(T
: Entity_Id
) is
5452 if not Is_Overloaded
(R
) then
5453 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
5455 Get_First_Interp
(R
, Index2
, It2
);
5456 while Present
(It2
.Typ
) loop
5457 Check_Arithmetic_Pair
(T
, It2
.Typ
, Op_Id
, N
);
5458 Get_Next_Interp
(Index2
, It2
);
5461 end Check_Right_Argument
;
5463 -- Start of processing for Find_Arithmetic_Types
5466 if not Is_Overloaded
(L
) then
5467 Check_Right_Argument
(Etype
(L
));
5470 Get_First_Interp
(L
, Index1
, It1
);
5471 while Present
(It1
.Typ
) loop
5472 Check_Right_Argument
(It1
.Typ
);
5473 Get_Next_Interp
(Index1
, It1
);
5477 end Find_Arithmetic_Types
;
5479 ------------------------
5480 -- Find_Boolean_Types --
5481 ------------------------
5483 procedure Find_Boolean_Types
5488 Index
: Interp_Index
;
5491 procedure Check_Numeric_Argument
(T
: Entity_Id
);
5492 -- Special case for logical operations one of whose operands is an
5493 -- integer literal. If both are literal the result is any modular type.
5495 ----------------------------
5496 -- Check_Numeric_Argument --
5497 ----------------------------
5499 procedure Check_Numeric_Argument
(T
: Entity_Id
) is
5501 if T
= Universal_Integer
then
5502 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5504 elsif Is_Modular_Integer_Type
(T
) then
5505 Add_One_Interp
(N
, Op_Id
, T
);
5507 end Check_Numeric_Argument
;
5509 -- Start of processing for Find_Boolean_Types
5512 if not Is_Overloaded
(L
) then
5513 if Etype
(L
) = Universal_Integer
5514 or else Etype
(L
) = Any_Modular
5516 if not Is_Overloaded
(R
) then
5517 Check_Numeric_Argument
(Etype
(R
));
5520 Get_First_Interp
(R
, Index
, It
);
5521 while Present
(It
.Typ
) loop
5522 Check_Numeric_Argument
(It
.Typ
);
5523 Get_Next_Interp
(Index
, It
);
5527 -- If operands are aggregates, we must assume that they may be
5528 -- boolean arrays, and leave disambiguation for the second pass.
5529 -- If only one is an aggregate, verify that the other one has an
5530 -- interpretation as a boolean array
5532 elsif Nkind
(L
) = N_Aggregate
then
5533 if Nkind
(R
) = N_Aggregate
then
5534 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
5536 elsif not Is_Overloaded
(R
) then
5537 if Valid_Boolean_Arg
(Etype
(R
)) then
5538 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5542 Get_First_Interp
(R
, Index
, It
);
5543 while Present
(It
.Typ
) loop
5544 if Valid_Boolean_Arg
(It
.Typ
) then
5545 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5548 Get_Next_Interp
(Index
, It
);
5552 elsif Valid_Boolean_Arg
(Etype
(L
))
5553 and then Has_Compatible_Type
(R
, Etype
(L
))
5555 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
5559 Get_First_Interp
(L
, Index
, It
);
5560 while Present
(It
.Typ
) loop
5561 if Valid_Boolean_Arg
(It
.Typ
)
5562 and then Has_Compatible_Type
(R
, It
.Typ
)
5564 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5567 Get_Next_Interp
(Index
, It
);
5570 end Find_Boolean_Types
;
5572 ---------------------------
5573 -- Find_Comparison_Types --
5574 ---------------------------
5576 procedure Find_Comparison_Types
5581 Index
: Interp_Index
;
5583 Found
: Boolean := False;
5586 Scop
: Entity_Id
:= Empty
;
5588 procedure Try_One_Interp
(T1
: Entity_Id
);
5589 -- Routine to try one proposed interpretation. Note that the context
5590 -- of the operator plays no role in resolving the arguments, so that
5591 -- if there is more than one interpretation of the operands that is
5592 -- compatible with comparison, the operation is ambiguous.
5594 --------------------
5595 -- Try_One_Interp --
5596 --------------------
5598 procedure Try_One_Interp
(T1
: Entity_Id
) is
5601 -- If the operator is an expanded name, then the type of the operand
5602 -- must be defined in the corresponding scope. If the type is
5603 -- universal, the context will impose the correct type.
5606 and then not Defined_In_Scope
(T1
, Scop
)
5607 and then T1
/= Universal_Integer
5608 and then T1
/= Universal_Real
5609 and then T1
/= Any_String
5610 and then T1
/= Any_Composite
5615 if Valid_Comparison_Arg
(T1
)
5616 and then Has_Compatible_Type
(R
, T1
)
5619 and then Base_Type
(T1
) /= Base_Type
(T_F
)
5621 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
5623 if It
= No_Interp
then
5624 Ambiguous_Operands
(N
);
5625 Set_Etype
(L
, Any_Type
);
5639 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
5644 -- Start of processing for Find_Comparison_Types
5647 -- If left operand is aggregate, the right operand has to
5648 -- provide a usable type for it.
5650 if Nkind
(L
) = N_Aggregate
5651 and then Nkind
(R
) /= N_Aggregate
5653 Find_Comparison_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
5657 if Nkind
(N
) = N_Function_Call
5658 and then Nkind
(Name
(N
)) = N_Expanded_Name
5660 Scop
:= Entity
(Prefix
(Name
(N
)));
5662 -- The prefix may be a package renaming, and the subsequent test
5663 -- requires the original package.
5665 if Ekind
(Scop
) = E_Package
5666 and then Present
(Renamed_Entity
(Scop
))
5668 Scop
:= Renamed_Entity
(Scop
);
5669 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5673 if not Is_Overloaded
(L
) then
5674 Try_One_Interp
(Etype
(L
));
5677 Get_First_Interp
(L
, Index
, It
);
5678 while Present
(It
.Typ
) loop
5679 Try_One_Interp
(It
.Typ
);
5680 Get_Next_Interp
(Index
, It
);
5683 end Find_Comparison_Types
;
5685 ----------------------------------------
5686 -- Find_Non_Universal_Interpretations --
5687 ----------------------------------------
5689 procedure Find_Non_Universal_Interpretations
5695 Index
: Interp_Index
;
5699 if T1
= Universal_Integer
5700 or else T1
= Universal_Real
5702 -- If the left operand of an equality operator is null, the visibility
5703 -- of the operator must be determined from the interpretation of the
5704 -- right operand. This processing must be done for Any_Access, which
5705 -- is the internal representation of the type of the literal null.
5707 or else T1
= Any_Access
5709 if not Is_Overloaded
(R
) then
5711 (N
, Op_Id
, Standard_Boolean
, Base_Type
(Etype
(R
)));
5713 Get_First_Interp
(R
, Index
, It
);
5714 while Present
(It
.Typ
) loop
5715 if Covers
(It
.Typ
, T1
) then
5717 (N
, Op_Id
, Standard_Boolean
, Base_Type
(It
.Typ
));
5720 Get_Next_Interp
(Index
, It
);
5724 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(T1
));
5726 end Find_Non_Universal_Interpretations
;
5728 ------------------------------
5729 -- Find_Concatenation_Types --
5730 ------------------------------
5732 procedure Find_Concatenation_Types
5737 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
5740 if Is_Array_Type
(Op_Type
)
5741 and then not Is_Limited_Type
(Op_Type
)
5743 and then (Has_Compatible_Type
(L
, Op_Type
)
5745 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
5747 and then (Has_Compatible_Type
(R
, Op_Type
)
5749 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
5751 Add_One_Interp
(N
, Op_Id
, Op_Type
);
5753 end Find_Concatenation_Types
;
5755 -------------------------
5756 -- Find_Equality_Types --
5757 -------------------------
5759 procedure Find_Equality_Types
5764 Index
: Interp_Index
;
5766 Found
: Boolean := False;
5769 Scop
: Entity_Id
:= Empty
;
5771 procedure Try_One_Interp
(T1
: Entity_Id
);
5772 -- The context of the equality operator plays no role in resolving the
5773 -- arguments, so that if there is more than one interpretation of the
5774 -- operands that is compatible with equality, the construct is ambiguous
5775 -- and an error can be emitted now, after trying to disambiguate, i.e.
5776 -- applying preference rules.
5778 --------------------
5779 -- Try_One_Interp --
5780 --------------------
5782 procedure Try_One_Interp
(T1
: Entity_Id
) is
5783 Bas
: constant Entity_Id
:= Base_Type
(T1
);
5786 -- If the operator is an expanded name, then the type of the operand
5787 -- must be defined in the corresponding scope. If the type is
5788 -- universal, the context will impose the correct type. An anonymous
5789 -- type for a 'Access reference is also universal in this sense, as
5790 -- the actual type is obtained from context.
5791 -- In Ada 2005, the equality operator for anonymous access types
5792 -- is declared in Standard, and preference rules apply to it.
5794 if Present
(Scop
) then
5795 if Defined_In_Scope
(T1
, Scop
)
5796 or else T1
= Universal_Integer
5797 or else T1
= Universal_Real
5798 or else T1
= Any_Access
5799 or else T1
= Any_String
5800 or else T1
= Any_Composite
5801 or else (Ekind
(T1
) = E_Access_Subprogram_Type
5802 and then not Comes_From_Source
(T1
))
5806 elsif Ekind
(T1
) = E_Anonymous_Access_Type
5807 and then Scop
= Standard_Standard
5812 -- The scope does not contain an operator for the type
5817 -- If we have infix notation, the operator must be usable. Within
5818 -- an instance, if the type is already established we know it is
5819 -- correct. If an operand is universal it is compatible with any
5822 -- In Ada 2005, the equality on anonymous access types is declared
5823 -- in Standard, and is always visible.
5825 elsif In_Open_Scopes
(Scope
(Bas
))
5826 or else Is_Potentially_Use_Visible
(Bas
)
5827 or else In_Use
(Bas
)
5828 or else (In_Use
(Scope
(Bas
)) and then not Is_Hidden
(Bas
))
5829 or else (In_Instance
5831 (First_Subtype
(T1
) = First_Subtype
(Etype
(R
))
5833 (Is_Numeric_Type
(T1
)
5834 and then Is_Universal_Numeric_Type
(Etype
(R
)))))
5835 or else Ekind
(T1
) = E_Anonymous_Access_Type
5840 -- Save candidate type for subsequent error message, if any
5842 if not Is_Limited_Type
(T1
) then
5843 Candidate_Type
:= T1
;
5849 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
5850 -- Do not allow anonymous access types in equality operators.
5852 if Ada_Version
< Ada_2005
5853 and then Ekind
(T1
) = E_Anonymous_Access_Type
5858 -- If the right operand has a type compatible with T1, check for an
5859 -- acceptable interpretation, unless T1 is limited (no predefined
5860 -- equality available), or this is use of a "/=" for a tagged type.
5861 -- In the latter case, possible interpretations of equality need to
5862 -- be considered, we don't want the default inequality declared in
5863 -- Standard to be chosen, and the "/=" will be rewritten as a
5864 -- negation of "=" (see the end of Analyze_Equality_Op). This ensures
5865 -- that that rewriting happens during analysis rather than being
5866 -- delayed until expansion (this is needed for ASIS, which only sees
5867 -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id
5868 -- is Name_Op_Eq then we still proceed with the interpretation,
5869 -- because that indicates the potential rewriting case where the
5870 -- interpretation to consider is actually "=" and the node may be
5871 -- about to be rewritten by Analyze_Equality_Op.
5873 if T1
/= Standard_Void_Type
5874 and then Has_Compatible_Type
(R
, T1
)
5877 ((not Is_Limited_Type
(T1
)
5878 and then not Is_Limited_Composite
(T1
))
5882 and then not Is_Limited_Type
(Component_Type
(T1
))
5883 and then Available_Full_View_Of_Component
(T1
)))
5886 (Nkind
(N
) /= N_Op_Ne
5887 or else not Is_Tagged_Type
(T1
)
5888 or else Chars
(Op_Id
) = Name_Op_Eq
)
5891 and then Base_Type
(T1
) /= Base_Type
(T_F
)
5893 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
5895 if It
= No_Interp
then
5896 Ambiguous_Operands
(N
);
5897 Set_Etype
(L
, Any_Type
);
5910 if not Analyzed
(L
) then
5914 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
5916 -- Case of operator was not visible, Etype still set to Any_Type
5918 if Etype
(N
) = Any_Type
then
5922 elsif Scop
= Standard_Standard
5923 and then Ekind
(T1
) = E_Anonymous_Access_Type
5929 -- Start of processing for Find_Equality_Types
5932 -- If left operand is aggregate, the right operand has to
5933 -- provide a usable type for it.
5935 if Nkind
(L
) = N_Aggregate
5936 and then Nkind
(R
) /= N_Aggregate
5938 Find_Equality_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
5942 if Nkind
(N
) = N_Function_Call
5943 and then Nkind
(Name
(N
)) = N_Expanded_Name
5945 Scop
:= Entity
(Prefix
(Name
(N
)));
5947 -- The prefix may be a package renaming, and the subsequent test
5948 -- requires the original package.
5950 if Ekind
(Scop
) = E_Package
5951 and then Present
(Renamed_Entity
(Scop
))
5953 Scop
:= Renamed_Entity
(Scop
);
5954 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5958 if not Is_Overloaded
(L
) then
5959 Try_One_Interp
(Etype
(L
));
5962 Get_First_Interp
(L
, Index
, It
);
5963 while Present
(It
.Typ
) loop
5964 Try_One_Interp
(It
.Typ
);
5965 Get_Next_Interp
(Index
, It
);
5968 end Find_Equality_Types
;
5970 -------------------------
5971 -- Find_Negation_Types --
5972 -------------------------
5974 procedure Find_Negation_Types
5979 Index
: Interp_Index
;
5983 if not Is_Overloaded
(R
) then
5984 if Etype
(R
) = Universal_Integer
then
5985 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5986 elsif Valid_Boolean_Arg
(Etype
(R
)) then
5987 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5991 Get_First_Interp
(R
, Index
, It
);
5992 while Present
(It
.Typ
) loop
5993 if Valid_Boolean_Arg
(It
.Typ
) then
5994 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5997 Get_Next_Interp
(Index
, It
);
6000 end Find_Negation_Types
;
6002 ------------------------------
6003 -- Find_Primitive_Operation --
6004 ------------------------------
6006 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
6007 Obj
: constant Node_Id
:= Prefix
(N
);
6008 Op
: constant Node_Id
:= Selector_Name
(N
);
6015 Set_Etype
(Op
, Any_Type
);
6017 if Is_Access_Type
(Etype
(Obj
)) then
6018 Typ
:= Designated_Type
(Etype
(Obj
));
6023 if Is_Class_Wide_Type
(Typ
) then
6024 Typ
:= Root_Type
(Typ
);
6027 Prims
:= Primitive_Operations
(Typ
);
6029 Prim
:= First_Elmt
(Prims
);
6030 while Present
(Prim
) loop
6031 if Chars
(Node
(Prim
)) = Chars
(Op
) then
6032 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
6033 Set_Etype
(N
, Etype
(Node
(Prim
)));
6039 -- Now look for class-wide operations of the type or any of its
6040 -- ancestors by iterating over the homonyms of the selector.
6043 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
6047 Hom
:= Current_Entity
(Op
);
6048 while Present
(Hom
) loop
6049 if (Ekind
(Hom
) = E_Procedure
6051 Ekind
(Hom
) = E_Function
)
6052 and then Scope
(Hom
) = Scope
(Typ
)
6053 and then Present
(First_Formal
(Hom
))
6055 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
6057 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
6059 Ekind
(Etype
(First_Formal
(Hom
))) =
6060 E_Anonymous_Access_Type
6063 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
6066 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
6067 Set_Etype
(N
, Etype
(Hom
));
6070 Hom
:= Homonym
(Hom
);
6074 return Etype
(Op
) /= Any_Type
;
6075 end Find_Primitive_Operation
;
6077 ----------------------
6078 -- Find_Unary_Types --
6079 ----------------------
6081 procedure Find_Unary_Types
6086 Index
: Interp_Index
;
6090 if not Is_Overloaded
(R
) then
6091 if Is_Numeric_Type
(Etype
(R
)) then
6093 -- In an instance a generic actual may be a numeric type even if
6094 -- the formal in the generic unit was not. In that case, the
6095 -- predefined operator was not a possible interpretation in the
6096 -- generic, and cannot be one in the instance.
6100 not Is_Numeric_Type
(Corresponding_Generic_Type
(Etype
(R
)))
6104 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
6109 Get_First_Interp
(R
, Index
, It
);
6110 while Present
(It
.Typ
) loop
6111 if Is_Numeric_Type
(It
.Typ
) then
6115 (Corresponding_Generic_Type
(Etype
(It
.Typ
)))
6120 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
6124 Get_Next_Interp
(Index
, It
);
6127 end Find_Unary_Types
;
6133 function Junk_Operand
(N
: Node_Id
) return Boolean is
6137 if Error_Posted
(N
) then
6141 -- Get entity to be tested
6143 if Is_Entity_Name
(N
)
6144 and then Present
(Entity
(N
))
6148 -- An odd case, a procedure name gets converted to a very peculiar
6149 -- function call, and here is where we detect this happening.
6151 elsif Nkind
(N
) = N_Function_Call
6152 and then Is_Entity_Name
(Name
(N
))
6153 and then Present
(Entity
(Name
(N
)))
6157 -- Another odd case, there are at least some cases of selected
6158 -- components where the selected component is not marked as having
6159 -- an entity, even though the selector does have an entity
6161 elsif Nkind
(N
) = N_Selected_Component
6162 and then Present
(Entity
(Selector_Name
(N
)))
6164 Enode
:= Selector_Name
(N
);
6170 -- Now test the entity we got to see if it is a bad case
6172 case Ekind
(Entity
(Enode
)) is
6176 ("package name cannot be used as operand", Enode
);
6178 when Generic_Unit_Kind
=>
6180 ("generic unit name cannot be used as operand", Enode
);
6184 ("subtype name cannot be used as operand", Enode
);
6188 ("entry name cannot be used as operand", Enode
);
6192 ("procedure name cannot be used as operand", Enode
);
6196 ("exception name cannot be used as operand", Enode
);
6198 when E_Block | E_Label | E_Loop
=>
6200 ("label name cannot be used as operand", Enode
);
6210 --------------------
6211 -- Operator_Check --
6212 --------------------
6214 procedure Operator_Check
(N
: Node_Id
) is
6216 Remove_Abstract_Operations
(N
);
6218 -- Test for case of no interpretation found for operator
6220 if Etype
(N
) = Any_Type
then
6224 Op_Id
: Entity_Id
:= Empty
;
6227 R
:= Right_Opnd
(N
);
6229 if Nkind
(N
) in N_Binary_Op
then
6235 -- If either operand has no type, then don't complain further,
6236 -- since this simply means that we have a propagated error.
6239 or else Etype
(R
) = Any_Type
6240 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
6244 -- We explicitly check for the case of concatenation of component
6245 -- with component to avoid reporting spurious matching array types
6246 -- that might happen to be lurking in distant packages (such as
6247 -- run-time packages). This also prevents inconsistencies in the
6248 -- messages for certain ACVC B tests, which can vary depending on
6249 -- types declared in run-time interfaces. Another improvement when
6250 -- aggregates are present is to look for a well-typed operand.
6252 elsif Present
(Candidate_Type
)
6253 and then (Nkind
(N
) /= N_Op_Concat
6254 or else Is_Array_Type
(Etype
(L
))
6255 or else Is_Array_Type
(Etype
(R
)))
6257 if Nkind
(N
) = N_Op_Concat
then
6258 if Etype
(L
) /= Any_Composite
6259 and then Is_Array_Type
(Etype
(L
))
6261 Candidate_Type
:= Etype
(L
);
6263 elsif Etype
(R
) /= Any_Composite
6264 and then Is_Array_Type
(Etype
(R
))
6266 Candidate_Type
:= Etype
(R
);
6270 Error_Msg_NE
-- CODEFIX
6271 ("operator for} is not directly visible!",
6272 N
, First_Subtype
(Candidate_Type
));
6275 U
: constant Node_Id
:=
6276 Cunit
(Get_Source_Unit
(Candidate_Type
));
6278 if Unit_Is_Visible
(U
) then
6279 Error_Msg_N
-- CODEFIX
6280 ("use clause would make operation legal!", N
);
6282 Error_Msg_NE
-- CODEFIX
6283 ("add with_clause and use_clause for&!",
6284 N
, Defining_Entity
(Unit
(U
)));
6289 -- If either operand is a junk operand (e.g. package name), then
6290 -- post appropriate error messages, but do not complain further.
6292 -- Note that the use of OR in this test instead of OR ELSE is
6293 -- quite deliberate, we may as well check both operands in the
6294 -- binary operator case.
6296 elsif Junk_Operand
(R
)
6297 or (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
6301 -- If we have a logical operator, one of whose operands is
6302 -- Boolean, then we know that the other operand cannot resolve to
6303 -- Boolean (since we got no interpretations), but in that case we
6304 -- pretty much know that the other operand should be Boolean, so
6305 -- resolve it that way (generating an error)
6307 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
) then
6308 if Etype
(L
) = Standard_Boolean
then
6309 Resolve
(R
, Standard_Boolean
);
6311 elsif Etype
(R
) = Standard_Boolean
then
6312 Resolve
(L
, Standard_Boolean
);
6316 -- For an arithmetic operator or comparison operator, if one
6317 -- of the operands is numeric, then we know the other operand
6318 -- is not the same numeric type. If it is a non-numeric type,
6319 -- then probably it is intended to match the other operand.
6321 elsif Nkind_In
(N
, N_Op_Add
,
6327 Nkind_In
(N
, N_Op_Lt
,
6333 if Is_Numeric_Type
(Etype
(L
))
6334 and then not Is_Numeric_Type
(Etype
(R
))
6336 Resolve
(R
, Etype
(L
));
6339 elsif Is_Numeric_Type
(Etype
(R
))
6340 and then not Is_Numeric_Type
(Etype
(L
))
6342 Resolve
(L
, Etype
(R
));
6346 -- Comparisons on A'Access are common enough to deserve a
6349 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
6350 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
6351 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
6354 ("two access attributes cannot be compared directly", N
);
6356 ("\use qualified expression for one of the operands",
6360 -- Another one for C programmers
6362 elsif Nkind
(N
) = N_Op_Concat
6363 and then Valid_Boolean_Arg
(Etype
(L
))
6364 and then Valid_Boolean_Arg
(Etype
(R
))
6366 Error_Msg_N
("invalid operands for concatenation", N
);
6367 Error_Msg_N
-- CODEFIX
6368 ("\maybe AND was meant", N
);
6371 -- A special case for comparison of access parameter with null
6373 elsif Nkind
(N
) = N_Op_Eq
6374 and then Is_Entity_Name
(L
)
6375 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
6376 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
6378 and then Nkind
(R
) = N_Null
6380 Error_Msg_N
("access parameter is not allowed to be null", L
);
6381 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
6384 -- Another special case for exponentiation, where the right
6385 -- operand must be Natural, independently of the base.
6387 elsif Nkind
(N
) = N_Op_Expon
6388 and then Is_Numeric_Type
(Etype
(L
))
6389 and then not Is_Overloaded
(R
)
6391 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
6392 and then Base_Type
(Etype
(R
)) /= Universal_Integer
6394 if Ada_Version
>= Ada_2012
6395 and then Has_Dimension_System
(Etype
(L
))
6398 ("exponent for dimensioned type must be a rational" &
6399 ", found}", R
, Etype
(R
));
6402 ("exponent must be of type Natural, found}", R
, Etype
(R
));
6408 -- If we fall through then just give general message. Note that in
6409 -- the following messages, if the operand is overloaded we choose
6410 -- an arbitrary type to complain about, but that is probably more
6411 -- useful than not giving a type at all.
6413 if Nkind
(N
) in N_Unary_Op
then
6414 Error_Msg_Node_2
:= Etype
(R
);
6415 Error_Msg_N
("operator& not defined for}", N
);
6419 if Nkind
(N
) in N_Binary_Op
then
6420 if not Is_Overloaded
(L
)
6421 and then not Is_Overloaded
(R
)
6422 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
6424 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
6425 Error_Msg_N
("there is no applicable operator& for}", N
);
6428 -- Another attempt to find a fix: one of the candidate
6429 -- interpretations may not be use-visible. This has
6430 -- already been checked for predefined operators, so
6431 -- we examine only user-defined functions.
6433 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
6435 while Present
(Op_Id
) loop
6436 if Ekind
(Op_Id
) /= E_Operator
6437 and then Is_Overloadable
(Op_Id
)
6439 if not Is_Immediately_Visible
(Op_Id
)
6440 and then not In_Use
(Scope
(Op_Id
))
6441 and then not Is_Abstract_Subprogram
(Op_Id
)
6442 and then not Is_Hidden
(Op_Id
)
6443 and then Ekind
(Scope
(Op_Id
)) = E_Package
6446 (L
, Etype
(First_Formal
(Op_Id
)))
6448 (Next_Formal
(First_Formal
(Op_Id
)))
6452 Etype
(Next_Formal
(First_Formal
(Op_Id
))))
6455 ("No legal interpretation for operator&", N
);
6457 ("\use clause on& would make operation legal",
6463 Op_Id
:= Homonym
(Op_Id
);
6467 Error_Msg_N
("invalid operand types for operator&", N
);
6469 if Nkind
(N
) /= N_Op_Concat
then
6470 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
6471 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
6481 -----------------------------------------
6482 -- Process_Implicit_Dereference_Prefix --
6483 -----------------------------------------
6485 function Process_Implicit_Dereference_Prefix
6487 P
: Entity_Id
) return Entity_Id
6490 Typ
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
6494 and then (Operating_Mode
= Check_Semantics
or else not Expander_Active
)
6496 -- We create a dummy reference to E to ensure that the reference
6497 -- is not considered as part of an assignment (an implicit
6498 -- dereference can never assign to its prefix). The Comes_From_Source
6499 -- attribute needs to be propagated for accurate warnings.
6501 Ref
:= New_Reference_To
(E
, Sloc
(P
));
6502 Set_Comes_From_Source
(Ref
, Comes_From_Source
(P
));
6503 Generate_Reference
(E
, Ref
);
6506 -- An implicit dereference is a legal occurrence of an
6507 -- incomplete type imported through a limited_with clause,
6508 -- if the full view is visible.
6510 if From_With_Type
(Typ
)
6511 and then not From_With_Type
(Scope
(Typ
))
6513 (Is_Immediately_Visible
(Scope
(Typ
))
6515 (Is_Child_Unit
(Scope
(Typ
))
6516 and then Is_Visible_Lib_Unit
(Scope
(Typ
))))
6518 return Available_View
(Typ
);
6522 end Process_Implicit_Dereference_Prefix
;
6524 --------------------------------
6525 -- Remove_Abstract_Operations --
6526 --------------------------------
6528 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
6529 Abstract_Op
: Entity_Id
:= Empty
;
6530 Address_Kludge
: Boolean := False;
6534 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
6535 -- activate this if either extensions are enabled, or if the abstract
6536 -- operation in question comes from a predefined file. This latter test
6537 -- allows us to use abstract to make operations invisible to users. In
6538 -- particular, if type Address is non-private and abstract subprograms
6539 -- are used to hide its operators, they will be truly hidden.
6541 type Operand_Position
is (First_Op
, Second_Op
);
6542 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
6544 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
6545 -- Ambiguities may arise when the operands are literal and the address
6546 -- operations in s-auxdec are visible. In that case, remove the
6547 -- interpretation of a literal as Address, to retain the semantics of
6548 -- Address as a private type.
6550 ------------------------------------
6551 -- Remove_Address_Interpretations --
6552 ------------------------------------
6554 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
6558 if Is_Overloaded
(N
) then
6559 Get_First_Interp
(N
, I
, It
);
6560 while Present
(It
.Nam
) loop
6561 Formal
:= First_Entity
(It
.Nam
);
6563 if Op
= Second_Op
then
6564 Formal
:= Next_Entity
(Formal
);
6567 if Is_Descendent_Of_Address
(Etype
(Formal
)) then
6568 Address_Kludge
:= True;
6572 Get_Next_Interp
(I
, It
);
6575 end Remove_Address_Interpretations
;
6577 -- Start of processing for Remove_Abstract_Operations
6580 if Is_Overloaded
(N
) then
6581 if Debug_Flag_V
then
6582 Write_Str
("Remove_Abstract_Operations: ");
6583 Write_Overloads
(N
);
6586 Get_First_Interp
(N
, I
, It
);
6588 while Present
(It
.Nam
) loop
6589 if Is_Overloadable
(It
.Nam
)
6590 and then Is_Abstract_Subprogram
(It
.Nam
)
6591 and then not Is_Dispatching_Operation
(It
.Nam
)
6593 Abstract_Op
:= It
.Nam
;
6595 if Is_Descendent_Of_Address
(It
.Typ
) then
6596 Address_Kludge
:= True;
6600 -- In Ada 2005, this operation does not participate in overload
6601 -- resolution. If the operation is defined in a predefined
6602 -- unit, it is one of the operations declared abstract in some
6603 -- variants of System, and it must be removed as well.
6605 elsif Ada_Version
>= Ada_2005
6606 or else Is_Predefined_File_Name
6607 (Unit_File_Name
(Get_Source_Unit
(It
.Nam
)))
6614 Get_Next_Interp
(I
, It
);
6617 if No
(Abstract_Op
) then
6619 -- If some interpretation yields an integer type, it is still
6620 -- possible that there are address interpretations. Remove them
6621 -- if one operand is a literal, to avoid spurious ambiguities
6622 -- on systems where Address is a visible integer type.
6624 if Is_Overloaded
(N
)
6625 and then Nkind
(N
) in N_Op
6626 and then Is_Integer_Type
(Etype
(N
))
6628 if Nkind
(N
) in N_Binary_Op
then
6629 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
6630 Remove_Address_Interpretations
(Second_Op
);
6632 elsif Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
6633 Remove_Address_Interpretations
(First_Op
);
6638 elsif Nkind
(N
) in N_Op
then
6640 -- Remove interpretations that treat literals as addresses. This
6641 -- is never appropriate, even when Address is defined as a visible
6642 -- Integer type. The reason is that we would really prefer Address
6643 -- to behave as a private type, even in this case, which is there
6644 -- only to accommodate oddities of VMS address sizes. If Address
6645 -- is a visible integer type, we get lots of overload ambiguities.
6647 if Nkind
(N
) in N_Binary_Op
then
6649 U1
: constant Boolean :=
6650 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
6651 U2
: constant Boolean :=
6652 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
6656 Remove_Address_Interpretations
(Second_Op
);
6660 Remove_Address_Interpretations
(First_Op
);
6663 if not (U1
and U2
) then
6665 -- Remove corresponding predefined operator, which is
6666 -- always added to the overload set.
6668 Get_First_Interp
(N
, I
, It
);
6669 while Present
(It
.Nam
) loop
6670 if Scope
(It
.Nam
) = Standard_Standard
6671 and then Base_Type
(It
.Typ
) =
6672 Base_Type
(Etype
(Abstract_Op
))
6677 Get_Next_Interp
(I
, It
);
6680 elsif Is_Overloaded
(N
)
6681 and then Present
(Univ_Type
)
6683 -- If both operands have a universal interpretation,
6684 -- it is still necessary to remove interpretations that
6685 -- yield Address. Any remaining ambiguities will be
6686 -- removed in Disambiguate.
6688 Get_First_Interp
(N
, I
, It
);
6689 while Present
(It
.Nam
) loop
6690 if Is_Descendent_Of_Address
(It
.Typ
) then
6693 elsif not Is_Type
(It
.Nam
) then
6694 Set_Entity
(N
, It
.Nam
);
6697 Get_Next_Interp
(I
, It
);
6703 elsif Nkind
(N
) = N_Function_Call
6705 (Nkind
(Name
(N
)) = N_Operator_Symbol
6707 (Nkind
(Name
(N
)) = N_Expanded_Name
6709 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
6713 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
6714 U1
: constant Boolean :=
6715 Present
(Universal_Interpretation
(Arg1
));
6716 U2
: constant Boolean :=
6717 Present
(Next
(Arg1
)) and then
6718 Present
(Universal_Interpretation
(Next
(Arg1
)));
6722 Remove_Address_Interpretations
(First_Op
);
6726 Remove_Address_Interpretations
(Second_Op
);
6729 if not (U1
and U2
) then
6730 Get_First_Interp
(N
, I
, It
);
6731 while Present
(It
.Nam
) loop
6732 if Scope
(It
.Nam
) = Standard_Standard
6733 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
6738 Get_Next_Interp
(I
, It
);
6744 -- If the removal has left no valid interpretations, emit an error
6745 -- message now and label node as illegal.
6747 if Present
(Abstract_Op
) then
6748 Get_First_Interp
(N
, I
, It
);
6752 -- Removal of abstract operation left no viable candidate
6754 Set_Etype
(N
, Any_Type
);
6755 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
6757 ("cannot call abstract operation& declared#", N
, Abstract_Op
);
6759 -- In Ada 2005, an abstract operation may disable predefined
6760 -- operators. Since the context is not yet known, we mark the
6761 -- predefined operators as potentially hidden. Do not include
6762 -- predefined operators when addresses are involved since this
6763 -- case is handled separately.
6765 elsif Ada_Version
>= Ada_2005
6766 and then not Address_Kludge
6768 while Present
(It
.Nam
) loop
6769 if Is_Numeric_Type
(It
.Typ
)
6770 and then Scope
(It
.Typ
) = Standard_Standard
6772 Set_Abstract_Op
(I
, Abstract_Op
);
6775 Get_Next_Interp
(I
, It
);
6780 if Debug_Flag_V
then
6781 Write_Str
("Remove_Abstract_Operations done: ");
6782 Write_Overloads
(N
);
6785 end Remove_Abstract_Operations
;
6787 ----------------------------
6788 -- Try_Container_Indexing --
6789 ----------------------------
6791 function Try_Container_Indexing
6794 Exprs
: List_Id
) return Boolean
6796 Loc
: constant Source_Ptr
:= Sloc
(N
);
6800 Func_Name
: Node_Id
;
6805 -- Check whether type has a specified indexing aspect
6809 if Is_Variable
(Prefix
) then
6811 Find_Value_Of_Aspect
(Etype
(Prefix
), Aspect_Variable_Indexing
);
6814 if No
(Func_Name
) then
6816 Find_Value_Of_Aspect
(Etype
(Prefix
), Aspect_Constant_Indexing
);
6819 -- If aspect does not exist the expression is illegal. Error is
6820 -- diagnosed in caller.
6822 if No
(Func_Name
) then
6824 -- The prefix itself may be an indexing of a container
6825 -- rewrite as such and re-analyze.
6827 if Has_Implicit_Dereference
(Etype
(Prefix
)) then
6828 Build_Explicit_Dereference
6829 (Prefix
, First_Discriminant
(Etype
(Prefix
)));
6830 return Try_Container_Indexing
(N
, Prefix
, Exprs
);
6837 Assoc
:= New_List
(Relocate_Node
(Prefix
));
6839 -- A generalized iterator may have nore than one index expression, so
6840 -- transfer all of them to the argument list to be used in the call.
6845 Arg
:= First
(Exprs
);
6846 while Present
(Arg
) loop
6847 Append
(Relocate_Node
(Arg
), Assoc
);
6852 if not Is_Overloaded
(Func_Name
) then
6853 Func
:= Entity
(Func_Name
);
6855 Make_Function_Call
(Loc
,
6856 Name
=> New_Occurrence_Of
(Func
, Loc
),
6857 Parameter_Associations
=> Assoc
);
6858 Rewrite
(N
, Indexing
);
6861 -- If the return type of the indexing function is a reference type,
6862 -- add the dereference as a possible interpretation. Note that the
6863 -- indexing aspect may be a function that returns the element type
6864 -- with no intervening implicit dereference.
6866 if Has_Discriminants
(Etype
(Func
)) then
6867 Disc
:= First_Discriminant
(Etype
(Func
));
6868 while Present
(Disc
) loop
6869 if Has_Implicit_Dereference
(Disc
) then
6870 Add_One_Interp
(N
, Disc
, Designated_Type
(Etype
(Disc
)));
6874 Next_Discriminant
(Disc
);
6879 Indexing
:= Make_Function_Call
(Loc
,
6880 Name
=> Make_Identifier
(Loc
, Chars
(Func_Name
)),
6881 Parameter_Associations
=> Assoc
);
6883 Rewrite
(N
, Indexing
);
6891 Get_First_Interp
(Func_Name
, I
, It
);
6892 Set_Etype
(N
, Any_Type
);
6893 while Present
(It
.Nam
) loop
6894 Analyze_One_Call
(N
, It
.Nam
, False, Success
);
6896 Set_Etype
(Name
(N
), It
.Typ
);
6897 Set_Entity
(Name
(N
), It
.Nam
);
6899 -- Add implicit dereference interpretation
6901 if Has_Discriminants
(Etype
(It
.Nam
)) then
6902 Disc
:= First_Discriminant
(Etype
(It
.Nam
));
6903 while Present
(Disc
) loop
6904 if Has_Implicit_Dereference
(Disc
) then
6906 (N
, Disc
, Designated_Type
(Etype
(Disc
)));
6910 Next_Discriminant
(Disc
);
6916 Get_Next_Interp
(I
, It
);
6921 if Etype
(N
) = Any_Type
then
6923 ("container cannot be indexed with&", N
, Etype
(First
(Exprs
)));
6924 Rewrite
(N
, New_Occurrence_Of
(Any_Id
, Loc
));
6930 end Try_Container_Indexing
;
6932 -----------------------
6933 -- Try_Indirect_Call --
6934 -----------------------
6936 function Try_Indirect_Call
6939 Typ
: Entity_Id
) return Boolean
6945 pragma Warnings
(Off
, Call_OK
);
6948 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
6950 Actual
:= First_Actual
(N
);
6951 Formal
:= First_Formal
(Designated_Type
(Typ
));
6952 while Present
(Actual
) and then Present
(Formal
) loop
6953 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
6958 Next_Formal
(Formal
);
6961 if No
(Actual
) and then No
(Formal
) then
6962 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
6964 -- Nam is a candidate interpretation for the name in the call,
6965 -- if it is not an indirect call.
6967 if not Is_Type
(Nam
)
6968 and then Is_Entity_Name
(Name
(N
))
6970 Set_Entity
(Name
(N
), Nam
);
6977 end Try_Indirect_Call
;
6979 ----------------------
6980 -- Try_Indexed_Call --
6981 ----------------------
6983 function Try_Indexed_Call
6987 Skip_First
: Boolean) return Boolean
6989 Loc
: constant Source_Ptr
:= Sloc
(N
);
6990 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
6995 Actual
:= First
(Actuals
);
6997 -- If the call was originally written in prefix form, skip the first
6998 -- actual, which is obviously not defaulted.
7004 Index
:= First_Index
(Typ
);
7005 while Present
(Actual
) and then Present
(Index
) loop
7007 -- If the parameter list has a named association, the expression
7008 -- is definitely a call and not an indexed component.
7010 if Nkind
(Actual
) = N_Parameter_Association
then
7014 if Is_Entity_Name
(Actual
)
7015 and then Is_Type
(Entity
(Actual
))
7016 and then No
(Next
(Actual
))
7018 -- A single actual that is a type name indicates a slice if the
7019 -- type is discrete, and an error otherwise.
7021 if Is_Discrete_Type
(Entity
(Actual
)) then
7025 Make_Function_Call
(Loc
,
7026 Name
=> Relocate_Node
(Name
(N
))),
7028 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
7033 Error_Msg_N
("invalid use of type in expression", Actual
);
7034 Set_Etype
(N
, Any_Type
);
7039 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
7047 if No
(Actual
) and then No
(Index
) then
7048 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
7050 -- Nam is a candidate interpretation for the name in the call,
7051 -- if it is not an indirect call.
7053 if not Is_Type
(Nam
)
7054 and then Is_Entity_Name
(Name
(N
))
7056 Set_Entity
(Name
(N
), Nam
);
7063 end Try_Indexed_Call
;
7065 --------------------------
7066 -- Try_Object_Operation --
7067 --------------------------
7069 function Try_Object_Operation
7070 (N
: Node_Id
; CW_Test_Only
: Boolean := False) return Boolean
7072 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
7073 Is_Subprg_Call
: constant Boolean := K
in N_Subprogram_Call
;
7074 Loc
: constant Source_Ptr
:= Sloc
(N
);
7075 Obj
: constant Node_Id
:= Prefix
(N
);
7077 Subprog
: constant Node_Id
:=
7078 Make_Identifier
(Sloc
(Selector_Name
(N
)),
7079 Chars
=> Chars
(Selector_Name
(N
)));
7080 -- Identifier on which possible interpretations will be collected
7082 Report_Error
: Boolean := False;
7083 -- If no candidate interpretation matches the context, redo the
7084 -- analysis with error enabled to provide additional information.
7087 Candidate
: Entity_Id
:= Empty
;
7088 New_Call_Node
: Node_Id
:= Empty
;
7089 Node_To_Replace
: Node_Id
;
7090 Obj_Type
: Entity_Id
:= Etype
(Obj
);
7091 Success
: Boolean := False;
7093 function Valid_Candidate
7096 Subp
: Entity_Id
) return Entity_Id
;
7097 -- If the subprogram is a valid interpretation, record it, and add
7098 -- to the list of interpretations of Subprog. Otherwise return Empty.
7100 procedure Complete_Object_Operation
7101 (Call_Node
: Node_Id
;
7102 Node_To_Replace
: Node_Id
);
7103 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
7104 -- Call_Node, insert the object (or its dereference) as the first actual
7105 -- in the call, and complete the analysis of the call.
7107 procedure Report_Ambiguity
(Op
: Entity_Id
);
7108 -- If a prefixed procedure call is ambiguous, indicate whether the
7109 -- call includes an implicit dereference or an implicit 'Access.
7111 procedure Transform_Object_Operation
7112 (Call_Node
: out Node_Id
;
7113 Node_To_Replace
: out Node_Id
);
7114 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
7115 -- Call_Node is the resulting subprogram call, Node_To_Replace is
7116 -- either N or the parent of N, and Subprog is a reference to the
7117 -- subprogram we are trying to match.
7119 function Try_Class_Wide_Operation
7120 (Call_Node
: Node_Id
;
7121 Node_To_Replace
: Node_Id
) return Boolean;
7122 -- Traverse all ancestor types looking for a class-wide subprogram
7123 -- for which the current operation is a valid non-dispatching call.
7125 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
7126 -- If prefix is overloaded, its interpretation may include different
7127 -- tagged types, and we must examine the primitive operations and
7128 -- the class-wide operations of each in order to find candidate
7129 -- interpretations for the call as a whole.
7131 function Try_Primitive_Operation
7132 (Call_Node
: Node_Id
;
7133 Node_To_Replace
: Node_Id
) return Boolean;
7134 -- Traverse the list of primitive subprograms looking for a dispatching
7135 -- operation for which the current node is a valid call .
7137 ---------------------
7138 -- Valid_Candidate --
7139 ---------------------
7141 function Valid_Candidate
7144 Subp
: Entity_Id
) return Entity_Id
7146 Arr_Type
: Entity_Id
;
7147 Comp_Type
: Entity_Id
;
7150 -- If the subprogram is a valid interpretation, record it in global
7151 -- variable Subprog, to collect all possible overloadings.
7154 if Subp
/= Entity
(Subprog
) then
7155 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
7159 -- If the call may be an indexed call, retrieve component type of
7160 -- resulting expression, and add possible interpretation.
7165 if Nkind
(Call
) = N_Function_Call
7166 and then Nkind
(Parent
(N
)) = N_Indexed_Component
7167 and then Needs_One_Actual
(Subp
)
7169 if Is_Array_Type
(Etype
(Subp
)) then
7170 Arr_Type
:= Etype
(Subp
);
7172 elsif Is_Access_Type
(Etype
(Subp
))
7173 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
7175 Arr_Type
:= Designated_Type
(Etype
(Subp
));
7179 if Present
(Arr_Type
) then
7181 -- Verify that the actuals (excluding the object) match the types
7189 Actual
:= Next
(First_Actual
(Call
));
7190 Index
:= First_Index
(Arr_Type
);
7191 while Present
(Actual
) and then Present
(Index
) loop
7192 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
7197 Next_Actual
(Actual
);
7203 and then Present
(Arr_Type
)
7205 Comp_Type
:= Component_Type
(Arr_Type
);
7209 if Present
(Comp_Type
)
7210 and then Etype
(Subprog
) /= Comp_Type
7212 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
7216 if Etype
(Call
) /= Any_Type
then
7221 end Valid_Candidate
;
7223 -------------------------------
7224 -- Complete_Object_Operation --
7225 -------------------------------
7227 procedure Complete_Object_Operation
7228 (Call_Node
: Node_Id
;
7229 Node_To_Replace
: Node_Id
)
7231 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
7232 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
7233 First_Actual
: Node_Id
;
7236 -- Place the name of the operation, with its interpretations,
7237 -- on the rewritten call.
7239 Set_Name
(Call_Node
, Subprog
);
7241 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
7243 -- For cross-reference purposes, treat the new node as being in
7244 -- the source if the original one is. Set entity and type, even
7245 -- though they may be overwritten during resolution if overloaded.
7247 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
7248 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
7250 if Nkind
(N
) = N_Selected_Component
7251 and then not Inside_A_Generic
7253 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
7254 Set_Etype
(Selector_Name
(N
), Etype
(Entity
(Subprog
)));
7257 -- If need be, rewrite first actual as an explicit dereference
7258 -- If the call is overloaded, the rewriting can only be done
7259 -- once the primitive operation is identified.
7261 if Is_Overloaded
(Subprog
) then
7263 -- The prefix itself may be overloaded, and its interpretations
7264 -- must be propagated to the new actual in the call.
7266 if Is_Overloaded
(Obj
) then
7267 Save_Interps
(Obj
, First_Actual
);
7270 Rewrite
(First_Actual
, Obj
);
7272 elsif not Is_Access_Type
(Formal_Type
)
7273 and then Is_Access_Type
(Etype
(Obj
))
7275 Rewrite
(First_Actual
,
7276 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
7277 Analyze
(First_Actual
);
7279 -- If we need to introduce an explicit dereference, verify that
7280 -- the resulting actual is compatible with the mode of the formal.
7282 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
7283 and then Is_Access_Constant
(Etype
(Obj
))
7286 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
7289 -- Conversely, if the formal is an access parameter and the object
7290 -- is not, replace the actual with a 'Access reference. Its analysis
7291 -- will check that the object is aliased.
7293 elsif Is_Access_Type
(Formal_Type
)
7294 and then not Is_Access_Type
(Etype
(Obj
))
7296 -- A special case: A.all'access is illegal if A is an access to a
7297 -- constant and the context requires an access to a variable.
7299 if not Is_Access_Constant
(Formal_Type
) then
7300 if (Nkind
(Obj
) = N_Explicit_Dereference
7301 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
7302 or else not Is_Variable
(Obj
)
7305 ("actual for& must be a variable", Obj
, Control
);
7309 Rewrite
(First_Actual
,
7310 Make_Attribute_Reference
(Loc
,
7311 Attribute_Name
=> Name_Access
,
7312 Prefix
=> Relocate_Node
(Obj
)));
7314 if not Is_Aliased_View
(Obj
) then
7316 ("object in prefixed call to& must be aliased"
7317 & " (RM-2005 4.3.1 (13))",
7318 Prefix
(First_Actual
), Subprog
);
7321 Analyze
(First_Actual
);
7324 if Is_Overloaded
(Obj
) then
7325 Save_Interps
(Obj
, First_Actual
);
7328 Rewrite
(First_Actual
, Obj
);
7331 Rewrite
(Node_To_Replace
, Call_Node
);
7333 -- Propagate the interpretations collected in subprog to the new
7334 -- function call node, to be resolved from context.
7336 if Is_Overloaded
(Subprog
) then
7337 Save_Interps
(Subprog
, Node_To_Replace
);
7340 Analyze
(Node_To_Replace
);
7342 -- If the operation has been rewritten into a call, which may get
7343 -- subsequently an explicit dereference, preserve the type on the
7344 -- original node (selected component or indexed component) for
7345 -- subsequent legality tests, e.g. Is_Variable. which examines
7346 -- the original node.
7348 if Nkind
(Node_To_Replace
) = N_Function_Call
then
7350 (Original_Node
(Node_To_Replace
), Etype
(Node_To_Replace
));
7353 end Complete_Object_Operation
;
7355 ----------------------
7356 -- Report_Ambiguity --
7357 ----------------------
7359 procedure Report_Ambiguity
(Op
: Entity_Id
) is
7360 Access_Actual
: constant Boolean :=
7361 Is_Access_Type
(Etype
(Prefix
(N
)));
7362 Access_Formal
: Boolean := False;
7365 Error_Msg_Sloc
:= Sloc
(Op
);
7367 if Present
(First_Formal
(Op
)) then
7368 Access_Formal
:= Is_Access_Type
(Etype
(First_Formal
(Op
)));
7371 if Access_Formal
and then not Access_Actual
then
7372 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7374 ("\possible interpretation"
7375 & " (inherited, with implicit 'Access) #", N
);
7378 ("\possible interpretation (with implicit 'Access) #", N
);
7381 elsif not Access_Formal
and then Access_Actual
then
7382 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7384 ("\possible interpretation"
7385 & " ( inherited, with implicit dereference) #", N
);
7388 ("\possible interpretation (with implicit dereference) #", N
);
7392 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7393 Error_Msg_N
("\possible interpretation (inherited)#", N
);
7395 Error_Msg_N
-- CODEFIX
7396 ("\possible interpretation#", N
);
7399 end Report_Ambiguity
;
7401 --------------------------------
7402 -- Transform_Object_Operation --
7403 --------------------------------
7405 procedure Transform_Object_Operation
7406 (Call_Node
: out Node_Id
;
7407 Node_To_Replace
: out Node_Id
)
7409 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
7410 -- Placeholder used as a first parameter in the call, replaced
7411 -- eventually by the proper object.
7413 Parent_Node
: constant Node_Id
:= Parent
(N
);
7419 -- Common case covering 1) Call to a procedure and 2) Call to a
7420 -- function that has some additional actuals.
7422 if Nkind
(Parent_Node
) in N_Subprogram_Call
7424 -- N is a selected component node containing the name of the
7425 -- subprogram. If N is not the name of the parent node we must
7426 -- not replace the parent node by the new construct. This case
7427 -- occurs when N is a parameterless call to a subprogram that
7428 -- is an actual parameter of a call to another subprogram. For
7430 -- Some_Subprogram (..., Obj.Operation, ...)
7432 and then Name
(Parent_Node
) = N
7434 Node_To_Replace
:= Parent_Node
;
7436 Actuals
:= Parameter_Associations
(Parent_Node
);
7438 if Present
(Actuals
) then
7439 Prepend
(Dummy
, Actuals
);
7441 Actuals
:= New_List
(Dummy
);
7444 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
7446 Make_Procedure_Call_Statement
(Loc
,
7447 Name
=> New_Copy
(Subprog
),
7448 Parameter_Associations
=> Actuals
);
7452 Make_Function_Call
(Loc
,
7453 Name
=> New_Copy
(Subprog
),
7454 Parameter_Associations
=> Actuals
);
7458 -- Before analysis, a function call appears as an indexed component
7459 -- if there are no named associations.
7461 elsif Nkind
(Parent_Node
) = N_Indexed_Component
7462 and then N
= Prefix
(Parent_Node
)
7464 Node_To_Replace
:= Parent_Node
;
7465 Actuals
:= Expressions
(Parent_Node
);
7467 Actual
:= First
(Actuals
);
7468 while Present
(Actual
) loop
7473 Prepend
(Dummy
, Actuals
);
7476 Make_Function_Call
(Loc
,
7477 Name
=> New_Copy
(Subprog
),
7478 Parameter_Associations
=> Actuals
);
7480 -- Parameterless call: Obj.F is rewritten as F (Obj)
7483 Node_To_Replace
:= N
;
7486 Make_Function_Call
(Loc
,
7487 Name
=> New_Copy
(Subprog
),
7488 Parameter_Associations
=> New_List
(Dummy
));
7490 end Transform_Object_Operation
;
7492 ------------------------------
7493 -- Try_Class_Wide_Operation --
7494 ------------------------------
7496 function Try_Class_Wide_Operation
7497 (Call_Node
: Node_Id
;
7498 Node_To_Replace
: Node_Id
) return Boolean
7500 Anc_Type
: Entity_Id
;
7501 Matching_Op
: Entity_Id
:= Empty
;
7504 procedure Traverse_Homonyms
7505 (Anc_Type
: Entity_Id
;
7506 Error
: out Boolean);
7507 -- Traverse the homonym chain of the subprogram searching for those
7508 -- homonyms whose first formal has the Anc_Type's class-wide type,
7509 -- or an anonymous access type designating the class-wide type. If
7510 -- an ambiguity is detected, then Error is set to True.
7512 procedure Traverse_Interfaces
7513 (Anc_Type
: Entity_Id
;
7514 Error
: out Boolean);
7515 -- Traverse the list of interfaces, if any, associated with Anc_Type
7516 -- and search for acceptable class-wide homonyms associated with each
7517 -- interface. If an ambiguity is detected, then Error is set to True.
7519 -----------------------
7520 -- Traverse_Homonyms --
7521 -----------------------
7523 procedure Traverse_Homonyms
7524 (Anc_Type
: Entity_Id
;
7525 Error
: out Boolean)
7527 Cls_Type
: Entity_Id
;
7535 Cls_Type
:= Class_Wide_Type
(Anc_Type
);
7537 Hom
:= Current_Entity
(Subprog
);
7539 -- Find a non-hidden operation whose first parameter is of the
7540 -- class-wide type, a subtype thereof, or an anonymous access
7541 -- to same. If in an instance, the operation can be considered
7542 -- even if hidden (it may be hidden because the instantiation is
7543 -- expanded after the containing package has been analyzed).
7545 while Present
(Hom
) loop
7546 if Ekind_In
(Hom
, E_Procedure
, E_Function
)
7547 and then (not Is_Hidden
(Hom
) or else In_Instance
)
7548 and then Scope
(Hom
) = Scope
(Anc_Type
)
7549 and then Present
(First_Formal
(Hom
))
7551 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
7553 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
7555 Ekind
(Etype
(First_Formal
(Hom
))) =
7556 E_Anonymous_Access_Type
7559 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
7562 -- If the context is a procedure call, ignore functions
7563 -- in the name of the call.
7565 if Ekind
(Hom
) = E_Function
7566 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
7567 and then N
= Name
(Parent
(N
))
7571 -- If the context is a function call, ignore procedures
7572 -- in the name of the call.
7574 elsif Ekind
(Hom
) = E_Procedure
7575 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
7580 Set_Etype
(Call_Node
, Any_Type
);
7581 Set_Is_Overloaded
(Call_Node
, False);
7584 if No
(Matching_Op
) then
7585 Hom_Ref
:= New_Reference_To
(Hom
, Sloc
(Subprog
));
7586 Set_Etype
(Call_Node
, Any_Type
);
7587 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
7589 Set_Name
(Call_Node
, Hom_Ref
);
7594 Report
=> Report_Error
,
7596 Skip_First
=> True);
7599 Valid_Candidate
(Success
, Call_Node
, Hom
);
7605 Report
=> Report_Error
,
7607 Skip_First
=> True);
7609 if Present
(Valid_Candidate
(Success
, Call_Node
, Hom
))
7610 and then Nkind
(Call_Node
) /= N_Function_Call
7612 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
7613 Report_Ambiguity
(Matching_Op
);
7614 Report_Ambiguity
(Hom
);
7622 Hom
:= Homonym
(Hom
);
7624 end Traverse_Homonyms
;
7626 -------------------------
7627 -- Traverse_Interfaces --
7628 -------------------------
7630 procedure Traverse_Interfaces
7631 (Anc_Type
: Entity_Id
;
7632 Error
: out Boolean)
7634 Intface_List
: constant List_Id
:=
7635 Abstract_Interface_List
(Anc_Type
);
7641 if Is_Non_Empty_List
(Intface_List
) then
7642 Intface
:= First
(Intface_List
);
7643 while Present
(Intface
) loop
7645 -- Look for acceptable class-wide homonyms associated with
7648 Traverse_Homonyms
(Etype
(Intface
), Error
);
7654 -- Continue the search by looking at each of the interface's
7655 -- associated interface ancestors.
7657 Traverse_Interfaces
(Etype
(Intface
), Error
);
7666 end Traverse_Interfaces
;
7668 -- Start of processing for Try_Class_Wide_Operation
7671 -- If we are searching only for conflicting class-wide subprograms
7672 -- then initialize directly Matching_Op with the target entity.
7674 if CW_Test_Only
then
7675 Matching_Op
:= Entity
(Selector_Name
(N
));
7678 -- Loop through ancestor types (including interfaces), traversing
7679 -- the homonym chain of the subprogram, trying out those homonyms
7680 -- whose first formal has the class-wide type of the ancestor, or
7681 -- an anonymous access type designating the class-wide type.
7683 Anc_Type
:= Obj_Type
;
7685 -- Look for a match among homonyms associated with the ancestor
7687 Traverse_Homonyms
(Anc_Type
, Error
);
7693 -- Continue the search for matches among homonyms associated with
7694 -- any interfaces implemented by the ancestor.
7696 Traverse_Interfaces
(Anc_Type
, Error
);
7702 exit when Etype
(Anc_Type
) = Anc_Type
;
7703 Anc_Type
:= Etype
(Anc_Type
);
7706 if Present
(Matching_Op
) then
7707 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
7710 return Present
(Matching_Op
);
7711 end Try_Class_Wide_Operation
;
7713 -----------------------------------
7714 -- Try_One_Prefix_Interpretation --
7715 -----------------------------------
7717 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
7721 if Is_Access_Type
(Obj_Type
) then
7722 Obj_Type
:= Designated_Type
(Obj_Type
);
7725 if Ekind
(Obj_Type
) = E_Private_Subtype
then
7726 Obj_Type
:= Base_Type
(Obj_Type
);
7729 if Is_Class_Wide_Type
(Obj_Type
) then
7730 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
7733 -- The type may have be obtained through a limited_with clause,
7734 -- in which case the primitive operations are available on its
7735 -- non-limited view. If still incomplete, retrieve full view.
7737 if Ekind
(Obj_Type
) = E_Incomplete_Type
7738 and then From_With_Type
(Obj_Type
)
7740 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
7743 -- If the object is not tagged, or the type is still an incomplete
7744 -- type, this is not a prefixed call.
7746 if not Is_Tagged_Type
(Obj_Type
)
7747 or else Is_Incomplete_Type
(Obj_Type
)
7753 Dup_Call_Node
: constant Node_Id
:= New_Copy
(New_Call_Node
);
7754 CW_Result
: Boolean;
7755 Prim_Result
: Boolean;
7756 pragma Unreferenced
(CW_Result
);
7759 if not CW_Test_Only
then
7761 Try_Primitive_Operation
7762 (Call_Node
=> New_Call_Node
,
7763 Node_To_Replace
=> Node_To_Replace
);
7766 -- Check if there is a class-wide subprogram covering the
7767 -- primitive. This check must be done even if a candidate
7768 -- was found in order to report ambiguous calls.
7770 if not (Prim_Result
) then
7772 Try_Class_Wide_Operation
7773 (Call_Node
=> New_Call_Node
,
7774 Node_To_Replace
=> Node_To_Replace
);
7776 -- If we found a primitive we search for class-wide subprograms
7777 -- using a duplicate of the call node (done to avoid missing its
7778 -- decoration if there is no ambiguity).
7782 Try_Class_Wide_Operation
7783 (Call_Node
=> Dup_Call_Node
,
7784 Node_To_Replace
=> Node_To_Replace
);
7787 end Try_One_Prefix_Interpretation
;
7789 -----------------------------
7790 -- Try_Primitive_Operation --
7791 -----------------------------
7793 function Try_Primitive_Operation
7794 (Call_Node
: Node_Id
;
7795 Node_To_Replace
: Node_Id
) return Boolean
7798 Prim_Op
: Entity_Id
;
7799 Matching_Op
: Entity_Id
:= Empty
;
7800 Prim_Op_Ref
: Node_Id
:= Empty
;
7802 Corr_Type
: Entity_Id
:= Empty
;
7803 -- If the prefix is a synchronized type, the controlling type of
7804 -- the primitive operation is the corresponding record type, else
7805 -- this is the object type itself.
7807 Success
: Boolean := False;
7809 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
7810 -- For tagged types the candidate interpretations are found in
7811 -- the list of primitive operations of the type and its ancestors.
7812 -- For formal tagged types we have to find the operations declared
7813 -- in the same scope as the type (including in the generic formal
7814 -- part) because the type itself carries no primitive operations,
7815 -- except for formal derived types that inherit the operations of
7816 -- the parent and progenitors.
7817 -- If the context is a generic subprogram body, the generic formals
7818 -- are visible by name, but are not in the entity list of the
7819 -- subprogram because that list starts with the subprogram formals.
7820 -- We retrieve the candidate operations from the generic declaration.
7822 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
7823 -- An operation that overrides an inherited operation in the private
7824 -- part of its package may be hidden, but if the inherited operation
7825 -- is visible a direct call to it will dispatch to the private one,
7826 -- which is therefore a valid candidate.
7828 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
7829 -- Verify that the prefix, dereferenced if need be, is a valid
7830 -- controlling argument in a call to Op. The remaining actuals
7831 -- are checked in the subsequent call to Analyze_One_Call.
7833 ------------------------------
7834 -- Collect_Generic_Type_Ops --
7835 ------------------------------
7837 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
7838 Bas
: constant Entity_Id
:= Base_Type
(T
);
7839 Candidates
: constant Elist_Id
:= New_Elmt_List
;
7843 procedure Check_Candidate
;
7844 -- The operation is a candidate if its first parameter is a
7845 -- controlling operand of the desired type.
7847 -----------------------
7848 -- Check_Candidate; --
7849 -----------------------
7851 procedure Check_Candidate
is
7853 Formal
:= First_Formal
(Subp
);
7856 and then Is_Controlling_Formal
(Formal
)
7858 (Base_Type
(Etype
(Formal
)) = Bas
7860 (Is_Access_Type
(Etype
(Formal
))
7861 and then Designated_Type
(Etype
(Formal
)) = Bas
))
7863 Append_Elmt
(Subp
, Candidates
);
7865 end Check_Candidate
;
7867 -- Start of processing for Collect_Generic_Type_Ops
7870 if Is_Derived_Type
(T
) then
7871 return Primitive_Operations
(T
);
7873 elsif Ekind_In
(Scope
(T
), E_Procedure
, E_Function
) then
7875 -- Scan the list of generic formals to find subprograms
7876 -- that may have a first controlling formal of the type.
7878 if Nkind
(Unit_Declaration_Node
(Scope
(T
)))
7879 = N_Generic_Subprogram_Declaration
7886 First
(Generic_Formal_Declarations
7887 (Unit_Declaration_Node
(Scope
(T
))));
7888 while Present
(Decl
) loop
7889 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
7890 Subp
:= Defining_Entity
(Decl
);
7901 -- Scan the list of entities declared in the same scope as
7902 -- the type. In general this will be an open scope, given that
7903 -- the call we are analyzing can only appear within a generic
7904 -- declaration or body (either the one that declares T, or a
7907 -- For a subtype representing a generic actual type, go to the
7910 if Is_Generic_Actual_Type
(T
) then
7911 Subp
:= First_Entity
(Scope
(Base_Type
(T
)));
7913 Subp
:= First_Entity
(Scope
(T
));
7916 while Present
(Subp
) loop
7917 if Is_Overloadable
(Subp
) then
7926 end Collect_Generic_Type_Ops
;
7928 ---------------------------
7929 -- Is_Private_Overriding --
7930 ---------------------------
7932 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
7933 Visible_Op
: constant Entity_Id
:= Homonym
(Op
);
7936 return Present
(Visible_Op
)
7937 and then Scope
(Op
) = Scope
(Visible_Op
)
7938 and then not Comes_From_Source
(Visible_Op
)
7939 and then Alias
(Visible_Op
) = Op
7940 and then not Is_Hidden
(Visible_Op
);
7941 end Is_Private_Overriding
;
7943 -----------------------------
7944 -- Valid_First_Argument_Of --
7945 -----------------------------
7947 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
7948 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
7951 if Is_Concurrent_Type
(Typ
)
7952 and then Present
(Corresponding_Record_Type
(Typ
))
7954 Typ
:= Corresponding_Record_Type
(Typ
);
7957 -- Simple case. Object may be a subtype of the tagged type or
7958 -- may be the corresponding record of a synchronized type.
7960 return Obj_Type
= Typ
7961 or else Base_Type
(Obj_Type
) = Typ
7962 or else Corr_Type
= Typ
7964 -- Prefix can be dereferenced
7967 (Is_Access_Type
(Corr_Type
)
7968 and then Designated_Type
(Corr_Type
) = Typ
)
7970 -- Formal is an access parameter, for which the object
7971 -- can provide an access.
7974 (Ekind
(Typ
) = E_Anonymous_Access_Type
7976 Base_Type
(Designated_Type
(Typ
)) = Base_Type
(Corr_Type
));
7977 end Valid_First_Argument_Of
;
7979 -- Start of processing for Try_Primitive_Operation
7982 -- Look for subprograms in the list of primitive operations. The name
7983 -- must be identical, and the kind of call indicates the expected
7984 -- kind of operation (function or procedure). If the type is a
7985 -- (tagged) synchronized type, the primitive ops are attached to the
7986 -- corresponding record (base) type.
7988 if Is_Concurrent_Type
(Obj_Type
) then
7989 if Present
(Corresponding_Record_Type
(Obj_Type
)) then
7990 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
7991 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
7993 Corr_Type
:= Obj_Type
;
7994 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
7997 elsif not Is_Generic_Type
(Obj_Type
) then
7998 Corr_Type
:= Obj_Type
;
7999 Elmt
:= First_Elmt
(Primitive_Operations
(Obj_Type
));
8002 Corr_Type
:= Obj_Type
;
8003 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
8006 while Present
(Elmt
) loop
8007 Prim_Op
:= Node
(Elmt
);
8009 if Chars
(Prim_Op
) = Chars
(Subprog
)
8010 and then Present
(First_Formal
(Prim_Op
))
8011 and then Valid_First_Argument_Of
(Prim_Op
)
8013 (Nkind
(Call_Node
) = N_Function_Call
)
8014 = (Ekind
(Prim_Op
) = E_Function
)
8016 -- Ada 2005 (AI-251): If this primitive operation corresponds
8017 -- with an immediate ancestor interface there is no need to add
8018 -- it to the list of interpretations; the corresponding aliased
8019 -- primitive is also in this list of primitive operations and
8020 -- will be used instead.
8022 if (Present
(Interface_Alias
(Prim_Op
))
8023 and then Is_Ancestor
(Find_Dispatching_Type
8024 (Alias
(Prim_Op
)), Corr_Type
))
8026 -- Do not consider hidden primitives unless the type is in an
8027 -- open scope or we are within an instance, where visibility
8028 -- is known to be correct, or else if this is an overriding
8029 -- operation in the private part for an inherited operation.
8031 or else (Is_Hidden
(Prim_Op
)
8032 and then not Is_Immediately_Visible
(Obj_Type
)
8033 and then not In_Instance
8034 and then not Is_Private_Overriding
(Prim_Op
))
8039 Set_Etype
(Call_Node
, Any_Type
);
8040 Set_Is_Overloaded
(Call_Node
, False);
8042 if No
(Matching_Op
) then
8043 Prim_Op_Ref
:= New_Reference_To
(Prim_Op
, Sloc
(Subprog
));
8044 Candidate
:= Prim_Op
;
8046 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
8048 Set_Name
(Call_Node
, Prim_Op_Ref
);
8054 Report
=> Report_Error
,
8056 Skip_First
=> True);
8058 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
8060 -- More than one interpretation, collect for subsequent
8061 -- disambiguation. If this is a procedure call and there
8062 -- is another match, report ambiguity now.
8068 Report
=> Report_Error
,
8070 Skip_First
=> True);
8072 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
8073 and then Nkind
(Call_Node
) /= N_Function_Call
8075 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
8076 Report_Ambiguity
(Matching_Op
);
8077 Report_Ambiguity
(Prim_Op
);
8087 if Present
(Matching_Op
) then
8088 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
8091 return Present
(Matching_Op
);
8092 end Try_Primitive_Operation
;
8094 -- Start of processing for Try_Object_Operation
8097 Analyze_Expression
(Obj
);
8099 -- Analyze the actuals if node is known to be a subprogram call
8101 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
8102 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
8103 while Present
(Actual
) loop
8104 Analyze_Expression
(Actual
);
8109 -- Build a subprogram call node, using a copy of Obj as its first
8110 -- actual. This is a placeholder, to be replaced by an explicit
8111 -- dereference when needed.
8113 Transform_Object_Operation
8114 (Call_Node
=> New_Call_Node
,
8115 Node_To_Replace
=> Node_To_Replace
);
8117 Set_Etype
(New_Call_Node
, Any_Type
);
8118 Set_Etype
(Subprog
, Any_Type
);
8119 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
8121 if not Is_Overloaded
(Obj
) then
8122 Try_One_Prefix_Interpretation
(Obj_Type
);
8129 Get_First_Interp
(Obj
, I
, It
);
8130 while Present
(It
.Nam
) loop
8131 Try_One_Prefix_Interpretation
(It
.Typ
);
8132 Get_Next_Interp
(I
, It
);
8137 if Etype
(New_Call_Node
) /= Any_Type
then
8139 -- No need to complete the tree transformations if we are only
8140 -- searching for conflicting class-wide subprograms
8142 if CW_Test_Only
then
8145 Complete_Object_Operation
8146 (Call_Node
=> New_Call_Node
,
8147 Node_To_Replace
=> Node_To_Replace
);
8151 elsif Present
(Candidate
) then
8153 -- The argument list is not type correct. Re-analyze with error
8154 -- reporting enabled, and use one of the possible candidates.
8155 -- In All_Errors_Mode, re-analyze all failed interpretations.
8157 if All_Errors_Mode
then
8158 Report_Error
:= True;
8159 if Try_Primitive_Operation
8160 (Call_Node
=> New_Call_Node
,
8161 Node_To_Replace
=> Node_To_Replace
)
8164 Try_Class_Wide_Operation
8165 (Call_Node
=> New_Call_Node
,
8166 Node_To_Replace
=> Node_To_Replace
)
8173 (N
=> New_Call_Node
,
8177 Skip_First
=> True);
8180 -- No need for further errors
8185 -- There was no candidate operation, so report it as an error
8186 -- in the caller: Analyze_Selected_Component.
8190 end Try_Object_Operation
;
8196 procedure wpo
(T
: Entity_Id
) is
8201 if not Is_Tagged_Type
(T
) then
8205 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
8206 while Present
(E
) loop
8208 Write_Int
(Int
(Op
));
8209 Write_Str
(" === ");
8210 Write_Name
(Chars
(Op
));
8212 Write_Name
(Chars
(Scope
(Op
)));