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_Allocators_After_Elaboration, loop to look at
417 -- enclosing context, checking task case and 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
434 Check_Restriction
(No_Allocators_After_Elaboration
, N
);
438 -- The other case is appearance in a subprogram body. This may
439 -- be a violation if this is a library level subprogram, and it
440 -- turns out to be used as the main program, but only the
441 -- binder knows that, so just record the occurrence.
443 if Nkind
(Original_Node
(Parent
(P
))) = N_Subprogram_Body
444 and then Nkind
(Parent
(Parent
(P
))) = N_Compilation_Unit
446 Set_Has_Allocator
(Current_Sem_Unit
);
455 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
456 -- any. The expected type for the name is any type. A non-overloading
457 -- rule then requires it to be of a type descended from
458 -- System.Storage_Pools.Subpools.Subpool_Handle.
460 -- This isn't exactly what the AI says, but it seems to be the right
461 -- rule. The AI should be fixed.???
464 Subpool
: constant Node_Id
:= Subpool_Handle_Name
(N
);
467 if Present
(Subpool
) then
470 if Is_Overloaded
(Subpool
) then
471 Error_Msg_N
("ambiguous subpool handle", Subpool
);
474 -- Check that Etype (Subpool) is descended from Subpool_Handle
480 -- Analyze the qualified expression or subtype indication
482 if Nkind
(E
) = N_Qualified_Expression
then
483 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
484 Set_Etype
(Acc_Type
, Acc_Type
);
485 Find_Type
(Subtype_Mark
(E
));
487 -- Analyze the qualified expression, and apply the name resolution
488 -- rule given in 4.7(3).
491 Type_Id
:= Etype
(E
);
492 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
494 Resolve
(Expression
(E
), Type_Id
);
496 -- Allocators generated by the build-in-place expansion mechanism
497 -- are explicitly marked as coming from source but do not need to be
498 -- checked for limited initialization. To exclude this case, ensure
499 -- that the parent of the allocator is a source node.
501 if Is_Limited_Type
(Type_Id
)
502 and then Comes_From_Source
(N
)
503 and then Comes_From_Source
(Parent
(N
))
504 and then not In_Instance_Body
506 if not OK_For_Limited_Init
(Type_Id
, Expression
(E
)) then
507 Error_Msg_N
("initialization not allowed for limited types", N
);
508 Explain_Limited_Type
(Type_Id
, N
);
512 -- A qualified expression requires an exact match of the type,
513 -- class-wide matching is not allowed.
515 -- if Is_Class_Wide_Type (Type_Id)
516 -- and then Base_Type
517 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
519 -- Wrong_Type (Expression (E), Type_Id);
522 Check_Non_Static_Context
(Expression
(E
));
524 -- We don't analyze the qualified expression itself because it's
525 -- part of the allocator
527 Set_Etype
(E
, Type_Id
);
529 -- Case where allocator has a subtype indication
534 Base_Typ
: Entity_Id
;
537 -- If the allocator includes a N_Subtype_Indication then a
538 -- constraint is present, otherwise the node is a subtype mark.
539 -- Introduce an explicit subtype declaration into the tree
540 -- defining some anonymous subtype and rewrite the allocator to
541 -- use this subtype rather than the subtype indication.
543 -- It is important to introduce the explicit subtype declaration
544 -- so that the bounds of the subtype indication are attached to
545 -- the tree in case the allocator is inside a generic unit.
547 if Nkind
(E
) = N_Subtype_Indication
then
549 -- A constraint is only allowed for a composite type in Ada
550 -- 95. In Ada 83, a constraint is also allowed for an
551 -- access-to-composite type, but the constraint is ignored.
553 Find_Type
(Subtype_Mark
(E
));
554 Base_Typ
:= Entity
(Subtype_Mark
(E
));
556 if Is_Elementary_Type
(Base_Typ
) then
557 if not (Ada_Version
= Ada_83
558 and then Is_Access_Type
(Base_Typ
))
560 Error_Msg_N
("constraint not allowed here", E
);
562 if Nkind
(Constraint
(E
)) =
563 N_Index_Or_Discriminant_Constraint
565 Error_Msg_N
-- CODEFIX
566 ("\if qualified expression was meant, " &
567 "use apostrophe", Constraint
(E
));
571 -- Get rid of the bogus constraint:
573 Rewrite
(E
, New_Copy_Tree
(Subtype_Mark
(E
)));
574 Analyze_Allocator
(N
);
577 -- Ada 2005, AI-363: if the designated type has a constrained
578 -- partial view, it cannot receive a discriminant constraint,
579 -- and the allocated object is unconstrained.
581 elsif Ada_Version
>= Ada_2005
582 and then Effectively_Has_Constrained_Partial_View
584 Scop
=> Current_Scope
)
587 ("constraint not allowed when type " &
588 "has a constrained partial view", Constraint
(E
));
591 if Expander_Active
then
592 Def_Id
:= Make_Temporary
(Loc
, 'S');
595 Make_Subtype_Declaration
(Loc
,
596 Defining_Identifier
=> Def_Id
,
597 Subtype_Indication
=> Relocate_Node
(E
)));
599 if Sav_Errs
/= Serious_Errors_Detected
600 and then Nkind
(Constraint
(E
)) =
601 N_Index_Or_Discriminant_Constraint
603 Error_Msg_N
-- CODEFIX
604 ("if qualified expression was meant, " &
605 "use apostrophe!", Constraint
(E
));
608 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
609 Rewrite
(Expression
(N
), E
);
613 Type_Id
:= Process_Subtype
(E
, N
);
614 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
615 Set_Etype
(Acc_Type
, Acc_Type
);
616 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
617 Check_Fully_Declared
(Type_Id
, N
);
619 -- Ada 2005 (AI-231): If the designated type is itself an access
620 -- type that excludes null, its default initialization will
621 -- be a null object, and we can insert an unconditional raise
622 -- before the allocator.
624 -- Ada 2012 (AI-104): A not null indication here is altogether
627 if Can_Never_Be_Null
(Type_Id
) then
629 Not_Null_Check
: constant Node_Id
:=
630 Make_Raise_Constraint_Error
(Sloc
(E
),
631 Reason
=> CE_Null_Not_Allowed
);
634 if Expander_Active
then
635 Insert_Action
(N
, Not_Null_Check
);
636 Analyze
(Not_Null_Check
);
638 elsif Warn_On_Ada_2012_Compatibility
then
640 ("null value not allowed here in Ada 2012?y?", E
);
645 -- Check restriction against dynamically allocated protected
646 -- objects. Note that when limited aggregates are supported,
647 -- a similar test should be applied to an allocator with a
648 -- qualified expression ???
650 if Is_Protected_Type
(Type_Id
) then
651 Check_Restriction
(No_Protected_Type_Allocators
, N
);
654 -- Check for missing initialization. Skip this check if we already
655 -- had errors on analyzing the allocator, since in that case these
656 -- are probably cascaded errors.
658 if Is_Indefinite_Subtype
(Type_Id
)
659 and then Serious_Errors_Detected
= Sav_Errs
661 -- The build-in-place machinery may produce an allocator when
662 -- the designated type is indefinite but the underlying type is
663 -- not. In this case the unknown discriminants are meaningless
664 -- and should not trigger error messages. Check the parent node
665 -- because the allocator is marked as coming from source.
667 if Present
(Underlying_Type
(Type_Id
))
668 and then not Is_Indefinite_Subtype
(Underlying_Type
(Type_Id
))
669 and then not Comes_From_Source
(Parent
(N
))
673 elsif Is_Class_Wide_Type
(Type_Id
) then
675 ("initialization required in class-wide allocation", N
);
678 if Ada_Version
< Ada_2005
679 and then Is_Limited_Type
(Type_Id
)
681 Error_Msg_N
("unconstrained allocation not allowed", N
);
683 if Is_Array_Type
(Type_Id
) then
685 ("\constraint with array bounds required", N
);
687 elsif Has_Unknown_Discriminants
(Type_Id
) then
690 else pragma Assert
(Has_Discriminants
(Type_Id
));
692 ("\constraint with discriminant values required", N
);
695 -- Limited Ada 2005 and general non-limited case
699 ("uninitialized unconstrained allocation not allowed",
702 if Is_Array_Type
(Type_Id
) then
704 ("\qualified expression or constraint with " &
705 "array bounds required", N
);
707 elsif Has_Unknown_Discriminants
(Type_Id
) then
708 Error_Msg_N
("\qualified expression required", N
);
710 else pragma Assert
(Has_Discriminants
(Type_Id
));
712 ("\qualified expression or constraint with " &
713 "discriminant values required", N
);
721 if Is_Abstract_Type
(Type_Id
) then
722 Error_Msg_N
("cannot allocate abstract object", E
);
725 if Has_Task
(Designated_Type
(Acc_Type
)) then
726 Check_Restriction
(No_Tasking
, N
);
727 Check_Restriction
(Max_Tasks
, N
);
728 Check_Restriction
(No_Task_Allocators
, N
);
731 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
732 -- type is nested, and the designated type needs finalization. The rule
733 -- is conservative in that class-wide types need finalization.
735 if Needs_Finalization
(Designated_Type
(Acc_Type
))
736 and then not Is_Library_Level_Entity
(Acc_Type
)
738 Check_Restriction
(No_Nested_Finalization
, N
);
741 -- Check that an allocator of a nested access type doesn't create a
742 -- protected object when restriction No_Local_Protected_Objects applies.
743 -- We don't have an equivalent to Has_Task for protected types, so only
744 -- cases where the designated type itself is a protected type are
745 -- currently checked. ???
747 if Is_Protected_Type
(Designated_Type
(Acc_Type
))
748 and then not Is_Library_Level_Entity
(Acc_Type
)
750 Check_Restriction
(No_Local_Protected_Objects
, N
);
753 -- If the No_Streams restriction is set, check that the type of the
754 -- object is not, and does not contain, any subtype derived from
755 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
756 -- Has_Stream just for efficiency reasons. There is no point in
757 -- spending time on a Has_Stream check if the restriction is not set.
759 if Restriction_Check_Required
(No_Streams
) then
760 if Has_Stream
(Designated_Type
(Acc_Type
)) then
761 Check_Restriction
(No_Streams
, N
);
765 Set_Etype
(N
, Acc_Type
);
767 if not Is_Library_Level_Entity
(Acc_Type
) then
768 Check_Restriction
(No_Local_Allocators
, N
);
771 if Serious_Errors_Detected
> Sav_Errs
then
772 Set_Error_Posted
(N
);
773 Set_Etype
(N
, Any_Type
);
775 end Analyze_Allocator
;
777 ---------------------------
778 -- Analyze_Arithmetic_Op --
779 ---------------------------
781 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
782 L
: constant Node_Id
:= Left_Opnd
(N
);
783 R
: constant Node_Id
:= Right_Opnd
(N
);
787 Candidate_Type
:= Empty
;
788 Analyze_Expression
(L
);
789 Analyze_Expression
(R
);
791 -- If the entity is already set, the node is the instantiation of a
792 -- generic node with a non-local reference, or was manufactured by a
793 -- call to Make_Op_xxx. In either case the entity is known to be valid,
794 -- and we do not need to collect interpretations, instead we just get
795 -- the single possible interpretation.
799 if Present
(Op_Id
) then
800 if Ekind
(Op_Id
) = E_Operator
then
802 if Nkind_In
(N
, N_Op_Divide
, N_Op_Mod
, N_Op_Multiply
, N_Op_Rem
)
803 and then Treat_Fixed_As_Integer
(N
)
807 Set_Etype
(N
, Any_Type
);
808 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
812 Set_Etype
(N
, Any_Type
);
813 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
816 -- Entity is not already set, so we do need to collect interpretations
819 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
820 Set_Etype
(N
, Any_Type
);
822 while Present
(Op_Id
) loop
823 if Ekind
(Op_Id
) = E_Operator
824 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
826 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
828 -- The following may seem superfluous, because an operator cannot
829 -- be generic, but this ignores the cleverness of the author of
832 elsif Is_Overloadable
(Op_Id
) then
833 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
836 Op_Id
:= Homonym
(Op_Id
);
841 end Analyze_Arithmetic_Op
;
847 -- Function, procedure, and entry calls are checked here. The Name in
848 -- the call may be overloaded. The actuals have been analyzed and may
849 -- themselves be overloaded. On exit from this procedure, the node N
850 -- may have zero, one or more interpretations. In the first case an
851 -- error message is produced. In the last case, the node is flagged
852 -- as overloaded and the interpretations are collected in All_Interp.
854 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
855 -- the type-checking is similar to that of other calls.
857 procedure Analyze_Call
(N
: Node_Id
) is
858 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
863 Success
: Boolean := False;
865 Deref
: Boolean := False;
866 -- Flag indicates whether an interpretation of the prefix is a
867 -- parameterless call that returns an access_to_subprogram.
869 procedure Check_Mixed_Parameter_And_Named_Associations
;
870 -- Check that parameter and named associations are not mixed. This is
871 -- a restriction in SPARK mode.
873 function Name_Denotes_Function
return Boolean;
874 -- If the type of the name is an access to subprogram, this may be the
875 -- type of a name, or the return type of the function being called. If
876 -- the name is not an entity then it can denote a protected function.
877 -- Until we distinguish Etype from Return_Type, we must use this routine
878 -- to resolve the meaning of the name in the call.
880 procedure No_Interpretation
;
881 -- Output error message when no valid interpretation exists
883 --------------------------------------------------
884 -- Check_Mixed_Parameter_And_Named_Associations --
885 --------------------------------------------------
887 procedure Check_Mixed_Parameter_And_Named_Associations
is
889 Named_Seen
: Boolean;
894 Actual
:= First
(Actuals
);
895 while Present
(Actual
) loop
896 case Nkind
(Actual
) is
897 when N_Parameter_Association
=>
899 Check_SPARK_Restriction
900 ("named association cannot follow positional one",
910 end Check_Mixed_Parameter_And_Named_Associations
;
912 ---------------------------
913 -- Name_Denotes_Function --
914 ---------------------------
916 function Name_Denotes_Function
return Boolean is
918 if Is_Entity_Name
(Nam
) then
919 return Ekind
(Entity
(Nam
)) = E_Function
;
921 elsif Nkind
(Nam
) = N_Selected_Component
then
922 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
927 end Name_Denotes_Function
;
929 -----------------------
930 -- No_Interpretation --
931 -----------------------
933 procedure No_Interpretation
is
934 L
: constant Boolean := Is_List_Member
(N
);
935 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
938 -- If the node is in a list whose parent is not an expression then it
939 -- must be an attempted procedure call.
941 if L
and then K
not in N_Subexpr
then
942 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
944 ("must instantiate generic procedure& before call",
948 ("procedure or entry name expected", Nam
);
951 -- Check for tasking cases where only an entry call will do
954 and then Nkind_In
(K
, N_Entry_Call_Alternative
,
955 N_Triggering_Alternative
)
957 Error_Msg_N
("entry name expected", Nam
);
959 -- Otherwise give general error message
962 Error_Msg_N
("invalid prefix in call", Nam
);
964 end No_Interpretation
;
966 -- Start of processing for Analyze_Call
969 if Restriction_Check_Required
(SPARK
) then
970 Check_Mixed_Parameter_And_Named_Associations
;
973 -- Initialize the type of the result of the call to the error type,
974 -- which will be reset if the type is successfully resolved.
976 Set_Etype
(N
, Any_Type
);
980 if not Is_Overloaded
(Nam
) then
982 -- Only one interpretation to check
984 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
985 Nam_Ent
:= Etype
(Nam
);
987 -- If the prefix is an access_to_subprogram, this may be an indirect
988 -- call. This is the case if the name in the call is not an entity
989 -- name, or if it is a function name in the context of a procedure
990 -- call. In this latter case, we have a call to a parameterless
991 -- function that returns a pointer_to_procedure which is the entity
992 -- being called. Finally, F (X) may be a call to a parameterless
993 -- function that returns a pointer to a function with parameters.
995 elsif Is_Access_Type
(Etype
(Nam
))
996 and then Ekind
(Designated_Type
(Etype
(Nam
))) = E_Subprogram_Type
998 (not Name_Denotes_Function
999 or else Nkind
(N
) = N_Procedure_Call_Statement
1001 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1002 and then Is_Entity_Name
(Nam
)
1003 and then No
(First_Formal
(Entity
(Nam
)))
1004 and then Present
(Actuals
)))
1006 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
1007 Insert_Explicit_Dereference
(Nam
);
1009 -- Selected component case. Simple entry or protected operation,
1010 -- where the entry name is given by the selector name.
1012 elsif Nkind
(Nam
) = N_Selected_Component
then
1013 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
1015 if not Ekind_In
(Nam_Ent
, E_Entry
,
1020 Error_Msg_N
("name in call is not a callable entity", Nam
);
1021 Set_Etype
(N
, Any_Type
);
1025 -- If the name is an Indexed component, it can be a call to a member
1026 -- of an entry family. The prefix must be a selected component whose
1027 -- selector is the entry. Analyze_Procedure_Call normalizes several
1028 -- kinds of call into this form.
1030 elsif Nkind
(Nam
) = N_Indexed_Component
then
1031 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
1032 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
1034 Error_Msg_N
("name in call is not a callable entity", Nam
);
1035 Set_Etype
(N
, Any_Type
);
1039 elsif not Is_Entity_Name
(Nam
) then
1040 Error_Msg_N
("name in call is not a callable entity", Nam
);
1041 Set_Etype
(N
, Any_Type
);
1045 Nam_Ent
:= Entity
(Nam
);
1047 -- If no interpretations, give error message
1049 if not Is_Overloadable
(Nam_Ent
) then
1055 -- Operations generated for RACW stub types are called only through
1056 -- dispatching, and can never be the static interpretation of a call.
1058 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
1063 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
1065 -- If this is an indirect call, the return type of the access_to
1066 -- subprogram may be an incomplete type. At the point of the call,
1067 -- use the full type if available, and at the same time update the
1068 -- return type of the access_to_subprogram.
1071 and then Nkind
(Nam
) = N_Explicit_Dereference
1072 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
1073 and then Present
(Full_View
(Etype
(N
)))
1075 Set_Etype
(N
, Full_View
(Etype
(N
)));
1076 Set_Etype
(Nam_Ent
, Etype
(N
));
1080 -- An overloaded selected component must denote overloaded operations
1081 -- of a concurrent type. The interpretations are attached to the
1082 -- simple name of those operations.
1084 if Nkind
(Nam
) = N_Selected_Component
then
1085 Nam
:= Selector_Name
(Nam
);
1088 Get_First_Interp
(Nam
, X
, It
);
1090 while Present
(It
.Nam
) loop
1094 -- Name may be call that returns an access to subprogram, or more
1095 -- generally an overloaded expression one of whose interpretations
1096 -- yields an access to subprogram. If the name is an entity, we do
1097 -- not dereference, because the node is a call that returns the
1098 -- access type: note difference between f(x), where the call may
1099 -- return an access subprogram type, and f(x)(y), where the type
1100 -- returned by the call to f is implicitly dereferenced to analyze
1103 if Is_Access_Type
(Nam_Ent
) then
1104 Nam_Ent
:= Designated_Type
(Nam_Ent
);
1106 elsif Is_Access_Type
(Etype
(Nam_Ent
))
1108 (not Is_Entity_Name
(Nam
)
1109 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1110 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
1113 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
1115 if Is_Entity_Name
(Nam
) then
1120 -- If the call has been rewritten from a prefixed call, the first
1121 -- parameter has been analyzed, but may need a subsequent
1122 -- dereference, so skip its analysis now.
1124 if N
/= Original_Node
(N
)
1125 and then Nkind
(Original_Node
(N
)) = Nkind
(N
)
1126 and then Nkind
(Name
(N
)) /= Nkind
(Name
(Original_Node
(N
)))
1127 and then Present
(Parameter_Associations
(N
))
1128 and then Present
(Etype
(First
(Parameter_Associations
(N
))))
1131 (N
, Nam_Ent
, False, Success
, Skip_First
=> True);
1133 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
1136 -- If the interpretation succeeds, mark the proper type of the
1137 -- prefix (any valid candidate will do). If not, remove the
1138 -- candidate interpretation. This only needs to be done for
1139 -- overloaded protected operations, for other entities disambi-
1140 -- guation is done directly in Resolve.
1144 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1146 Set_Entity
(Nam
, It
.Nam
);
1147 Insert_Explicit_Dereference
(Nam
);
1148 Set_Etype
(Nam
, Nam_Ent
);
1151 Set_Etype
(Nam
, It
.Typ
);
1154 elsif Nkind_In
(Name
(N
), N_Selected_Component
,
1160 Get_Next_Interp
(X
, It
);
1163 -- If the name is the result of a function call, it can only
1164 -- be a call to a function returning an access to subprogram.
1165 -- Insert explicit dereference.
1167 if Nkind
(Nam
) = N_Function_Call
then
1168 Insert_Explicit_Dereference
(Nam
);
1171 if Etype
(N
) = Any_Type
then
1173 -- None of the interpretations is compatible with the actuals
1175 Diagnose_Call
(N
, Nam
);
1177 -- Special checks for uninstantiated put routines
1179 if Nkind
(N
) = N_Procedure_Call_Statement
1180 and then Is_Entity_Name
(Nam
)
1181 and then Chars
(Nam
) = Name_Put
1182 and then List_Length
(Actuals
) = 1
1185 Arg
: constant Node_Id
:= First
(Actuals
);
1189 if Nkind
(Arg
) = N_Parameter_Association
then
1190 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
1195 if Is_Signed_Integer_Type
(Typ
) then
1197 ("possible missing instantiation of " &
1198 "'Text_'I'O.'Integer_'I'O!", Nam
);
1200 elsif Is_Modular_Integer_Type
(Typ
) then
1202 ("possible missing instantiation of " &
1203 "'Text_'I'O.'Modular_'I'O!", Nam
);
1205 elsif Is_Floating_Point_Type
(Typ
) then
1207 ("possible missing instantiation of " &
1208 "'Text_'I'O.'Float_'I'O!", Nam
);
1210 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1212 ("possible missing instantiation of " &
1213 "'Text_'I'O.'Fixed_'I'O!", Nam
);
1215 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1217 ("possible missing instantiation of " &
1218 "'Text_'I'O.'Decimal_'I'O!", Nam
);
1220 elsif Is_Enumeration_Type
(Typ
) then
1222 ("possible missing instantiation of " &
1223 "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1228 elsif not Is_Overloaded
(N
)
1229 and then Is_Entity_Name
(Nam
)
1231 -- Resolution yields a single interpretation. Verify that the
1232 -- reference has capitalization consistent with the declaration.
1234 Set_Entity_With_Style_Check
(Nam
, Entity
(Nam
));
1235 Generate_Reference
(Entity
(Nam
), Nam
);
1237 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1239 Remove_Abstract_Operations
(N
);
1246 -----------------------------
1247 -- Analyze_Case_Expression --
1248 -----------------------------
1250 procedure Analyze_Case_Expression
(N
: Node_Id
) is
1251 Expr
: constant Node_Id
:= Expression
(N
);
1252 FirstX
: constant Node_Id
:= Expression
(First
(Alternatives
(N
)));
1254 Exp_Type
: Entity_Id
;
1255 Exp_Btype
: Entity_Id
;
1257 Dont_Care
: Boolean;
1258 Others_Present
: Boolean;
1260 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
1261 -- Error routine invoked by the generic instantiation below when
1262 -- the case expression has a non static choice.
1264 package Case_Choices_Processing
is new
1265 Generic_Choices_Processing
1266 (Get_Alternatives
=> Alternatives
,
1267 Get_Choices
=> Discrete_Choices
,
1268 Process_Empty_Choice
=> No_OP
,
1269 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
1270 Process_Associated_Node
=> No_OP
);
1271 use Case_Choices_Processing
;
1273 -----------------------------
1274 -- Non_Static_Choice_Error --
1275 -----------------------------
1277 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
1279 Flag_Non_Static_Expr
1280 ("choice given in case expression is not static!", Choice
);
1281 end Non_Static_Choice_Error
;
1283 -- Start of processing for Analyze_Case_Expression
1286 if Comes_From_Source
(N
) then
1287 Check_Compiler_Unit
(N
);
1290 Analyze_And_Resolve
(Expr
, Any_Discrete
);
1291 Check_Unset_Reference
(Expr
);
1292 Exp_Type
:= Etype
(Expr
);
1293 Exp_Btype
:= Base_Type
(Exp_Type
);
1295 Alt
:= First
(Alternatives
(N
));
1296 while Present
(Alt
) loop
1297 Analyze
(Expression
(Alt
));
1301 if not Is_Overloaded
(FirstX
) then
1302 Set_Etype
(N
, Etype
(FirstX
));
1310 Set_Etype
(N
, Any_Type
);
1312 Get_First_Interp
(FirstX
, I
, It
);
1313 while Present
(It
.Nam
) loop
1315 -- For each interpretation of the first expression, we only
1316 -- add the interpretation if every other expression in the
1317 -- case expression alternatives has a compatible type.
1319 Alt
:= Next
(First
(Alternatives
(N
)));
1320 while Present
(Alt
) loop
1321 exit when not Has_Compatible_Type
(Expression
(Alt
), It
.Typ
);
1326 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1329 Get_Next_Interp
(I
, It
);
1334 Exp_Btype
:= Base_Type
(Exp_Type
);
1336 -- The expression must be of a discrete type which must be determinable
1337 -- independently of the context in which the expression occurs, but
1338 -- using the fact that the expression must be of a discrete type.
1339 -- Moreover, the type this expression must not be a character literal
1340 -- (which is always ambiguous).
1342 -- If error already reported by Resolve, nothing more to do
1344 if Exp_Btype
= Any_Discrete
1345 or else Exp_Btype
= Any_Type
1349 elsif Exp_Btype
= Any_Character
then
1351 ("character literal as case expression is ambiguous", Expr
);
1355 -- If the case expression is a formal object of mode in out, then
1356 -- treat it as having a nonstatic subtype by forcing use of the base
1357 -- type (which has to get passed to Check_Case_Choices below). Also
1358 -- use base type when the case expression is parenthesized.
1360 if Paren_Count
(Expr
) > 0
1361 or else (Is_Entity_Name
(Expr
)
1362 and then Ekind
(Entity
(Expr
)) = E_Generic_In_Out_Parameter
)
1364 Exp_Type
:= Exp_Btype
;
1367 -- Call instantiated Analyze_Choices which does the rest of the work
1369 Analyze_Choices
(N
, Exp_Type
, Dont_Care
, Others_Present
);
1371 if Exp_Type
= Universal_Integer
and then not Others_Present
then
1373 ("case on universal integer requires OTHERS choice", Expr
);
1375 end Analyze_Case_Expression
;
1377 ---------------------------
1378 -- Analyze_Comparison_Op --
1379 ---------------------------
1381 procedure Analyze_Comparison_Op
(N
: Node_Id
) is
1382 L
: constant Node_Id
:= Left_Opnd
(N
);
1383 R
: constant Node_Id
:= Right_Opnd
(N
);
1384 Op_Id
: Entity_Id
:= Entity
(N
);
1387 Set_Etype
(N
, Any_Type
);
1388 Candidate_Type
:= Empty
;
1390 Analyze_Expression
(L
);
1391 Analyze_Expression
(R
);
1393 if Present
(Op_Id
) then
1394 if Ekind
(Op_Id
) = E_Operator
then
1395 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1397 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1400 if Is_Overloaded
(L
) then
1401 Set_Etype
(L
, Intersect_Types
(L
, R
));
1405 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1406 while Present
(Op_Id
) loop
1407 if Ekind
(Op_Id
) = E_Operator
then
1408 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1410 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1413 Op_Id
:= Homonym
(Op_Id
);
1418 end Analyze_Comparison_Op
;
1420 ---------------------------
1421 -- Analyze_Concatenation --
1422 ---------------------------
1424 procedure Analyze_Concatenation
(N
: Node_Id
) is
1426 -- We wish to avoid deep recursion, because concatenations are often
1427 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1428 -- operands nonrecursively until we find something that is not a
1429 -- concatenation (A in this case), or has already been analyzed. We
1430 -- analyze that, and then walk back up the tree following Parent
1431 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1432 -- work at each level. The Parent pointers allow us to avoid recursion,
1433 -- and thus avoid running out of memory.
1439 Candidate_Type
:= Empty
;
1441 -- The following code is equivalent to:
1443 -- Set_Etype (N, Any_Type);
1444 -- Analyze_Expression (Left_Opnd (N));
1445 -- Analyze_Concatenation_Rest (N);
1447 -- where the Analyze_Expression call recurses back here if the left
1448 -- operand is a concatenation.
1450 -- Walk down left operands
1453 Set_Etype
(NN
, Any_Type
);
1454 L
:= Left_Opnd
(NN
);
1455 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1459 -- Now (given the above example) NN is A&B and L is A
1461 -- First analyze L ...
1463 Analyze_Expression
(L
);
1465 -- ... then walk NN back up until we reach N (where we started), calling
1466 -- Analyze_Concatenation_Rest along the way.
1469 Analyze_Concatenation_Rest
(NN
);
1473 end Analyze_Concatenation
;
1475 --------------------------------
1476 -- Analyze_Concatenation_Rest --
1477 --------------------------------
1479 -- If the only one-dimensional array type in scope is String,
1480 -- this is the resulting type of the operation. Otherwise there
1481 -- will be a concatenation operation defined for each user-defined
1482 -- one-dimensional array.
1484 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1485 L
: constant Node_Id
:= Left_Opnd
(N
);
1486 R
: constant Node_Id
:= Right_Opnd
(N
);
1487 Op_Id
: Entity_Id
:= Entity
(N
);
1492 Analyze_Expression
(R
);
1494 -- If the entity is present, the node appears in an instance, and
1495 -- denotes a predefined concatenation operation. The resulting type is
1496 -- obtained from the arguments when possible. If the arguments are
1497 -- aggregates, the array type and the concatenation type must be
1500 if Present
(Op_Id
) then
1501 if Ekind
(Op_Id
) = E_Operator
then
1502 LT
:= Base_Type
(Etype
(L
));
1503 RT
:= Base_Type
(Etype
(R
));
1505 if Is_Array_Type
(LT
)
1506 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1508 Add_One_Interp
(N
, Op_Id
, LT
);
1510 elsif Is_Array_Type
(RT
)
1511 and then LT
= Base_Type
(Component_Type
(RT
))
1513 Add_One_Interp
(N
, Op_Id
, RT
);
1515 -- If one operand is a string type or a user-defined array type,
1516 -- and the other is a literal, result is of the specific type.
1519 (Root_Type
(LT
) = Standard_String
1520 or else Scope
(LT
) /= Standard_Standard
)
1521 and then Etype
(R
) = Any_String
1523 Add_One_Interp
(N
, Op_Id
, LT
);
1526 (Root_Type
(RT
) = Standard_String
1527 or else Scope
(RT
) /= Standard_Standard
)
1528 and then Etype
(L
) = Any_String
1530 Add_One_Interp
(N
, Op_Id
, RT
);
1532 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
1533 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1536 -- Type and its operations must be visible
1538 Set_Entity
(N
, Empty
);
1539 Analyze_Concatenation
(N
);
1543 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1547 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
1548 while Present
(Op_Id
) loop
1549 if Ekind
(Op_Id
) = E_Operator
then
1551 -- Do not consider operators declared in dead code, they can
1552 -- not be part of the resolution.
1554 if Is_Eliminated
(Op_Id
) then
1557 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
1561 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1564 Op_Id
:= Homonym
(Op_Id
);
1569 end Analyze_Concatenation_Rest
;
1571 -------------------------
1572 -- Analyze_Equality_Op --
1573 -------------------------
1575 procedure Analyze_Equality_Op
(N
: Node_Id
) is
1576 Loc
: constant Source_Ptr
:= Sloc
(N
);
1577 L
: constant Node_Id
:= Left_Opnd
(N
);
1578 R
: constant Node_Id
:= Right_Opnd
(N
);
1582 Set_Etype
(N
, Any_Type
);
1583 Candidate_Type
:= Empty
;
1585 Analyze_Expression
(L
);
1586 Analyze_Expression
(R
);
1588 -- If the entity is set, the node is a generic instance with a non-local
1589 -- reference to the predefined operator or to a user-defined function.
1590 -- It can also be an inequality that is expanded into the negation of a
1591 -- call to a user-defined equality operator.
1593 -- For the predefined case, the result is Boolean, regardless of the
1594 -- type of the operands. The operands may even be limited, if they are
1595 -- generic actuals. If they are overloaded, label the left argument with
1596 -- the common type that must be present, or with the type of the formal
1597 -- of the user-defined function.
1599 if Present
(Entity
(N
)) then
1600 Op_Id
:= Entity
(N
);
1602 if Ekind
(Op_Id
) = E_Operator
then
1603 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
1605 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1608 if Is_Overloaded
(L
) then
1609 if Ekind
(Op_Id
) = E_Operator
then
1610 Set_Etype
(L
, Intersect_Types
(L
, R
));
1612 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
1617 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1618 while Present
(Op_Id
) loop
1619 if Ekind
(Op_Id
) = E_Operator
then
1620 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1622 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1625 Op_Id
:= Homonym
(Op_Id
);
1629 -- If there was no match, and the operator is inequality, this may
1630 -- be a case where inequality has not been made explicit, as for
1631 -- tagged types. Analyze the node as the negation of an equality
1632 -- operation. This cannot be done earlier, because before analysis
1633 -- we cannot rule out the presence of an explicit inequality.
1635 if Etype
(N
) = Any_Type
1636 and then Nkind
(N
) = N_Op_Ne
1638 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
1639 while Present
(Op_Id
) loop
1640 if Ekind
(Op_Id
) = E_Operator
then
1641 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1643 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1646 Op_Id
:= Homonym
(Op_Id
);
1649 if Etype
(N
) /= Any_Type
then
1650 Op_Id
:= Entity
(N
);
1656 Left_Opnd
=> Left_Opnd
(N
),
1657 Right_Opnd
=> Right_Opnd
(N
))));
1659 Set_Entity
(Right_Opnd
(N
), Op_Id
);
1665 end Analyze_Equality_Op
;
1667 ----------------------------------
1668 -- Analyze_Explicit_Dereference --
1669 ----------------------------------
1671 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
1672 Loc
: constant Source_Ptr
:= Sloc
(N
);
1673 P
: constant Node_Id
:= Prefix
(N
);
1679 function Is_Function_Type
return Boolean;
1680 -- Check whether node may be interpreted as an implicit function call
1682 ----------------------
1683 -- Is_Function_Type --
1684 ----------------------
1686 function Is_Function_Type
return Boolean is
1691 if not Is_Overloaded
(N
) then
1692 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
1693 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
1696 Get_First_Interp
(N
, I
, It
);
1697 while Present
(It
.Nam
) loop
1698 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
1699 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
1704 Get_Next_Interp
(I
, It
);
1709 end Is_Function_Type
;
1711 -- Start of processing for Analyze_Explicit_Dereference
1714 -- If source node, check SPARK restriction. We guard this with the
1715 -- source node check, because ???
1717 if Comes_From_Source
(N
) then
1718 Check_SPARK_Restriction
("explicit dereference is not allowed", N
);
1721 -- In formal verification mode, keep track of all reads and writes
1722 -- through explicit dereferences.
1725 Alfa
.Generate_Dereference
(N
);
1729 Set_Etype
(N
, Any_Type
);
1731 -- Test for remote access to subprogram type, and if so return
1732 -- after rewriting the original tree.
1734 if Remote_AST_E_Dereference
(P
) then
1738 -- Normal processing for other than remote access to subprogram type
1740 if not Is_Overloaded
(P
) then
1741 if Is_Access_Type
(Etype
(P
)) then
1743 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
1744 -- avoid other problems caused by the Private_Subtype and it is
1745 -- safe to go to the Base_Type because this is the same as
1746 -- converting the access value to its Base_Type.
1749 DT
: Entity_Id
:= Designated_Type
(Etype
(P
));
1752 if Ekind
(DT
) = E_Private_Subtype
1753 and then Is_For_Access_Subtype
(DT
)
1755 DT
:= Base_Type
(DT
);
1758 -- An explicit dereference is a legal occurrence of an
1759 -- incomplete type imported through a limited_with clause,
1760 -- if the full view is visible.
1762 if From_With_Type
(DT
)
1763 and then not From_With_Type
(Scope
(DT
))
1765 (Is_Immediately_Visible
(Scope
(DT
))
1767 (Is_Child_Unit
(Scope
(DT
))
1768 and then Is_Visible_Lib_Unit
(Scope
(DT
))))
1770 Set_Etype
(N
, Available_View
(DT
));
1777 elsif Etype
(P
) /= Any_Type
then
1778 Error_Msg_N
("prefix of dereference must be an access type", N
);
1783 Get_First_Interp
(P
, I
, It
);
1784 while Present
(It
.Nam
) loop
1787 if Is_Access_Type
(T
) then
1788 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
1791 Get_Next_Interp
(I
, It
);
1794 -- Error if no interpretation of the prefix has an access type
1796 if Etype
(N
) = Any_Type
then
1798 ("access type required in prefix of explicit dereference", P
);
1799 Set_Etype
(N
, Any_Type
);
1805 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
1807 and then (Nkind
(Parent
(N
)) /= N_Function_Call
1808 or else N
/= Name
(Parent
(N
)))
1810 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1811 or else N
/= Name
(Parent
(N
)))
1813 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
1814 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
1816 (Attribute_Name
(Parent
(N
)) /= Name_Address
1818 Attribute_Name
(Parent
(N
)) /= Name_Access
))
1820 -- Name is a function call with no actuals, in a context that
1821 -- requires deproceduring (including as an actual in an enclosing
1822 -- function or procedure call). There are some pathological cases
1823 -- where the prefix might include functions that return access to
1824 -- subprograms and others that return a regular type. Disambiguation
1825 -- of those has to take place in Resolve.
1828 Make_Function_Call
(Loc
,
1829 Name
=> Make_Explicit_Dereference
(Loc
, P
),
1830 Parameter_Associations
=> New_List
);
1832 -- If the prefix is overloaded, remove operations that have formals,
1833 -- we know that this is a parameterless call.
1835 if Is_Overloaded
(P
) then
1836 Get_First_Interp
(P
, I
, It
);
1837 while Present
(It
.Nam
) loop
1840 if No
(First_Formal
(Base_Type
(Designated_Type
(T
)))) then
1846 Get_Next_Interp
(I
, It
);
1853 elsif not Is_Function_Type
1854 and then Is_Overloaded
(N
)
1856 -- The prefix may include access to subprograms and other access
1857 -- types. If the context selects the interpretation that is a
1858 -- function call (not a procedure call) we cannot rewrite the node
1859 -- yet, but we include the result of the call interpretation.
1861 Get_First_Interp
(N
, I
, It
);
1862 while Present
(It
.Nam
) loop
1863 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
1864 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
1865 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
1867 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
1870 Get_Next_Interp
(I
, It
);
1874 -- A value of remote access-to-class-wide must not be dereferenced
1877 Validate_Remote_Access_To_Class_Wide_Type
(N
);
1878 end Analyze_Explicit_Dereference
;
1880 ------------------------
1881 -- Analyze_Expression --
1882 ------------------------
1884 procedure Analyze_Expression
(N
: Node_Id
) is
1887 Check_Parameterless_Call
(N
);
1888 end Analyze_Expression
;
1890 -------------------------------------
1891 -- Analyze_Expression_With_Actions --
1892 -------------------------------------
1894 procedure Analyze_Expression_With_Actions
(N
: Node_Id
) is
1898 A
:= First
(Actions
(N
));
1905 -- This test needs a comment ???
1907 if Nkind
(Expression
(N
)) = N_Null_Statement
then
1908 Set_Etype
(N
, Standard_Void_Type
);
1910 Analyze_Expression
(Expression
(N
));
1911 Set_Etype
(N
, Etype
(Expression
(N
)));
1913 end Analyze_Expression_With_Actions
;
1915 ---------------------------
1916 -- Analyze_If_Expression --
1917 ---------------------------
1919 procedure Analyze_If_Expression
(N
: Node_Id
) is
1920 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1921 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1922 Else_Expr
: Node_Id
;
1925 -- Defend against error of missing expressions from previous error
1927 if No
(Then_Expr
) then
1928 Check_Error_Detected
;
1932 Check_SPARK_Restriction
("if expression is not allowed", N
);
1934 Else_Expr
:= Next
(Then_Expr
);
1936 if Comes_From_Source
(N
) then
1937 Check_Compiler_Unit
(N
);
1940 Analyze_Expression
(Condition
);
1941 Analyze_Expression
(Then_Expr
);
1943 if Present
(Else_Expr
) then
1944 Analyze_Expression
(Else_Expr
);
1947 -- If then expression not overloaded, then that decides the type
1949 if not Is_Overloaded
(Then_Expr
) then
1950 Set_Etype
(N
, Etype
(Then_Expr
));
1952 -- Case where then expression is overloaded
1960 Set_Etype
(N
, Any_Type
);
1962 -- Shouldn't the following statement be down in the ELSE of the
1963 -- following loop? ???
1965 Get_First_Interp
(Then_Expr
, I
, It
);
1967 -- if no Else_Expression the conditional must be boolean
1969 if No
(Else_Expr
) then
1970 Set_Etype
(N
, Standard_Boolean
);
1972 -- Else_Expression Present. For each possible intepretation of
1973 -- the Then_Expression, add it only if the Else_Expression has
1974 -- a compatible type.
1977 while Present
(It
.Nam
) loop
1978 if Has_Compatible_Type
(Else_Expr
, It
.Typ
) then
1979 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1982 Get_Next_Interp
(I
, It
);
1987 end Analyze_If_Expression
;
1989 ------------------------------------
1990 -- Analyze_Indexed_Component_Form --
1991 ------------------------------------
1993 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
1994 P
: constant Node_Id
:= Prefix
(N
);
1995 Exprs
: constant List_Id
:= Expressions
(N
);
2001 procedure Process_Function_Call
;
2002 -- Prefix in indexed component form is an overloadable entity,
2003 -- so the node is a function call. Reformat it as such.
2005 procedure Process_Indexed_Component
;
2006 -- Prefix in indexed component form is actually an indexed component.
2007 -- This routine processes it, knowing that the prefix is already
2010 procedure Process_Indexed_Component_Or_Slice
;
2011 -- An indexed component with a single index may designate a slice if
2012 -- the index is a subtype mark. This routine disambiguates these two
2013 -- cases by resolving the prefix to see if it is a subtype mark.
2015 procedure Process_Overloaded_Indexed_Component
;
2016 -- If the prefix of an indexed component is overloaded, the proper
2017 -- interpretation is selected by the index types and the context.
2019 ---------------------------
2020 -- Process_Function_Call --
2021 ---------------------------
2023 procedure Process_Function_Call
is
2027 Change_Node
(N
, N_Function_Call
);
2029 Set_Parameter_Associations
(N
, Exprs
);
2031 -- Analyze actuals prior to analyzing the call itself
2033 Actual
:= First
(Parameter_Associations
(N
));
2034 while Present
(Actual
) loop
2036 Check_Parameterless_Call
(Actual
);
2038 -- Move to next actual. Note that we use Next, not Next_Actual
2039 -- here. The reason for this is a bit subtle. If a function call
2040 -- includes named associations, the parser recognizes the node as
2041 -- a call, and it is analyzed as such. If all associations are
2042 -- positional, the parser builds an indexed_component node, and
2043 -- it is only after analysis of the prefix that the construct
2044 -- is recognized as a call, in which case Process_Function_Call
2045 -- rewrites the node and analyzes the actuals. If the list of
2046 -- actuals is malformed, the parser may leave the node as an
2047 -- indexed component (despite the presence of named associations).
2048 -- The iterator Next_Actual is equivalent to Next if the list is
2049 -- positional, but follows the normalized chain of actuals when
2050 -- named associations are present. In this case normalization has
2051 -- not taken place, and actuals remain unanalyzed, which leads to
2052 -- subsequent crashes or loops if there is an attempt to continue
2053 -- analysis of the program.
2059 end Process_Function_Call
;
2061 -------------------------------
2062 -- Process_Indexed_Component --
2063 -------------------------------
2065 procedure Process_Indexed_Component
is
2067 Array_Type
: Entity_Id
;
2069 Pent
: Entity_Id
:= Empty
;
2072 Exp
:= First
(Exprs
);
2074 if Is_Overloaded
(P
) then
2075 Process_Overloaded_Indexed_Component
;
2078 Array_Type
:= Etype
(P
);
2080 if Is_Entity_Name
(P
) then
2082 elsif Nkind
(P
) = N_Selected_Component
2083 and then Is_Entity_Name
(Selector_Name
(P
))
2085 Pent
:= Entity
(Selector_Name
(P
));
2088 -- Prefix must be appropriate for an array type, taking into
2089 -- account a possible implicit dereference.
2091 if Is_Access_Type
(Array_Type
) then
2093 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2094 Array_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, P
);
2097 if Is_Array_Type
(Array_Type
) then
2100 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
2102 Set_Etype
(N
, Any_Type
);
2104 if not Has_Compatible_Type
2105 (Exp
, Entry_Index_Type
(Pent
))
2107 Error_Msg_N
("invalid index type in entry name", N
);
2109 elsif Present
(Next
(Exp
)) then
2110 Error_Msg_N
("too many subscripts in entry reference", N
);
2113 Set_Etype
(N
, Etype
(P
));
2118 elsif Is_Record_Type
(Array_Type
)
2119 and then Remote_AST_I_Dereference
(P
)
2123 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2126 elsif Array_Type
= Any_Type
then
2127 Set_Etype
(N
, Any_Type
);
2129 -- In most cases the analysis of the prefix will have emitted
2130 -- an error already, but if the prefix may be interpreted as a
2131 -- call in prefixed notation, the report is left to the caller.
2132 -- To prevent cascaded errors, report only if no previous ones.
2134 if Serious_Errors_Detected
= 0 then
2135 Error_Msg_N
("invalid prefix in indexed component", P
);
2137 if Nkind
(P
) = N_Expanded_Name
then
2138 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
2144 -- Here we definitely have a bad indexing
2147 if Nkind
(Parent
(N
)) = N_Requeue_Statement
2148 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
2151 ("REQUEUE does not permit parameters", First
(Exprs
));
2153 elsif Is_Entity_Name
(P
)
2154 and then Etype
(P
) = Standard_Void_Type
2156 Error_Msg_NE
("incorrect use of&", P
, Entity
(P
));
2159 Error_Msg_N
("array type required in indexed component", P
);
2162 Set_Etype
(N
, Any_Type
);
2166 Index
:= First_Index
(Array_Type
);
2167 while Present
(Index
) and then Present
(Exp
) loop
2168 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2169 Wrong_Type
(Exp
, Etype
(Index
));
2170 Set_Etype
(N
, Any_Type
);
2178 Set_Etype
(N
, Component_Type
(Array_Type
));
2179 Check_Implicit_Dereference
(N
, Etype
(N
));
2181 if Present
(Index
) then
2183 ("too few subscripts in array reference", First
(Exprs
));
2185 elsif Present
(Exp
) then
2186 Error_Msg_N
("too many subscripts in array reference", Exp
);
2189 end Process_Indexed_Component
;
2191 ----------------------------------------
2192 -- Process_Indexed_Component_Or_Slice --
2193 ----------------------------------------
2195 procedure Process_Indexed_Component_Or_Slice
is
2197 Exp
:= First
(Exprs
);
2198 while Present
(Exp
) loop
2199 Analyze_Expression
(Exp
);
2203 Exp
:= First
(Exprs
);
2205 -- If one index is present, and it is a subtype name, then the
2206 -- node denotes a slice (note that the case of an explicit range
2207 -- for a slice was already built as an N_Slice node in the first
2208 -- place, so that case is not handled here).
2210 -- We use a replace rather than a rewrite here because this is one
2211 -- of the cases in which the tree built by the parser is plain wrong.
2214 and then Is_Entity_Name
(Exp
)
2215 and then Is_Type
(Entity
(Exp
))
2218 Make_Slice
(Sloc
(N
),
2220 Discrete_Range
=> New_Copy
(Exp
)));
2223 -- Otherwise (more than one index present, or single index is not
2224 -- a subtype name), then we have the indexed component case.
2227 Process_Indexed_Component
;
2229 end Process_Indexed_Component_Or_Slice
;
2231 ------------------------------------------
2232 -- Process_Overloaded_Indexed_Component --
2233 ------------------------------------------
2235 procedure Process_Overloaded_Indexed_Component
is
2244 Set_Etype
(N
, Any_Type
);
2246 Get_First_Interp
(P
, I
, It
);
2247 while Present
(It
.Nam
) loop
2250 if Is_Access_Type
(Typ
) then
2251 Typ
:= Designated_Type
(Typ
);
2253 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2256 if Is_Array_Type
(Typ
) then
2258 -- Got a candidate: verify that index types are compatible
2260 Index
:= First_Index
(Typ
);
2262 Exp
:= First
(Exprs
);
2263 while Present
(Index
) and then Present
(Exp
) loop
2264 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2276 if Found
and then No
(Index
) and then No
(Exp
) then
2278 CT
: constant Entity_Id
:=
2279 Base_Type
(Component_Type
(Typ
));
2281 Add_One_Interp
(N
, CT
, CT
);
2282 Check_Implicit_Dereference
(N
, CT
);
2286 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2291 Get_Next_Interp
(I
, It
);
2294 if Etype
(N
) = Any_Type
then
2295 Error_Msg_N
("no legal interpretation for indexed component", N
);
2296 Set_Is_Overloaded
(N
, False);
2300 end Process_Overloaded_Indexed_Component
;
2302 -- Start of processing for Analyze_Indexed_Component_Form
2305 -- Get name of array, function or type
2309 if Nkind
(N
) in N_Subprogram_Call
then
2311 -- If P is an explicit dereference whose prefix is of a
2312 -- remote access-to-subprogram type, then N has already
2313 -- been rewritten as a subprogram call and analyzed.
2318 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
2320 P_T
:= Base_Type
(Etype
(P
));
2322 if Is_Entity_Name
(P
) and then Present
(Entity
(P
)) then
2325 if Is_Type
(U_N
) then
2327 -- Reformat node as a type conversion
2329 E
:= Remove_Head
(Exprs
);
2331 if Present
(First
(Exprs
)) then
2333 ("argument of type conversion must be single expression", N
);
2336 Change_Node
(N
, N_Type_Conversion
);
2337 Set_Subtype_Mark
(N
, P
);
2339 Set_Expression
(N
, E
);
2341 -- After changing the node, call for the specific Analysis
2342 -- routine directly, to avoid a double call to the expander.
2344 Analyze_Type_Conversion
(N
);
2348 if Is_Overloadable
(U_N
) then
2349 Process_Function_Call
;
2351 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
2352 or else (Is_Access_Type
(Etype
(P
))
2354 Ekind
(Designated_Type
(Etype
(P
))) =
2357 -- Call to access_to-subprogram with possible implicit dereference
2359 Process_Function_Call
;
2361 elsif Is_Generic_Subprogram
(U_N
) then
2363 -- A common beginner's (or C++ templates fan) error
2365 Error_Msg_N
("generic subprogram cannot be called", N
);
2366 Set_Etype
(N
, Any_Type
);
2370 Process_Indexed_Component_Or_Slice
;
2373 -- If not an entity name, prefix is an expression that may denote
2374 -- an array or an access-to-subprogram.
2377 if Ekind
(P_T
) = E_Subprogram_Type
2378 or else (Is_Access_Type
(P_T
)
2380 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
2382 Process_Function_Call
;
2384 elsif Nkind
(P
) = N_Selected_Component
2385 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
2387 Process_Function_Call
;
2390 -- Indexed component, slice, or a call to a member of a family
2391 -- entry, which will be converted to an entry call later.
2393 Process_Indexed_Component_Or_Slice
;
2397 Analyze_Dimension
(N
);
2398 end Analyze_Indexed_Component_Form
;
2400 ------------------------
2401 -- Analyze_Logical_Op --
2402 ------------------------
2404 procedure Analyze_Logical_Op
(N
: Node_Id
) is
2405 L
: constant Node_Id
:= Left_Opnd
(N
);
2406 R
: constant Node_Id
:= Right_Opnd
(N
);
2407 Op_Id
: Entity_Id
:= Entity
(N
);
2410 Set_Etype
(N
, Any_Type
);
2411 Candidate_Type
:= Empty
;
2413 Analyze_Expression
(L
);
2414 Analyze_Expression
(R
);
2416 if Present
(Op_Id
) then
2418 if Ekind
(Op_Id
) = E_Operator
then
2419 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2421 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2425 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2426 while Present
(Op_Id
) loop
2427 if Ekind
(Op_Id
) = E_Operator
then
2428 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2430 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2433 Op_Id
:= Homonym
(Op_Id
);
2438 end Analyze_Logical_Op
;
2440 ---------------------------
2441 -- Analyze_Membership_Op --
2442 ---------------------------
2444 procedure Analyze_Membership_Op
(N
: Node_Id
) is
2445 Loc
: constant Source_Ptr
:= Sloc
(N
);
2446 L
: constant Node_Id
:= Left_Opnd
(N
);
2447 R
: constant Node_Id
:= Right_Opnd
(N
);
2449 Index
: Interp_Index
;
2451 Found
: Boolean := False;
2455 procedure Try_One_Interp
(T1
: Entity_Id
);
2456 -- Routine to try one proposed interpretation. Note that the context
2457 -- of the operation plays no role in resolving the arguments, so that
2458 -- if there is more than one interpretation of the operands that is
2459 -- compatible with a membership test, the operation is ambiguous.
2461 --------------------
2462 -- Try_One_Interp --
2463 --------------------
2465 procedure Try_One_Interp
(T1
: Entity_Id
) is
2467 if Has_Compatible_Type
(R
, T1
) then
2469 and then Base_Type
(T1
) /= Base_Type
(T_F
)
2471 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
2473 if It
= No_Interp
then
2474 Ambiguous_Operands
(N
);
2475 Set_Etype
(L
, Any_Type
);
2492 procedure Analyze_Set_Membership
;
2493 -- If a set of alternatives is present, analyze each and find the
2494 -- common type to which they must all resolve.
2496 ----------------------------
2497 -- Analyze_Set_Membership --
2498 ----------------------------
2500 procedure Analyze_Set_Membership
is
2502 Index
: Interp_Index
;
2504 Candidate_Interps
: Node_Id
;
2505 Common_Type
: Entity_Id
:= Empty
;
2509 Candidate_Interps
:= L
;
2511 if not Is_Overloaded
(L
) then
2512 Common_Type
:= Etype
(L
);
2514 Alt
:= First
(Alternatives
(N
));
2515 while Present
(Alt
) loop
2518 if not Has_Compatible_Type
(Alt
, Common_Type
) then
2519 Wrong_Type
(Alt
, Common_Type
);
2526 Alt
:= First
(Alternatives
(N
));
2527 while Present
(Alt
) loop
2529 if not Is_Overloaded
(Alt
) then
2530 Common_Type
:= Etype
(Alt
);
2533 Get_First_Interp
(Alt
, Index
, It
);
2534 while Present
(It
.Typ
) loop
2536 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
2538 Remove_Interp
(Index
);
2541 Get_Next_Interp
(Index
, It
);
2544 Get_First_Interp
(Alt
, Index
, It
);
2547 Error_Msg_N
("alternative has no legal type", Alt
);
2551 -- If alternative is not overloaded, we have a unique type
2554 Set_Etype
(Alt
, It
.Typ
);
2555 Get_Next_Interp
(Index
, It
);
2558 Set_Is_Overloaded
(Alt
, False);
2559 Common_Type
:= Etype
(Alt
);
2562 Candidate_Interps
:= Alt
;
2569 Set_Etype
(N
, Standard_Boolean
);
2571 if Present
(Common_Type
) then
2572 Set_Etype
(L
, Common_Type
);
2573 Set_Is_Overloaded
(L
, False);
2576 Error_Msg_N
("cannot resolve membership operation", N
);
2578 end Analyze_Set_Membership
;
2580 -- Start of processing for Analyze_Membership_Op
2583 Analyze_Expression
(L
);
2586 and then Ada_Version
>= Ada_2012
2588 Analyze_Set_Membership
;
2592 if Nkind
(R
) = N_Range
2593 or else (Nkind
(R
) = N_Attribute_Reference
2594 and then Attribute_Name
(R
) = Name_Range
)
2598 if not Is_Overloaded
(L
) then
2599 Try_One_Interp
(Etype
(L
));
2602 Get_First_Interp
(L
, Index
, It
);
2603 while Present
(It
.Typ
) loop
2604 Try_One_Interp
(It
.Typ
);
2605 Get_Next_Interp
(Index
, It
);
2609 -- If not a range, it can be a subtype mark, or else it is a degenerate
2610 -- membership test with a singleton value, i.e. a test for equality,
2611 -- if the types are compatible.
2616 if Is_Entity_Name
(R
)
2617 and then Is_Type
(Entity
(R
))
2620 Check_Fully_Declared
(Entity
(R
), R
);
2622 elsif Ada_Version
>= Ada_2012
2623 and then Has_Compatible_Type
(R
, Etype
(L
))
2625 if Nkind
(N
) = N_In
then
2641 -- In all versions of the language, if we reach this point there
2642 -- is a previous error that will be diagnosed below.
2648 -- Compatibility between expression and subtype mark or range is
2649 -- checked during resolution. The result of the operation is Boolean
2652 Set_Etype
(N
, Standard_Boolean
);
2654 if Comes_From_Source
(N
)
2655 and then Present
(Right_Opnd
(N
))
2656 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
2658 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
2660 end Analyze_Membership_Op
;
2666 procedure Analyze_Mod
(N
: Node_Id
) is
2668 -- A special warning check, if we have an expression of the form:
2669 -- expr mod 2 * literal
2670 -- where literal is 64 or less, then probably what was meant was
2671 -- expr mod 2 ** literal
2672 -- so issue an appropriate warning.
2674 if Warn_On_Suspicious_Modulus_Value
2675 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
2676 and then Intval
(Right_Opnd
(N
)) = Uint_2
2677 and then Nkind
(Parent
(N
)) = N_Op_Multiply
2678 and then Nkind
(Right_Opnd
(Parent
(N
))) = N_Integer_Literal
2679 and then Intval
(Right_Opnd
(Parent
(N
))) <= Uint_64
2682 ("suspicious MOD value, was '*'* intended'??M?", Parent
(N
));
2685 -- Remaining processing is same as for other arithmetic operators
2687 Analyze_Arithmetic_Op
(N
);
2690 ----------------------
2691 -- Analyze_Negation --
2692 ----------------------
2694 procedure Analyze_Negation
(N
: Node_Id
) is
2695 R
: constant Node_Id
:= Right_Opnd
(N
);
2696 Op_Id
: Entity_Id
:= Entity
(N
);
2699 Set_Etype
(N
, Any_Type
);
2700 Candidate_Type
:= Empty
;
2702 Analyze_Expression
(R
);
2704 if Present
(Op_Id
) then
2705 if Ekind
(Op_Id
) = E_Operator
then
2706 Find_Negation_Types
(R
, Op_Id
, N
);
2708 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2712 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2713 while Present
(Op_Id
) loop
2714 if Ekind
(Op_Id
) = E_Operator
then
2715 Find_Negation_Types
(R
, Op_Id
, N
);
2717 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
2720 Op_Id
:= Homonym
(Op_Id
);
2725 end Analyze_Negation
;
2731 procedure Analyze_Null
(N
: Node_Id
) is
2733 Check_SPARK_Restriction
("null is not allowed", N
);
2735 Set_Etype
(N
, Any_Access
);
2738 ----------------------
2739 -- Analyze_One_Call --
2740 ----------------------
2742 procedure Analyze_One_Call
2746 Success
: out Boolean;
2747 Skip_First
: Boolean := False)
2749 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
2750 Prev_T
: constant Entity_Id
:= Etype
(N
);
2752 Must_Skip
: constant Boolean := Skip_First
2753 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
2755 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
2756 and then Nkind
(Prefix
(Original_Node
(N
)))
2757 = N_Selected_Component
);
2758 -- The first formal must be omitted from the match when trying to find
2759 -- a primitive operation that is a possible interpretation, and also
2760 -- after the call has been rewritten, because the corresponding actual
2761 -- is already known to be compatible, and because this may be an
2762 -- indexing of a call with default parameters.
2766 Is_Indexed
: Boolean := False;
2767 Is_Indirect
: Boolean := False;
2768 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
2771 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
2772 -- There may be a user-defined operator that hides the current
2773 -- interpretation. We must check for this independently of the
2774 -- analysis of the call with the user-defined operation, because
2775 -- the parameter names may be wrong and yet the hiding takes place.
2776 -- This fixes a problem with ACATS test B34014O.
2778 -- When the type Address is a visible integer type, and the DEC
2779 -- system extension is visible, the predefined operator may be
2780 -- hidden as well, by one of the address operations in auxdec.
2781 -- Finally, The abstract operations on address do not hide the
2782 -- predefined operator (this is the purpose of making them abstract).
2784 procedure Indicate_Name_And_Type
;
2785 -- If candidate interpretation matches, indicate name and type of
2786 -- result on call node.
2788 ----------------------------
2789 -- Indicate_Name_And_Type --
2790 ----------------------------
2792 procedure Indicate_Name_And_Type
is
2794 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
2795 Check_Implicit_Dereference
(N
, Etype
(Nam
));
2798 -- If the prefix of the call is a name, indicate the entity
2799 -- being called. If it is not a name, it is an expression that
2800 -- denotes an access to subprogram or else an entry or family. In
2801 -- the latter case, the name is a selected component, and the entity
2802 -- being called is noted on the selector.
2804 if not Is_Type
(Nam
) then
2805 if Is_Entity_Name
(Name
(N
)) then
2806 Set_Entity
(Name
(N
), Nam
);
2808 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
2809 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
2813 if Debug_Flag_E
and not Report
then
2814 Write_Str
(" Overloaded call ");
2815 Write_Int
(Int
(N
));
2816 Write_Str
(" compatible with ");
2817 Write_Int
(Int
(Nam
));
2820 end Indicate_Name_And_Type
;
2822 ------------------------
2823 -- Operator_Hidden_By --
2824 ------------------------
2826 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
2827 Act1
: constant Node_Id
:= First_Actual
(N
);
2828 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
2829 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
2830 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
2833 if Ekind
(Fun
) /= E_Function
2834 or else Is_Abstract_Subprogram
(Fun
)
2838 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
2841 elsif Present
(Form2
) then
2843 No
(Act2
) or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
2848 elsif Present
(Act2
) then
2852 -- Now we know that the arity of the operator matches the function,
2853 -- and the function call is a valid interpretation. The function
2854 -- hides the operator if it has the right signature, or if one of
2855 -- its operands is a non-abstract operation on Address when this is
2856 -- a visible integer type.
2858 return Hides_Op
(Fun
, Nam
)
2859 or else Is_Descendent_Of_Address
(Etype
(Form1
))
2862 and then Is_Descendent_Of_Address
(Etype
(Form2
)));
2863 end Operator_Hidden_By
;
2865 -- Start of processing for Analyze_One_Call
2870 -- If the subprogram has no formals or if all the formals have defaults,
2871 -- and the return type is an array type, the node may denote an indexing
2872 -- of the result of a parameterless call. In Ada 2005, the subprogram
2873 -- may have one non-defaulted formal, and the call may have been written
2874 -- in prefix notation, so that the rebuilt parameter list has more than
2877 if not Is_Overloadable
(Nam
)
2878 and then Ekind
(Nam
) /= E_Subprogram_Type
2879 and then Ekind
(Nam
) /= E_Entry_Family
2884 -- An indexing requires at least one actual
2886 if not Is_Empty_List
(Actuals
)
2888 (Needs_No_Actuals
(Nam
)
2890 (Needs_One_Actual
(Nam
)
2891 and then Present
(Next_Actual
(First
(Actuals
)))))
2893 if Is_Array_Type
(Subp_Type
) then
2894 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
2896 elsif Is_Access_Type
(Subp_Type
)
2897 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
2901 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
2903 -- The prefix can also be a parameterless function that returns an
2904 -- access to subprogram, in which case this is an indirect call.
2905 -- If this succeeds, an explicit dereference is added later on,
2906 -- in Analyze_Call or Resolve_Call.
2908 elsif Is_Access_Type
(Subp_Type
)
2909 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
2911 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
2916 -- If the call has been transformed into a slice, it is of the form
2917 -- F (Subtype) where F is parameterless. The node has been rewritten in
2918 -- Try_Indexed_Call and there is nothing else to do.
2921 and then Nkind
(N
) = N_Slice
2927 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
2931 -- If an indirect call is a possible interpretation, indicate
2932 -- success to the caller.
2938 -- Mismatch in number or names of parameters
2940 elsif Debug_Flag_E
then
2941 Write_Str
(" normalization fails in call ");
2942 Write_Int
(Int
(N
));
2943 Write_Str
(" with subprogram ");
2944 Write_Int
(Int
(Nam
));
2948 -- If the context expects a function call, discard any interpretation
2949 -- that is a procedure. If the node is not overloaded, leave as is for
2950 -- better error reporting when type mismatch is found.
2952 elsif Nkind
(N
) = N_Function_Call
2953 and then Is_Overloaded
(Name
(N
))
2954 and then Ekind
(Nam
) = E_Procedure
2958 -- Ditto for function calls in a procedure context
2960 elsif Nkind
(N
) = N_Procedure_Call_Statement
2961 and then Is_Overloaded
(Name
(N
))
2962 and then Etype
(Nam
) /= Standard_Void_Type
2966 elsif No
(Actuals
) then
2968 -- If Normalize succeeds, then there are default parameters for
2971 Indicate_Name_And_Type
;
2973 elsif Ekind
(Nam
) = E_Operator
then
2974 if Nkind
(N
) = N_Procedure_Call_Statement
then
2978 -- This can occur when the prefix of the call is an operator
2979 -- name or an expanded name whose selector is an operator name.
2981 Analyze_Operator_Call
(N
, Nam
);
2983 if Etype
(N
) /= Prev_T
then
2985 -- Check that operator is not hidden by a function interpretation
2987 if Is_Overloaded
(Name
(N
)) then
2993 Get_First_Interp
(Name
(N
), I
, It
);
2994 while Present
(It
.Nam
) loop
2995 if Operator_Hidden_By
(It
.Nam
) then
2996 Set_Etype
(N
, Prev_T
);
3000 Get_Next_Interp
(I
, It
);
3005 -- If operator matches formals, record its name on the call.
3006 -- If the operator is overloaded, Resolve will select the
3007 -- correct one from the list of interpretations. The call
3008 -- node itself carries the first candidate.
3010 Set_Entity
(Name
(N
), Nam
);
3013 elsif Report
and then Etype
(N
) = Any_Type
then
3014 Error_Msg_N
("incompatible arguments for operator", N
);
3018 -- Normalize_Actuals has chained the named associations in the
3019 -- correct order of the formals.
3021 Actual
:= First_Actual
(N
);
3022 Formal
:= First_Formal
(Nam
);
3024 -- If we are analyzing a call rewritten from object notation, skip
3025 -- first actual, which may be rewritten later as an explicit
3029 Next_Actual
(Actual
);
3030 Next_Formal
(Formal
);
3033 while Present
(Actual
) and then Present
(Formal
) loop
3034 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
3035 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
3037 -- The actual can be compatible with the formal, but we must
3038 -- also check that the context is not an address type that is
3039 -- visibly an integer type, as is the case in VMS_64. In this
3040 -- case the use of literals is illegal, except in the body of
3041 -- descendents of system, where arithmetic operations on
3042 -- address are of course used.
3044 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
3046 (Etype
(Actual
) /= Universal_Integer
3047 or else not Is_Descendent_Of_Address
(Etype
(Formal
))
3049 Is_Predefined_File_Name
3050 (Unit_File_Name
(Get_Source_Unit
(N
))))
3052 Next_Actual
(Actual
);
3053 Next_Formal
(Formal
);
3056 if Debug_Flag_E
then
3057 Write_Str
(" type checking fails in call ");
3058 Write_Int
(Int
(N
));
3059 Write_Str
(" with formal ");
3060 Write_Int
(Int
(Formal
));
3061 Write_Str
(" in subprogram ");
3062 Write_Int
(Int
(Nam
));
3066 if Report
and not Is_Indexed
and not Is_Indirect
then
3068 -- Ada 2005 (AI-251): Complete the error notification
3069 -- to help new Ada 2005 users.
3071 if Is_Class_Wide_Type
(Etype
(Formal
))
3072 and then Is_Interface
(Etype
(Etype
(Formal
)))
3073 and then not Interface_Present_In_Ancestor
3074 (Typ
=> Etype
(Actual
),
3075 Iface
=> Etype
(Etype
(Formal
)))
3078 ("(Ada 2005) does not implement interface }",
3079 Actual
, Etype
(Etype
(Formal
)));
3082 Wrong_Type
(Actual
, Etype
(Formal
));
3084 if Nkind
(Actual
) = N_Op_Eq
3085 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
3087 Formal
:= First_Formal
(Nam
);
3088 while Present
(Formal
) loop
3089 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
3090 Error_Msg_N
-- CODEFIX
3091 ("possible misspelling of `='>`!", Actual
);
3095 Next_Formal
(Formal
);
3099 if All_Errors_Mode
then
3100 Error_Msg_Sloc
:= Sloc
(Nam
);
3102 if Etype
(Formal
) = Any_Type
then
3104 ("there is no legal actual parameter", Actual
);
3107 if Is_Overloadable
(Nam
)
3108 and then Present
(Alias
(Nam
))
3109 and then not Comes_From_Source
(Nam
)
3112 ("\\ =='> in call to inherited operation & #!",
3115 elsif Ekind
(Nam
) = E_Subprogram_Type
then
3117 Access_To_Subprogram_Typ
:
3118 constant Entity_Id
:=
3120 (Associated_Node_For_Itype
(Nam
));
3123 "\\ =='> in call to dereference of &#!",
3124 Actual
, Access_To_Subprogram_Typ
);
3129 ("\\ =='> in call to &#!", Actual
, Nam
);
3139 -- Normalize_Actuals has verified that a default value exists
3140 -- for this formal. Current actual names a subsequent formal.
3142 Next_Formal
(Formal
);
3146 -- On exit, all actuals match
3148 Indicate_Name_And_Type
;
3150 end Analyze_One_Call
;
3152 ---------------------------
3153 -- Analyze_Operator_Call --
3154 ---------------------------
3156 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
3157 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
3158 Act1
: constant Node_Id
:= First_Actual
(N
);
3159 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
3162 -- Binary operator case
3164 if Present
(Act2
) then
3166 -- If more than two operands, then not binary operator after all
3168 if Present
(Next_Actual
(Act2
)) then
3172 -- Otherwise action depends on operator
3182 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
3187 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
3193 Find_Comparison_Types
(Act1
, Act2
, Op_Id
, N
);
3197 Find_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
3199 when Name_Op_Concat
=>
3200 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
3202 -- Is this when others, or should it be an abort???
3208 -- Unary operator case
3212 when Name_Op_Subtract |
3215 Find_Unary_Types
(Act1
, Op_Id
, N
);
3218 Find_Negation_Types
(Act1
, Op_Id
, N
);
3220 -- Is this when others correct, or should it be an abort???
3226 end Analyze_Operator_Call
;
3228 -------------------------------------------
3229 -- Analyze_Overloaded_Selected_Component --
3230 -------------------------------------------
3232 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
3233 Nam
: constant Node_Id
:= Prefix
(N
);
3234 Sel
: constant Node_Id
:= Selector_Name
(N
);
3241 Set_Etype
(Sel
, Any_Type
);
3243 Get_First_Interp
(Nam
, I
, It
);
3244 while Present
(It
.Typ
) loop
3245 if Is_Access_Type
(It
.Typ
) then
3246 T
:= Designated_Type
(It
.Typ
);
3247 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
3252 -- Locate the component. For a private prefix the selector can denote
3255 if Is_Record_Type
(T
) or else Is_Private_Type
(T
) then
3257 -- If the prefix is a class-wide type, the visible components are
3258 -- those of the base type.
3260 if Is_Class_Wide_Type
(T
) then
3264 Comp
:= First_Entity
(T
);
3265 while Present
(Comp
) loop
3266 if Chars
(Comp
) = Chars
(Sel
)
3267 and then Is_Visible_Component
(Comp
)
3270 -- AI05-105: if the context is an object renaming with
3271 -- an anonymous access type, the expected type of the
3272 -- object must be anonymous. This is a name resolution rule.
3274 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
3275 or else No
(Access_Definition
(Parent
(N
)))
3276 or else Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Type
3278 Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Subprogram_Type
3280 Set_Entity
(Sel
, Comp
);
3281 Set_Etype
(Sel
, Etype
(Comp
));
3282 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
3283 Check_Implicit_Dereference
(N
, Etype
(Comp
));
3285 -- This also specifies a candidate to resolve the name.
3286 -- Further overloading will be resolved from context.
3287 -- The selector name itself does not carry overloading
3290 Set_Etype
(Nam
, It
.Typ
);
3293 -- Named access type in the context of a renaming
3294 -- declaration with an access definition. Remove
3295 -- inapplicable candidate.
3304 elsif Is_Concurrent_Type
(T
) then
3305 Comp
:= First_Entity
(T
);
3306 while Present
(Comp
)
3307 and then Comp
/= First_Private_Entity
(T
)
3309 if Chars
(Comp
) = Chars
(Sel
) then
3310 if Is_Overloadable
(Comp
) then
3311 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3313 Set_Entity_With_Style_Check
(Sel
, Comp
);
3314 Generate_Reference
(Comp
, Sel
);
3317 Set_Etype
(Sel
, Etype
(Comp
));
3318 Set_Etype
(N
, Etype
(Comp
));
3319 Set_Etype
(Nam
, It
.Typ
);
3321 -- For access type case, introduce explicit dereference for
3322 -- more uniform treatment of entry calls. Do this only once
3323 -- if several interpretations yield an access type.
3325 if Is_Access_Type
(Etype
(Nam
))
3326 and then Nkind
(Nam
) /= N_Explicit_Dereference
3328 Insert_Explicit_Dereference
(Nam
);
3330 (Warn_On_Dereference
, "?d?implicit dereference", N
);
3337 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3340 Get_Next_Interp
(I
, It
);
3343 if Etype
(N
) = Any_Type
3344 and then not Try_Object_Operation
(N
)
3346 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
3347 Set_Entity
(Sel
, Any_Id
);
3348 Set_Etype
(Sel
, Any_Type
);
3350 end Analyze_Overloaded_Selected_Component
;
3352 ----------------------------------
3353 -- Analyze_Qualified_Expression --
3354 ----------------------------------
3356 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
3357 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
3358 Expr
: constant Node_Id
:= Expression
(N
);
3364 Analyze_Expression
(Expr
);
3366 Set_Etype
(N
, Any_Type
);
3371 if T
= Any_Type
then
3375 Check_Fully_Declared
(T
, N
);
3377 -- If expected type is class-wide, check for exact match before
3378 -- expansion, because if the expression is a dispatching call it
3379 -- may be rewritten as explicit dereference with class-wide result.
3380 -- If expression is overloaded, retain only interpretations that
3381 -- will yield exact matches.
3383 if Is_Class_Wide_Type
(T
) then
3384 if not Is_Overloaded
(Expr
) then
3385 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
) then
3386 if Nkind
(Expr
) = N_Aggregate
then
3387 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
3389 Wrong_Type
(Expr
, T
);
3394 Get_First_Interp
(Expr
, I
, It
);
3396 while Present
(It
.Nam
) loop
3397 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
3401 Get_Next_Interp
(I
, It
);
3407 end Analyze_Qualified_Expression
;
3409 -----------------------------------
3410 -- Analyze_Quantified_Expression --
3411 -----------------------------------
3413 procedure Analyze_Quantified_Expression
(N
: Node_Id
) is
3414 QE_Scop
: Entity_Id
;
3416 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean;
3417 -- If the iterator is part of a quantified expression, and the range is
3418 -- known to be statically empty, emit a warning and replace expression
3419 -- with its static value. Returns True if the replacement occurs.
3421 --------------------
3422 -- Is_Empty_Range --
3423 --------------------
3425 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean is
3426 Loc
: constant Source_Ptr
:= Sloc
(N
);
3429 if Is_Array_Type
(Typ
)
3430 and then Compile_Time_Known_Bounds
(Typ
)
3432 (Expr_Value
(Type_Low_Bound
(Etype
(First_Index
(Typ
)))) >
3433 Expr_Value
(Type_High_Bound
(Etype
(First_Index
(Typ
)))))
3435 Preanalyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
3437 if All_Present
(N
) then
3439 ("??quantified expression with ALL "
3440 & "over a null range has value True", N
);
3441 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3445 ("??quantified expression with SOME "
3446 & "over a null range has value False", N
);
3447 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
3458 -- Start of processing for Analyze_Quantified_Expression
3461 Check_SPARK_Restriction
("quantified expression is not allowed", N
);
3463 -- Create a scope to emulate the loop-like behavior of the quantified
3464 -- expression. The scope is needed to provide proper visibility of the
3467 QE_Scop
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Sloc
(N
), 'L');
3468 Set_Etype
(QE_Scop
, Standard_Void_Type
);
3469 Set_Scope
(QE_Scop
, Current_Scope
);
3470 Set_Parent
(QE_Scop
, N
);
3472 Push_Scope
(QE_Scop
);
3474 -- All constituents are preanalyzed and resolved to avoid untimely
3475 -- generation of various temporaries and types. Full analysis and
3476 -- expansion is carried out when the quantified expression is
3477 -- transformed into an expression with actions.
3479 if Present
(Iterator_Specification
(N
)) then
3480 Preanalyze
(Iterator_Specification
(N
));
3482 if Is_Entity_Name
(Name
(Iterator_Specification
(N
)))
3483 and then Is_Empty_Range
(Etype
(Name
(Iterator_Specification
(N
))))
3489 Preanalyze
(Loop_Parameter_Specification
(N
));
3492 Preanalyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
3496 Set_Etype
(N
, Standard_Boolean
);
3497 end Analyze_Quantified_Expression
;
3503 procedure Analyze_Range
(N
: Node_Id
) is
3504 L
: constant Node_Id
:= Low_Bound
(N
);
3505 H
: constant Node_Id
:= High_Bound
(N
);
3506 I1
, I2
: Interp_Index
;
3509 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
3510 -- Verify the compatibility of two types, and choose the
3511 -- non universal one if the other is universal.
3513 procedure Check_High_Bound
(T
: Entity_Id
);
3514 -- Test one interpretation of the low bound against all those
3515 -- of the high bound.
3517 procedure Check_Universal_Expression
(N
: Node_Id
);
3518 -- In Ada 83, reject bounds of a universal range that are not literals
3521 -----------------------
3522 -- Check_Common_Type --
3523 -----------------------
3525 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
3527 if Covers
(T1
=> T1
, T2
=> T2
)
3529 Covers
(T1
=> T2
, T2
=> T1
)
3531 if T1
= Universal_Integer
3532 or else T1
= Universal_Real
3533 or else T1
= Any_Character
3535 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
3538 Add_One_Interp
(N
, T1
, T1
);
3541 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
3544 end Check_Common_Type
;
3546 ----------------------
3547 -- Check_High_Bound --
3548 ----------------------
3550 procedure Check_High_Bound
(T
: Entity_Id
) is
3552 if not Is_Overloaded
(H
) then
3553 Check_Common_Type
(T
, Etype
(H
));
3555 Get_First_Interp
(H
, I2
, It2
);
3556 while Present
(It2
.Typ
) loop
3557 Check_Common_Type
(T
, It2
.Typ
);
3558 Get_Next_Interp
(I2
, It2
);
3561 end Check_High_Bound
;
3563 -----------------------------
3564 -- Is_Universal_Expression --
3565 -----------------------------
3567 procedure Check_Universal_Expression
(N
: Node_Id
) is
3569 if Etype
(N
) = Universal_Integer
3570 and then Nkind
(N
) /= N_Integer_Literal
3571 and then not Is_Entity_Name
(N
)
3572 and then Nkind
(N
) /= N_Attribute_Reference
3574 Error_Msg_N
("illegal bound in discrete range", N
);
3576 end Check_Universal_Expression
;
3578 -- Start of processing for Analyze_Range
3581 Set_Etype
(N
, Any_Type
);
3582 Analyze_Expression
(L
);
3583 Analyze_Expression
(H
);
3585 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
3589 if not Is_Overloaded
(L
) then
3590 Check_High_Bound
(Etype
(L
));
3592 Get_First_Interp
(L
, I1
, It1
);
3593 while Present
(It1
.Typ
) loop
3594 Check_High_Bound
(It1
.Typ
);
3595 Get_Next_Interp
(I1
, It1
);
3599 -- If result is Any_Type, then we did not find a compatible pair
3601 if Etype
(N
) = Any_Type
then
3602 Error_Msg_N
("incompatible types in range ", N
);
3606 if Ada_Version
= Ada_83
3608 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
3609 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
3611 Check_Universal_Expression
(L
);
3612 Check_Universal_Expression
(H
);
3615 Check_Function_Writable_Actuals
(N
);
3618 -----------------------
3619 -- Analyze_Reference --
3620 -----------------------
3622 procedure Analyze_Reference
(N
: Node_Id
) is
3623 P
: constant Node_Id
:= Prefix
(N
);
3626 Acc_Type
: Entity_Id
;
3631 -- An interesting error check, if we take the 'Reference of an object
3632 -- for which a pragma Atomic or Volatile has been given, and the type
3633 -- of the object is not Atomic or Volatile, then we are in trouble. The
3634 -- problem is that no trace of the atomic/volatile status will remain
3635 -- for the backend to respect when it deals with the resulting pointer,
3636 -- since the pointer type will not be marked atomic (it is a pointer to
3637 -- the base type of the object).
3639 -- It is not clear if that can ever occur, but in case it does, we will
3640 -- generate an error message. Not clear if this message can ever be
3641 -- generated, and pretty clear that it represents a bug if it is, still
3642 -- seems worth checking, except in CodePeer mode where we do not really
3643 -- care and don't want to bother the user.
3647 if Is_Entity_Name
(P
)
3648 and then Is_Object_Reference
(P
)
3649 and then not CodePeer_Mode
3654 if (Has_Atomic_Components
(E
)
3655 and then not Has_Atomic_Components
(T
))
3657 (Has_Volatile_Components
(E
)
3658 and then not Has_Volatile_Components
(T
))
3659 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
3660 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
3662 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
3666 -- Carry on with normal processing
3668 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
3669 Set_Etype
(Acc_Type
, Acc_Type
);
3670 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
3671 Set_Etype
(N
, Acc_Type
);
3672 end Analyze_Reference
;
3674 --------------------------------
3675 -- Analyze_Selected_Component --
3676 --------------------------------
3678 -- Prefix is a record type or a task or protected type. In the latter case,
3679 -- the selector must denote a visible entry.
3681 procedure Analyze_Selected_Component
(N
: Node_Id
) is
3682 Name
: constant Node_Id
:= Prefix
(N
);
3683 Sel
: constant Node_Id
:= Selector_Name
(N
);
3686 Has_Candidate
: Boolean := False;
3689 Pent
: Entity_Id
:= Empty
;
3690 Prefix_Type
: Entity_Id
;
3692 Type_To_Use
: Entity_Id
;
3693 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
3694 -- a class-wide type, we use its root type, whose components are
3695 -- present in the class-wide type.
3697 Is_Single_Concurrent_Object
: Boolean;
3698 -- Set True if the prefix is a single task or a single protected object
3700 procedure Find_Component_In_Instance
(Rec
: Entity_Id
);
3701 -- In an instance, a component of a private extension may not be visible
3702 -- while it was visible in the generic. Search candidate scope for a
3703 -- component with the proper identifier. This is only done if all other
3704 -- searches have failed. When the match is found (it always will be),
3705 -- the Etype of both N and Sel are set from this component, and the
3706 -- entity of Sel is set to reference this component.
3708 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
3709 -- It is known that the parent of N denotes a subprogram call. Comp
3710 -- is an overloadable component of the concurrent type of the prefix.
3711 -- Determine whether all formals of the parent of N and Comp are mode
3712 -- conformant. If the parent node is not analyzed yet it may be an
3713 -- indexed component rather than a function call.
3715 --------------------------------
3716 -- Find_Component_In_Instance --
3717 --------------------------------
3719 procedure Find_Component_In_Instance
(Rec
: Entity_Id
) is
3723 Comp
:= First_Component
(Rec
);
3724 while Present
(Comp
) loop
3725 if Chars
(Comp
) = Chars
(Sel
) then
3726 Set_Entity_With_Style_Check
(Sel
, Comp
);
3727 Set_Etype
(Sel
, Etype
(Comp
));
3728 Set_Etype
(N
, Etype
(Comp
));
3732 Next_Component
(Comp
);
3735 -- This must succeed because code was legal in the generic
3737 raise Program_Error
;
3738 end Find_Component_In_Instance
;
3740 ------------------------------
3741 -- Has_Mode_Conformant_Spec --
3742 ------------------------------
3744 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
3745 Comp_Param
: Entity_Id
;
3747 Param_Typ
: Entity_Id
;
3750 Comp_Param
:= First_Formal
(Comp
);
3752 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
3753 Param
:= First
(Expressions
(Parent
(N
)));
3755 Param
:= First
(Parameter_Associations
(Parent
(N
)));
3758 while Present
(Comp_Param
)
3759 and then Present
(Param
)
3761 Param_Typ
:= Find_Parameter_Type
(Param
);
3763 if Present
(Param_Typ
)
3765 not Conforming_Types
3766 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
3771 Next_Formal
(Comp_Param
);
3775 -- One of the specs has additional formals
3777 if Present
(Comp_Param
) or else Present
(Param
) then
3782 end Has_Mode_Conformant_Spec
;
3784 -- Start of processing for Analyze_Selected_Component
3787 Set_Etype
(N
, Any_Type
);
3789 if Is_Overloaded
(Name
) then
3790 Analyze_Overloaded_Selected_Component
(N
);
3793 elsif Etype
(Name
) = Any_Type
then
3794 Set_Entity
(Sel
, Any_Id
);
3795 Set_Etype
(Sel
, Any_Type
);
3799 Prefix_Type
:= Etype
(Name
);
3802 if Is_Access_Type
(Prefix_Type
) then
3804 -- A RACW object can never be used as prefix of a selected component
3805 -- since that means it is dereferenced without being a controlling
3806 -- operand of a dispatching operation (RM E.2.2(16/1)). Before
3807 -- reporting an error, we must check whether this is actually a
3808 -- dispatching call in prefix form.
3810 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
3811 and then Comes_From_Source
(N
)
3813 if Try_Object_Operation
(N
) then
3817 ("invalid dereference of a remote access-to-class-wide value",
3821 -- Normal case of selected component applied to access type
3824 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
3826 if Is_Entity_Name
(Name
) then
3827 Pent
:= Entity
(Name
);
3828 elsif Nkind
(Name
) = N_Selected_Component
3829 and then Is_Entity_Name
(Selector_Name
(Name
))
3831 Pent
:= Entity
(Selector_Name
(Name
));
3834 Prefix_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, Name
);
3837 -- If we have an explicit dereference of a remote access-to-class-wide
3838 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
3839 -- have to check for the case of a prefix that is a controlling operand
3840 -- of a prefixed dispatching call, as the dereference is legal in that
3841 -- case. Normally this condition is checked in Validate_Remote_Access_
3842 -- To_Class_Wide_Type, but we have to defer the checking for selected
3843 -- component prefixes because of the prefixed dispatching call case.
3844 -- Note that implicit dereferences are checked for this just above.
3846 elsif Nkind
(Name
) = N_Explicit_Dereference
3847 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Name
)))
3848 and then Comes_From_Source
(N
)
3850 if Try_Object_Operation
(N
) then
3854 ("invalid dereference of a remote access-to-class-wide value",
3859 -- (Ada 2005): if the prefix is the limited view of a type, and
3860 -- the context already includes the full view, use the full view
3861 -- in what follows, either to retrieve a component of to find
3862 -- a primitive operation. If the prefix is an explicit dereference,
3863 -- set the type of the prefix to reflect this transformation.
3864 -- If the non-limited view is itself an incomplete type, get the
3865 -- full view if available.
3867 if Is_Incomplete_Type
(Prefix_Type
)
3868 and then From_With_Type
(Prefix_Type
)
3869 and then Present
(Non_Limited_View
(Prefix_Type
))
3871 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
3873 if Nkind
(N
) = N_Explicit_Dereference
then
3874 Set_Etype
(Prefix
(N
), Prefix_Type
);
3877 elsif Ekind
(Prefix_Type
) = E_Class_Wide_Type
3878 and then From_With_Type
(Prefix_Type
)
3879 and then Present
(Non_Limited_View
(Etype
(Prefix_Type
)))
3882 Class_Wide_Type
(Non_Limited_View
(Etype
(Prefix_Type
)));
3884 if Nkind
(N
) = N_Explicit_Dereference
then
3885 Set_Etype
(Prefix
(N
), Prefix_Type
);
3889 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
3890 Prefix_Type
:= Base_Type
(Prefix_Type
);
3893 Type_To_Use
:= Prefix_Type
;
3895 -- For class-wide types, use the entity list of the root type. This
3896 -- indirection is specially important for private extensions because
3897 -- only the root type get switched (not the class-wide type).
3899 if Is_Class_Wide_Type
(Prefix_Type
) then
3900 Type_To_Use
:= Root_Type
(Prefix_Type
);
3903 -- If the prefix is a single concurrent object, use its name in error
3904 -- messages, rather than that of its anonymous type.
3906 Is_Single_Concurrent_Object
:=
3907 Is_Concurrent_Type
(Prefix_Type
)
3908 and then Is_Internal_Name
(Chars
(Prefix_Type
))
3909 and then not Is_Derived_Type
(Prefix_Type
)
3910 and then Is_Entity_Name
(Name
);
3912 Comp
:= First_Entity
(Type_To_Use
);
3914 -- If the selector has an original discriminant, the node appears in
3915 -- an instance. Replace the discriminant with the corresponding one
3916 -- in the current discriminated type. For nested generics, this must
3917 -- be done transitively, so note the new original discriminant.
3919 if Nkind
(Sel
) = N_Identifier
3920 and then In_Instance
3921 and then Present
(Original_Discriminant
(Sel
))
3923 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
3925 -- Mark entity before rewriting, for completeness and because
3926 -- subsequent semantic checks might examine the original node.
3928 Set_Entity
(Sel
, Comp
);
3929 Rewrite
(Selector_Name
(N
), New_Occurrence_Of
(Comp
, Sloc
(N
)));
3930 Set_Original_Discriminant
(Selector_Name
(N
), Comp
);
3931 Set_Etype
(N
, Etype
(Comp
));
3932 Check_Implicit_Dereference
(N
, Etype
(Comp
));
3934 if Is_Access_Type
(Etype
(Name
)) then
3935 Insert_Explicit_Dereference
(Name
);
3936 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
3939 elsif Is_Record_Type
(Prefix_Type
) then
3941 -- Find component with given name. In an instance, if the node is
3942 -- known as a prefixed call, do not examine components whose
3943 -- visibility may be accidental.
3945 while Present
(Comp
) and then not Is_Prefixed_Call
(N
) loop
3946 if Chars
(Comp
) = Chars
(Sel
)
3947 and then Is_Visible_Component
(Comp
, N
)
3949 Set_Entity_With_Style_Check
(Sel
, Comp
);
3950 Set_Etype
(Sel
, Etype
(Comp
));
3952 if Ekind
(Comp
) = E_Discriminant
then
3953 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
3955 ("cannot reference discriminant of unchecked union",
3959 if Is_Generic_Type
(Prefix_Type
)
3961 Is_Generic_Type
(Root_Type
(Prefix_Type
))
3963 Set_Original_Discriminant
(Sel
, Comp
);
3967 -- Resolve the prefix early otherwise it is not possible to
3968 -- build the actual subtype of the component: it may need
3969 -- to duplicate this prefix and duplication is only allowed
3970 -- on fully resolved expressions.
3974 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
3975 -- subtypes in a package specification.
3978 -- limited with Pkg;
3980 -- type Acc_Inc is access Pkg.T;
3982 -- N : Natural := X.all.Comp; -- ERROR, limited view
3983 -- end Pkg; -- Comp is not visible
3985 if Nkind
(Name
) = N_Explicit_Dereference
3986 and then From_With_Type
(Etype
(Prefix
(Name
)))
3987 and then not Is_Potentially_Use_Visible
(Etype
(Name
))
3988 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
3989 N_Package_Specification
3992 ("premature usage of incomplete}", Prefix
(Name
),
3993 Etype
(Prefix
(Name
)));
3996 -- We never need an actual subtype for the case of a selection
3997 -- for a indexed component of a non-packed array, since in
3998 -- this case gigi generates all the checks and can find the
3999 -- necessary bounds information.
4001 -- We also do not need an actual subtype for the case of a
4002 -- first, last, length, or range attribute applied to a
4003 -- non-packed array, since gigi can again get the bounds in
4004 -- these cases (gigi cannot handle the packed case, since it
4005 -- has the bounds of the packed array type, not the original
4006 -- bounds of the type). However, if the prefix is itself a
4007 -- selected component, as in a.b.c (i), gigi may regard a.b.c
4008 -- as a dynamic-sized temporary, so we do generate an actual
4009 -- subtype for this case.
4011 Parent_N
:= Parent
(N
);
4013 if not Is_Packed
(Etype
(Comp
))
4015 ((Nkind
(Parent_N
) = N_Indexed_Component
4016 and then Nkind
(Name
) /= N_Selected_Component
)
4018 (Nkind
(Parent_N
) = N_Attribute_Reference
4019 and then (Attribute_Name
(Parent_N
) = Name_First
4021 Attribute_Name
(Parent_N
) = Name_Last
4023 Attribute_Name
(Parent_N
) = Name_Length
4025 Attribute_Name
(Parent_N
) = Name_Range
)))
4027 Set_Etype
(N
, Etype
(Comp
));
4029 -- If full analysis is not enabled, we do not generate an
4030 -- actual subtype, because in the absence of expansion
4031 -- reference to a formal of a protected type, for example,
4032 -- will not be properly transformed, and will lead to
4033 -- out-of-scope references in gigi.
4035 -- In all other cases, we currently build an actual subtype.
4036 -- It seems likely that many of these cases can be avoided,
4037 -- but right now, the front end makes direct references to the
4038 -- bounds (e.g. in generating a length check), and if we do
4039 -- not make an actual subtype, we end up getting a direct
4040 -- reference to a discriminant, which will not do.
4042 elsif Full_Analysis
then
4044 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
4045 Insert_Action
(N
, Act_Decl
);
4047 if No
(Act_Decl
) then
4048 Set_Etype
(N
, Etype
(Comp
));
4051 -- Component type depends on discriminants. Enter the
4052 -- main attributes of the subtype.
4055 Subt
: constant Entity_Id
:=
4056 Defining_Identifier
(Act_Decl
);
4059 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
4060 Set_Ekind
(Subt
, Ekind
(Etype
(Comp
)));
4061 Set_Etype
(N
, Subt
);
4065 -- If Full_Analysis not enabled, just set the Etype
4068 Set_Etype
(N
, Etype
(Comp
));
4071 Check_Implicit_Dereference
(N
, Etype
(N
));
4075 -- If the prefix is a private extension, check only the visible
4076 -- components of the partial view. This must include the tag,
4077 -- which can appear in expanded code in a tag check.
4079 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
4080 and then Chars
(Selector_Name
(N
)) /= Name_uTag
4082 exit when Comp
= Last_Entity
(Type_To_Use
);
4088 -- Ada 2005 (AI-252): The selected component can be interpreted as
4089 -- a prefixed view of a subprogram. Depending on the context, this is
4090 -- either a name that can appear in a renaming declaration, or part
4091 -- of an enclosing call given in prefix form.
4093 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
4094 -- selected component should resolve to a name.
4096 if Ada_Version
>= Ada_2005
4097 and then Is_Tagged_Type
(Prefix_Type
)
4098 and then not Is_Concurrent_Type
(Prefix_Type
)
4100 if Nkind
(Parent
(N
)) = N_Generic_Association
4101 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
4102 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
4104 if Find_Primitive_Operation
(N
) then
4108 elsif Try_Object_Operation
(N
) then
4112 -- If the transformation fails, it will be necessary to redo the
4113 -- analysis with all errors enabled, to indicate candidate
4114 -- interpretations and reasons for each failure ???
4118 elsif Is_Private_Type
(Prefix_Type
) then
4120 -- Allow access only to discriminants of the type. If the type has
4121 -- no full view, gigi uses the parent type for the components, so we
4122 -- do the same here.
4124 if No
(Full_View
(Prefix_Type
)) then
4125 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
4126 Comp
:= First_Entity
(Type_To_Use
);
4129 while Present
(Comp
) loop
4130 if Chars
(Comp
) = Chars
(Sel
) then
4131 if Ekind
(Comp
) = E_Discriminant
then
4132 Set_Entity_With_Style_Check
(Sel
, Comp
);
4133 Generate_Reference
(Comp
, Sel
);
4135 Set_Etype
(Sel
, Etype
(Comp
));
4136 Set_Etype
(N
, Etype
(Comp
));
4137 Check_Implicit_Dereference
(N
, Etype
(N
));
4139 if Is_Generic_Type
(Prefix_Type
)
4140 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
4142 Set_Original_Discriminant
(Sel
, Comp
);
4145 -- Before declaring an error, check whether this is tagged
4146 -- private type and a call to a primitive operation.
4148 elsif Ada_Version
>= Ada_2005
4149 and then Is_Tagged_Type
(Prefix_Type
)
4150 and then Try_Object_Operation
(N
)
4155 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4156 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
4157 Set_Entity
(Sel
, Any_Id
);
4158 Set_Etype
(N
, Any_Type
);
4167 elsif Is_Concurrent_Type
(Prefix_Type
) then
4169 -- Find visible operation with given name. For a protected type,
4170 -- the possible candidates are discriminants, entries or protected
4171 -- procedures. For a task type, the set can only include entries or
4172 -- discriminants if the task type is not an enclosing scope. If it
4173 -- is an enclosing scope (e.g. in an inner task) then all entities
4174 -- are visible, but the prefix must denote the enclosing scope, i.e.
4175 -- can only be a direct name or an expanded name.
4177 Set_Etype
(Sel
, Any_Type
);
4178 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
4180 while Present
(Comp
) loop
4181 if Chars
(Comp
) = Chars
(Sel
) then
4182 if Is_Overloadable
(Comp
) then
4183 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
4185 -- If the prefix is tagged, the correct interpretation may
4186 -- lie in the primitive or class-wide operations of the
4187 -- type. Perform a simple conformance check to determine
4188 -- whether Try_Object_Operation should be invoked even if
4189 -- a visible entity is found.
4191 if Is_Tagged_Type
(Prefix_Type
)
4193 Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
4195 N_Indexed_Component
)
4196 and then Has_Mode_Conformant_Spec
(Comp
)
4198 Has_Candidate
:= True;
4201 -- Note: a selected component may not denote a component of a
4202 -- protected type (4.1.3(7)).
4204 elsif Ekind_In
(Comp
, E_Discriminant
, E_Entry_Family
)
4206 and then not Is_Protected_Type
(Prefix_Type
)
4207 and then Is_Entity_Name
(Name
))
4209 Set_Entity_With_Style_Check
(Sel
, Comp
);
4210 Generate_Reference
(Comp
, Sel
);
4212 -- The selector is not overloadable, so we have a candidate
4215 Has_Candidate
:= True;
4221 Set_Etype
(Sel
, Etype
(Comp
));
4222 Set_Etype
(N
, Etype
(Comp
));
4224 if Ekind
(Comp
) = E_Discriminant
then
4225 Set_Original_Discriminant
(Sel
, Comp
);
4228 -- For access type case, introduce explicit dereference for
4229 -- more uniform treatment of entry calls.
4231 if Is_Access_Type
(Etype
(Name
)) then
4232 Insert_Explicit_Dereference
(Name
);
4234 (Warn_On_Dereference
, "?d?implicit dereference", N
);
4240 exit when not In_Scope
4242 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
4245 -- If there is no visible entity with the given name or none of the
4246 -- visible entities are plausible interpretations, check whether
4247 -- there is some other primitive operation with that name.
4249 if Ada_Version
>= Ada_2005
4250 and then Is_Tagged_Type
(Prefix_Type
)
4252 if (Etype
(N
) = Any_Type
4253 or else not Has_Candidate
)
4254 and then Try_Object_Operation
(N
)
4258 -- If the context is not syntactically a procedure call, it
4259 -- may be a call to a primitive function declared outside of
4260 -- the synchronized type.
4262 -- If the context is a procedure call, there might still be
4263 -- an overloading between an entry and a primitive procedure
4264 -- declared outside of the synchronized type, called in prefix
4265 -- notation. This is harder to disambiguate because in one case
4266 -- the controlling formal is implicit ???
4268 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
4269 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
4270 and then Try_Object_Operation
(N
)
4275 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
4276 -- entry or procedure of a tagged concurrent type we must check
4277 -- if there are class-wide subprograms covering the primitive. If
4278 -- true then Try_Object_Operation reports the error.
4281 and then Is_Concurrent_Type
(Prefix_Type
)
4282 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
4284 -- Duplicate the call. This is required to avoid problems with
4285 -- the tree transformations performed by Try_Object_Operation.
4286 -- Set properly the parent of the copied call, because it is
4287 -- about to be reanalyzed.
4291 Par
: constant Node_Id
:= New_Copy_Tree
(Parent
(N
));
4294 Set_Parent
(Par
, Parent
(Parent
(N
)));
4296 if Try_Object_Operation
4297 (Sinfo
.Name
(Par
), CW_Test_Only
=> True)
4305 if Etype
(N
) = Any_Type
and then Is_Protected_Type
(Prefix_Type
) then
4307 -- Case of a prefix of a protected type: selector might denote
4308 -- an invisible private component.
4310 Comp
:= First_Private_Entity
(Base_Type
(Prefix_Type
));
4311 while Present
(Comp
) and then Chars
(Comp
) /= Chars
(Sel
) loop
4315 if Present
(Comp
) then
4316 if Is_Single_Concurrent_Object
then
4317 Error_Msg_Node_2
:= Entity
(Name
);
4318 Error_Msg_NE
("invisible selector& for &", N
, Sel
);
4321 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4322 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
4328 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
4333 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
4336 -- If N still has no type, the component is not defined in the prefix
4338 if Etype
(N
) = Any_Type
then
4340 if Is_Single_Concurrent_Object
then
4341 Error_Msg_Node_2
:= Entity
(Name
);
4342 Error_Msg_NE
("no selector& for&", N
, Sel
);
4344 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
4346 elsif Is_Generic_Type
(Prefix_Type
)
4347 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
4348 and then Prefix_Type
/= Etype
(Prefix_Type
)
4349 and then Is_Record_Type
(Etype
(Prefix_Type
))
4351 -- If this is a derived formal type, the parent may have
4352 -- different visibility at this point. Try for an inherited
4353 -- component before reporting an error.
4355 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
4356 Analyze_Selected_Component
(N
);
4359 -- Similarly, if this is the actual for a formal derived type, the
4360 -- component inherited from the generic parent may not be visible
4361 -- in the actual, but the selected component is legal.
4363 elsif Ekind
(Prefix_Type
) = E_Record_Subtype_With_Private
4364 and then Is_Generic_Actual_Type
(Prefix_Type
)
4365 and then Present
(Full_View
(Prefix_Type
))
4368 Find_Component_In_Instance
4369 (Generic_Parent_Type
(Parent
(Prefix_Type
)));
4372 -- Finally, the formal and the actual may be private extensions,
4373 -- but the generic is declared in a child unit of the parent, and
4374 -- an additional step is needed to retrieve the proper scope.
4377 and then Present
(Parent_Subtype
(Etype
(Base_Type
(Prefix_Type
))))
4379 Find_Component_In_Instance
4380 (Parent_Subtype
(Etype
(Base_Type
(Prefix_Type
))));
4383 -- Component not found, specialize error message when appropriate
4386 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
4388 -- Check whether this is a component of the base type which
4389 -- is absent from a statically constrained subtype. This will
4390 -- raise constraint error at run time, but is not a compile-
4391 -- time error. When the selector is illegal for base type as
4392 -- well fall through and generate a compilation error anyway.
4394 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
4395 while Present
(Comp
) loop
4396 if Chars
(Comp
) = Chars
(Sel
)
4397 and then Is_Visible_Component
(Comp
)
4399 Set_Entity_With_Style_Check
(Sel
, Comp
);
4400 Generate_Reference
(Comp
, Sel
);
4401 Set_Etype
(Sel
, Etype
(Comp
));
4402 Set_Etype
(N
, Etype
(Comp
));
4404 -- Emit appropriate message. Gigi will replace the
4405 -- node subsequently with the appropriate Raise.
4407 -- In Alfa mode, this is made into an error to simplify
4408 -- the processing of the formal verification backend.
4411 Apply_Compile_Time_Constraint_Error
4412 (N
, "component not present in }",
4413 CE_Discriminant_Check_Failed
,
4414 Ent
=> Prefix_Type
, Rep
=> False);
4416 Apply_Compile_Time_Constraint_Error
4417 (N
, "component not present in }??",
4418 CE_Discriminant_Check_Failed
,
4419 Ent
=> Prefix_Type
, Rep
=> False);
4422 Set_Raises_Constraint_Error
(N
);
4426 Next_Component
(Comp
);
4431 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4432 Error_Msg_NE
("no selector& for}", N
, Sel
);
4434 -- Add information in the case of an incomplete prefix
4436 if Is_Incomplete_Type
(Type_To_Use
) then
4438 Inc
: constant Entity_Id
:= First_Subtype
(Type_To_Use
);
4441 if From_With_Type
(Scope
(Type_To_Use
)) then
4443 ("\limited view of& has no components", N
, Inc
);
4447 ("\premature usage of incomplete type&", N
, Inc
);
4449 if Nkind
(Parent
(Inc
)) =
4450 N_Incomplete_Type_Declaration
4452 -- Record location of premature use in entity so that
4453 -- a continuation message is generated when the
4454 -- completion is seen.
4456 Set_Premature_Use
(Parent
(Inc
), N
);
4462 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
4465 Set_Entity
(Sel
, Any_Id
);
4466 Set_Etype
(Sel
, Any_Type
);
4468 end Analyze_Selected_Component
;
4470 ---------------------------
4471 -- Analyze_Short_Circuit --
4472 ---------------------------
4474 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
4475 L
: constant Node_Id
:= Left_Opnd
(N
);
4476 R
: constant Node_Id
:= Right_Opnd
(N
);
4481 Analyze_Expression
(L
);
4482 Analyze_Expression
(R
);
4483 Set_Etype
(N
, Any_Type
);
4485 if not Is_Overloaded
(L
) then
4486 if Root_Type
(Etype
(L
)) = Standard_Boolean
4487 and then Has_Compatible_Type
(R
, Etype
(L
))
4489 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
4493 Get_First_Interp
(L
, Ind
, It
);
4494 while Present
(It
.Typ
) loop
4495 if Root_Type
(It
.Typ
) = Standard_Boolean
4496 and then Has_Compatible_Type
(R
, It
.Typ
)
4498 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
4501 Get_Next_Interp
(Ind
, It
);
4505 -- Here we have failed to find an interpretation. Clearly we know that
4506 -- it is not the case that both operands can have an interpretation of
4507 -- Boolean, but this is by far the most likely intended interpretation.
4508 -- So we simply resolve both operands as Booleans, and at least one of
4509 -- these resolutions will generate an error message, and we do not need
4510 -- to give another error message on the short circuit operation itself.
4512 if Etype
(N
) = Any_Type
then
4513 Resolve
(L
, Standard_Boolean
);
4514 Resolve
(R
, Standard_Boolean
);
4515 Set_Etype
(N
, Standard_Boolean
);
4517 end Analyze_Short_Circuit
;
4523 procedure Analyze_Slice
(N
: Node_Id
) is
4524 D
: constant Node_Id
:= Discrete_Range
(N
);
4525 P
: constant Node_Id
:= Prefix
(N
);
4526 Array_Type
: Entity_Id
;
4527 Index_Type
: Entity_Id
;
4529 procedure Analyze_Overloaded_Slice
;
4530 -- If the prefix is overloaded, select those interpretations that
4531 -- yield a one-dimensional array type.
4533 ------------------------------
4534 -- Analyze_Overloaded_Slice --
4535 ------------------------------
4537 procedure Analyze_Overloaded_Slice
is
4543 Set_Etype
(N
, Any_Type
);
4545 Get_First_Interp
(P
, I
, It
);
4546 while Present
(It
.Nam
) loop
4549 if Is_Access_Type
(Typ
) then
4550 Typ
:= Designated_Type
(Typ
);
4552 (Warn_On_Dereference
, "?d?implicit dereference", N
);
4555 if Is_Array_Type
(Typ
)
4556 and then Number_Dimensions
(Typ
) = 1
4557 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
4559 Add_One_Interp
(N
, Typ
, Typ
);
4562 Get_Next_Interp
(I
, It
);
4565 if Etype
(N
) = Any_Type
then
4566 Error_Msg_N
("expect array type in prefix of slice", N
);
4568 end Analyze_Overloaded_Slice
;
4570 -- Start of processing for Analyze_Slice
4573 if Comes_From_Source
(N
) then
4574 Check_SPARK_Restriction
("slice is not allowed", N
);
4580 if Is_Overloaded
(P
) then
4581 Analyze_Overloaded_Slice
;
4584 Array_Type
:= Etype
(P
);
4585 Set_Etype
(N
, Any_Type
);
4587 if Is_Access_Type
(Array_Type
) then
4588 Array_Type
:= Designated_Type
(Array_Type
);
4589 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4592 if not Is_Array_Type
(Array_Type
) then
4593 Wrong_Type
(P
, Any_Array
);
4595 elsif Number_Dimensions
(Array_Type
) > 1 then
4597 ("type is not one-dimensional array in slice prefix", N
);
4600 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
4601 Index_Type
:= Etype
(String_Literal_Low_Bound
(Array_Type
));
4603 Index_Type
:= Etype
(First_Index
(Array_Type
));
4606 if not Has_Compatible_Type
(D
, Index_Type
) then
4607 Wrong_Type
(D
, Index_Type
);
4609 Set_Etype
(N
, Array_Type
);
4615 -----------------------------
4616 -- Analyze_Type_Conversion --
4617 -----------------------------
4619 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
4620 Expr
: constant Node_Id
:= Expression
(N
);
4624 -- If Conversion_OK is set, then the Etype is already set, and the
4625 -- only processing required is to analyze the expression. This is
4626 -- used to construct certain "illegal" conversions which are not
4627 -- allowed by Ada semantics, but can be handled OK by Gigi, see
4628 -- Sinfo for further details.
4630 if Conversion_OK
(N
) then
4635 -- Otherwise full type analysis is required, as well as some semantic
4636 -- checks to make sure the argument of the conversion is appropriate.
4638 Find_Type
(Subtype_Mark
(N
));
4639 T
:= Entity
(Subtype_Mark
(N
));
4641 Check_Fully_Declared
(T
, N
);
4642 Analyze_Expression
(Expr
);
4643 Validate_Remote_Type_Type_Conversion
(N
);
4645 -- Only remaining step is validity checks on the argument. These
4646 -- are skipped if the conversion does not come from the source.
4648 if not Comes_From_Source
(N
) then
4651 -- If there was an error in a generic unit, no need to replicate the
4652 -- error message. Conversely, constant-folding in the generic may
4653 -- transform the argument of a conversion into a string literal, which
4654 -- is legal. Therefore the following tests are not performed in an
4657 elsif In_Instance
then
4660 elsif Nkind
(Expr
) = N_Null
then
4661 Error_Msg_N
("argument of conversion cannot be null", N
);
4662 Error_Msg_N
("\use qualified expression instead", N
);
4663 Set_Etype
(N
, Any_Type
);
4665 elsif Nkind
(Expr
) = N_Aggregate
then
4666 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
4667 Error_Msg_N
("\use qualified expression instead", N
);
4669 elsif Nkind
(Expr
) = N_Allocator
then
4670 Error_Msg_N
("argument of conversion cannot be an allocator", N
);
4671 Error_Msg_N
("\use qualified expression instead", N
);
4673 elsif Nkind
(Expr
) = N_String_Literal
then
4674 Error_Msg_N
("argument of conversion cannot be string literal", N
);
4675 Error_Msg_N
("\use qualified expression instead", N
);
4677 elsif Nkind
(Expr
) = N_Character_Literal
then
4678 if Ada_Version
= Ada_83
then
4681 Error_Msg_N
("argument of conversion cannot be character literal",
4683 Error_Msg_N
("\use qualified expression instead", N
);
4686 elsif Nkind
(Expr
) = N_Attribute_Reference
4688 (Attribute_Name
(Expr
) = Name_Access
or else
4689 Attribute_Name
(Expr
) = Name_Unchecked_Access
or else
4690 Attribute_Name
(Expr
) = Name_Unrestricted_Access
)
4692 Error_Msg_N
("argument of conversion cannot be access", N
);
4693 Error_Msg_N
("\use qualified expression instead", N
);
4695 end Analyze_Type_Conversion
;
4697 ----------------------
4698 -- Analyze_Unary_Op --
4699 ----------------------
4701 procedure Analyze_Unary_Op
(N
: Node_Id
) is
4702 R
: constant Node_Id
:= Right_Opnd
(N
);
4703 Op_Id
: Entity_Id
:= Entity
(N
);
4706 Set_Etype
(N
, Any_Type
);
4707 Candidate_Type
:= Empty
;
4709 Analyze_Expression
(R
);
4711 if Present
(Op_Id
) then
4712 if Ekind
(Op_Id
) = E_Operator
then
4713 Find_Unary_Types
(R
, Op_Id
, N
);
4715 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4719 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
4720 while Present
(Op_Id
) loop
4721 if Ekind
(Op_Id
) = E_Operator
then
4722 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
4723 Find_Unary_Types
(R
, Op_Id
, N
);
4726 elsif Is_Overloadable
(Op_Id
) then
4727 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
4730 Op_Id
:= Homonym
(Op_Id
);
4735 end Analyze_Unary_Op
;
4737 ----------------------------------
4738 -- Analyze_Unchecked_Expression --
4739 ----------------------------------
4741 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
4743 Analyze
(Expression
(N
), Suppress
=> All_Checks
);
4744 Set_Etype
(N
, Etype
(Expression
(N
)));
4745 Save_Interps
(Expression
(N
), N
);
4746 end Analyze_Unchecked_Expression
;
4748 ---------------------------------------
4749 -- Analyze_Unchecked_Type_Conversion --
4750 ---------------------------------------
4752 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
4754 Find_Type
(Subtype_Mark
(N
));
4755 Analyze_Expression
(Expression
(N
));
4756 Set_Etype
(N
, Entity
(Subtype_Mark
(N
)));
4757 end Analyze_Unchecked_Type_Conversion
;
4759 ------------------------------------
4760 -- Analyze_User_Defined_Binary_Op --
4761 ------------------------------------
4763 procedure Analyze_User_Defined_Binary_Op
4768 -- Only do analysis if the operator Comes_From_Source, since otherwise
4769 -- the operator was generated by the expander, and all such operators
4770 -- always refer to the operators in package Standard.
4772 if Comes_From_Source
(N
) then
4774 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
4775 F2
: constant Entity_Id
:= Next_Formal
(F1
);
4778 -- Verify that Op_Id is a visible binary function. Note that since
4779 -- we know Op_Id is overloaded, potentially use visible means use
4780 -- visible for sure (RM 9.4(11)).
4782 if Ekind
(Op_Id
) = E_Function
4783 and then Present
(F2
)
4784 and then (Is_Immediately_Visible
(Op_Id
)
4785 or else Is_Potentially_Use_Visible
(Op_Id
))
4786 and then Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
4787 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
4789 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4791 -- If the left operand is overloaded, indicate that the
4792 -- current type is a viable candidate. This is redundant
4793 -- in most cases, but for equality and comparison operators
4794 -- where the context does not impose a type on the operands,
4795 -- setting the proper type is necessary to avoid subsequent
4796 -- ambiguities during resolution, when both user-defined and
4797 -- predefined operators may be candidates.
4799 if Is_Overloaded
(Left_Opnd
(N
)) then
4800 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
4803 if Debug_Flag_E
then
4804 Write_Str
("user defined operator ");
4805 Write_Name
(Chars
(Op_Id
));
4806 Write_Str
(" on node ");
4807 Write_Int
(Int
(N
));
4813 end Analyze_User_Defined_Binary_Op
;
4815 -----------------------------------
4816 -- Analyze_User_Defined_Unary_Op --
4817 -----------------------------------
4819 procedure Analyze_User_Defined_Unary_Op
4824 -- Only do analysis if the operator Comes_From_Source, since otherwise
4825 -- the operator was generated by the expander, and all such operators
4826 -- always refer to the operators in package Standard.
4828 if Comes_From_Source
(N
) then
4830 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
4833 -- Verify that Op_Id is a visible unary function. Note that since
4834 -- we know Op_Id is overloaded, potentially use visible means use
4835 -- visible for sure (RM 9.4(11)).
4837 if Ekind
(Op_Id
) = E_Function
4838 and then No
(Next_Formal
(F
))
4839 and then (Is_Immediately_Visible
(Op_Id
)
4840 or else Is_Potentially_Use_Visible
(Op_Id
))
4841 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
4843 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
4847 end Analyze_User_Defined_Unary_Op
;
4849 ---------------------------
4850 -- Check_Arithmetic_Pair --
4851 ---------------------------
4853 procedure Check_Arithmetic_Pair
4854 (T1
, T2
: Entity_Id
;
4858 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
4860 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
4861 -- Check whether the fixed-point type Typ has a user-defined operator
4862 -- (multiplication or division) that should hide the corresponding
4863 -- predefined operator. Used to implement Ada 2005 AI-264, to make
4864 -- such operators more visible and therefore useful.
4866 -- If the name of the operation is an expanded name with prefix
4867 -- Standard, the predefined universal fixed operator is available,
4868 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
4870 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
4871 -- Get specific type (i.e. non-universal type if there is one)
4877 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
4878 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
4884 -- If the universal_fixed operation is given explicitly the rule
4885 -- concerning primitive operations of the type do not apply.
4887 if Nkind
(N
) = N_Function_Call
4888 and then Nkind
(Name
(N
)) = N_Expanded_Name
4889 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
4894 -- The operation is treated as primitive if it is declared in the
4895 -- same scope as the type, and therefore on the same entity chain.
4897 Ent
:= Next_Entity
(Typ
);
4898 while Present
(Ent
) loop
4899 if Chars
(Ent
) = Chars
(Op
) then
4900 F1
:= First_Formal
(Ent
);
4901 F2
:= Next_Formal
(F1
);
4903 -- The operation counts as primitive if either operand or
4904 -- result are of the given base type, and both operands are
4905 -- fixed point types.
4907 if (Base_Type
(Etype
(F1
)) = Bas
4908 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4911 (Base_Type
(Etype
(F2
)) = Bas
4912 and then Is_Fixed_Point_Type
(Etype
(F1
)))
4915 (Base_Type
(Etype
(Ent
)) = Bas
4916 and then Is_Fixed_Point_Type
(Etype
(F1
))
4917 and then Is_Fixed_Point_Type
(Etype
(F2
)))
4933 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
4935 if T1
= Universal_Integer
or else T1
= Universal_Real
then
4936 return Base_Type
(T2
);
4938 return Base_Type
(T1
);
4942 -- Start of processing for Check_Arithmetic_Pair
4945 if Op_Name
= Name_Op_Add
or else Op_Name
= Name_Op_Subtract
then
4947 if Is_Numeric_Type
(T1
)
4948 and then Is_Numeric_Type
(T2
)
4949 and then (Covers
(T1
=> T1
, T2
=> T2
)
4951 Covers
(T1
=> T2
, T2
=> T1
))
4953 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4956 elsif Op_Name
= Name_Op_Multiply
or else Op_Name
= Name_Op_Divide
then
4958 if Is_Fixed_Point_Type
(T1
)
4959 and then (Is_Fixed_Point_Type
(T2
)
4960 or else T2
= Universal_Real
)
4962 -- If Treat_Fixed_As_Integer is set then the Etype is already set
4963 -- and no further processing is required (this is the case of an
4964 -- operator constructed by Exp_Fixd for a fixed point operation)
4965 -- Otherwise add one interpretation with universal fixed result
4966 -- If the operator is given in functional notation, it comes
4967 -- from source and Fixed_As_Integer cannot apply.
4969 if (Nkind
(N
) not in N_Op
4970 or else not Treat_Fixed_As_Integer
(N
))
4972 (not Has_Fixed_Op
(T1
, Op_Id
)
4973 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4975 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4978 elsif Is_Fixed_Point_Type
(T2
)
4979 and then (Nkind
(N
) not in N_Op
4980 or else not Treat_Fixed_As_Integer
(N
))
4981 and then T1
= Universal_Real
4983 (not Has_Fixed_Op
(T1
, Op_Id
)
4984 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
4986 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
4988 elsif Is_Numeric_Type
(T1
)
4989 and then Is_Numeric_Type
(T2
)
4990 and then (Covers
(T1
=> T1
, T2
=> T2
)
4992 Covers
(T1
=> T2
, T2
=> T1
))
4994 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
4996 elsif Is_Fixed_Point_Type
(T1
)
4997 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
4998 or else T2
= Universal_Integer
)
5000 Add_One_Interp
(N
, Op_Id
, T1
);
5002 elsif T2
= Universal_Real
5003 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5004 and then Op_Name
= Name_Op_Multiply
5006 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5008 elsif T1
= Universal_Real
5009 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5011 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5013 elsif Is_Fixed_Point_Type
(T2
)
5014 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5015 or else T1
= Universal_Integer
)
5016 and then Op_Name
= Name_Op_Multiply
5018 Add_One_Interp
(N
, Op_Id
, T2
);
5020 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
5021 Add_One_Interp
(N
, Op_Id
, T1
);
5023 elsif T2
= Universal_Real
5024 and then T1
= Universal_Integer
5025 and then Op_Name
= Name_Op_Multiply
5027 Add_One_Interp
(N
, Op_Id
, T2
);
5030 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
5032 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
5033 -- set does not require any special processing, since the Etype is
5034 -- already set (case of operation constructed by Exp_Fixed).
5036 if Is_Integer_Type
(T1
)
5037 and then (Covers
(T1
=> T1
, T2
=> T2
)
5039 Covers
(T1
=> T2
, T2
=> T1
))
5041 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5044 elsif Op_Name
= Name_Op_Expon
then
5045 if Is_Numeric_Type
(T1
)
5046 and then not Is_Fixed_Point_Type
(T1
)
5047 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5048 or else T2
= Universal_Integer
)
5050 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5053 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
5055 -- If not one of the predefined operators, the node may be one
5056 -- of the intrinsic functions. Its kind is always specific, and
5057 -- we can use it directly, rather than the name of the operation.
5059 if Is_Integer_Type
(T1
)
5060 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5061 or else T2
= Universal_Integer
)
5063 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5066 end Check_Arithmetic_Pair
;
5068 -------------------------------
5069 -- Check_Misspelled_Selector --
5070 -------------------------------
5072 procedure Check_Misspelled_Selector
5073 (Prefix
: Entity_Id
;
5076 Max_Suggestions
: constant := 2;
5077 Nr_Of_Suggestions
: Natural := 0;
5079 Suggestion_1
: Entity_Id
:= Empty
;
5080 Suggestion_2
: Entity_Id
:= Empty
;
5085 -- All the components of the prefix of selector Sel are matched
5086 -- against Sel and a count is maintained of possible misspellings.
5087 -- When at the end of the analysis there are one or two (not more!)
5088 -- possible misspellings, these misspellings will be suggested as
5089 -- possible correction.
5091 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
5093 -- Concurrent types should be handled as well ???
5098 Comp
:= First_Entity
(Prefix
);
5099 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
5100 if Is_Visible_Component
(Comp
) then
5101 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
5102 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
5104 case Nr_Of_Suggestions
is
5105 when 1 => Suggestion_1
:= Comp
;
5106 when 2 => Suggestion_2
:= Comp
;
5107 when others => exit;
5112 Comp
:= Next_Entity
(Comp
);
5115 -- Report at most two suggestions
5117 if Nr_Of_Suggestions
= 1 then
5118 Error_Msg_NE
-- CODEFIX
5119 ("\possible misspelling of&", Sel
, Suggestion_1
);
5121 elsif Nr_Of_Suggestions
= 2 then
5122 Error_Msg_Node_2
:= Suggestion_2
;
5123 Error_Msg_NE
-- CODEFIX
5124 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
5126 end Check_Misspelled_Selector
;
5128 ----------------------
5129 -- Defined_In_Scope --
5130 ----------------------
5132 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean
5134 S1
: constant Entity_Id
:= Scope
(Base_Type
(T
));
5137 or else (S1
= System_Aux_Id
and then S
= Scope
(S1
));
5138 end Defined_In_Scope
;
5144 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
5150 Void_Interp_Seen
: Boolean := False;
5153 pragma Warnings
(Off
, Boolean);
5156 if Ada_Version
>= Ada_2005
then
5157 Actual
:= First_Actual
(N
);
5158 while Present
(Actual
) loop
5160 -- Ada 2005 (AI-50217): Post an error in case of premature
5161 -- usage of an entity from the limited view.
5163 if not Analyzed
(Etype
(Actual
))
5164 and then From_With_Type
(Etype
(Actual
))
5166 Error_Msg_Qual_Level
:= 1;
5168 ("missing with_clause for scope of imported type&",
5169 Actual
, Etype
(Actual
));
5170 Error_Msg_Qual_Level
:= 0;
5173 Next_Actual
(Actual
);
5177 -- Analyze each candidate call again, with full error reporting
5181 ("no candidate interpretations match the actuals:!", Nam
);
5182 Err_Mode
:= All_Errors_Mode
;
5183 All_Errors_Mode
:= True;
5185 -- If this is a call to an operation of a concurrent type,
5186 -- the failed interpretations have been removed from the
5187 -- name. Recover them to provide full diagnostics.
5189 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
5190 Set_Entity
(Nam
, Empty
);
5191 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
5192 Set_Is_Overloaded
(New_Nam
, False);
5193 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
5194 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
5195 Analyze_Selected_Component
(New_Nam
);
5196 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
5198 Get_First_Interp
(Nam
, X
, It
);
5201 while Present
(It
.Nam
) loop
5202 if Etype
(It
.Nam
) = Standard_Void_Type
then
5203 Void_Interp_Seen
:= True;
5206 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
5207 Get_Next_Interp
(X
, It
);
5210 if Nkind
(N
) = N_Function_Call
then
5211 Get_First_Interp
(Nam
, X
, It
);
5212 while Present
(It
.Nam
) loop
5213 if Ekind_In
(It
.Nam
, E_Function
, E_Operator
) then
5216 Get_Next_Interp
(X
, It
);
5220 -- If all interpretations are procedures, this deserves a
5221 -- more precise message. Ditto if this appears as the prefix
5222 -- of a selected component, which may be a lexical error.
5225 ("\context requires function call, found procedure name", Nam
);
5227 if Nkind
(Parent
(N
)) = N_Selected_Component
5228 and then N
= Prefix
(Parent
(N
))
5230 Error_Msg_N
-- CODEFIX
5231 ("\period should probably be semicolon", Parent
(N
));
5234 elsif Nkind
(N
) = N_Procedure_Call_Statement
5235 and then not Void_Interp_Seen
5238 "\function name found in procedure call", Nam
);
5241 All_Errors_Mode
:= Err_Mode
;
5244 ---------------------------
5245 -- Find_Arithmetic_Types --
5246 ---------------------------
5248 procedure Find_Arithmetic_Types
5253 Index1
: Interp_Index
;
5254 Index2
: Interp_Index
;
5258 procedure Check_Right_Argument
(T
: Entity_Id
);
5259 -- Check right operand of operator
5261 --------------------------
5262 -- Check_Right_Argument --
5263 --------------------------
5265 procedure Check_Right_Argument
(T
: Entity_Id
) is
5267 if not Is_Overloaded
(R
) then
5268 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
5270 Get_First_Interp
(R
, Index2
, It2
);
5271 while Present
(It2
.Typ
) loop
5272 Check_Arithmetic_Pair
(T
, It2
.Typ
, Op_Id
, N
);
5273 Get_Next_Interp
(Index2
, It2
);
5276 end Check_Right_Argument
;
5278 -- Start of processing for Find_Arithmetic_Types
5281 if not Is_Overloaded
(L
) then
5282 Check_Right_Argument
(Etype
(L
));
5285 Get_First_Interp
(L
, Index1
, It1
);
5286 while Present
(It1
.Typ
) loop
5287 Check_Right_Argument
(It1
.Typ
);
5288 Get_Next_Interp
(Index1
, It1
);
5292 end Find_Arithmetic_Types
;
5294 ------------------------
5295 -- Find_Boolean_Types --
5296 ------------------------
5298 procedure Find_Boolean_Types
5303 Index
: Interp_Index
;
5306 procedure Check_Numeric_Argument
(T
: Entity_Id
);
5307 -- Special case for logical operations one of whose operands is an
5308 -- integer literal. If both are literal the result is any modular type.
5310 ----------------------------
5311 -- Check_Numeric_Argument --
5312 ----------------------------
5314 procedure Check_Numeric_Argument
(T
: Entity_Id
) is
5316 if T
= Universal_Integer
then
5317 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5319 elsif Is_Modular_Integer_Type
(T
) then
5320 Add_One_Interp
(N
, Op_Id
, T
);
5322 end Check_Numeric_Argument
;
5324 -- Start of processing for Find_Boolean_Types
5327 if not Is_Overloaded
(L
) then
5328 if Etype
(L
) = Universal_Integer
5329 or else Etype
(L
) = Any_Modular
5331 if not Is_Overloaded
(R
) then
5332 Check_Numeric_Argument
(Etype
(R
));
5335 Get_First_Interp
(R
, Index
, It
);
5336 while Present
(It
.Typ
) loop
5337 Check_Numeric_Argument
(It
.Typ
);
5338 Get_Next_Interp
(Index
, It
);
5342 -- If operands are aggregates, we must assume that they may be
5343 -- boolean arrays, and leave disambiguation for the second pass.
5344 -- If only one is an aggregate, verify that the other one has an
5345 -- interpretation as a boolean array
5347 elsif Nkind
(L
) = N_Aggregate
then
5348 if Nkind
(R
) = N_Aggregate
then
5349 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
5351 elsif not Is_Overloaded
(R
) then
5352 if Valid_Boolean_Arg
(Etype
(R
)) then
5353 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5357 Get_First_Interp
(R
, Index
, It
);
5358 while Present
(It
.Typ
) loop
5359 if Valid_Boolean_Arg
(It
.Typ
) then
5360 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5363 Get_Next_Interp
(Index
, It
);
5367 elsif Valid_Boolean_Arg
(Etype
(L
))
5368 and then Has_Compatible_Type
(R
, Etype
(L
))
5370 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
5374 Get_First_Interp
(L
, Index
, It
);
5375 while Present
(It
.Typ
) loop
5376 if Valid_Boolean_Arg
(It
.Typ
)
5377 and then Has_Compatible_Type
(R
, It
.Typ
)
5379 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5382 Get_Next_Interp
(Index
, It
);
5385 end Find_Boolean_Types
;
5387 ---------------------------
5388 -- Find_Comparison_Types --
5389 ---------------------------
5391 procedure Find_Comparison_Types
5396 Index
: Interp_Index
;
5398 Found
: Boolean := False;
5401 Scop
: Entity_Id
:= Empty
;
5403 procedure Try_One_Interp
(T1
: Entity_Id
);
5404 -- Routine to try one proposed interpretation. Note that the context
5405 -- of the operator plays no role in resolving the arguments, so that
5406 -- if there is more than one interpretation of the operands that is
5407 -- compatible with comparison, the operation is ambiguous.
5409 --------------------
5410 -- Try_One_Interp --
5411 --------------------
5413 procedure Try_One_Interp
(T1
: Entity_Id
) is
5416 -- If the operator is an expanded name, then the type of the operand
5417 -- must be defined in the corresponding scope. If the type is
5418 -- universal, the context will impose the correct type.
5421 and then not Defined_In_Scope
(T1
, Scop
)
5422 and then T1
/= Universal_Integer
5423 and then T1
/= Universal_Real
5424 and then T1
/= Any_String
5425 and then T1
/= Any_Composite
5430 if Valid_Comparison_Arg
(T1
)
5431 and then Has_Compatible_Type
(R
, T1
)
5434 and then Base_Type
(T1
) /= Base_Type
(T_F
)
5436 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
5438 if It
= No_Interp
then
5439 Ambiguous_Operands
(N
);
5440 Set_Etype
(L
, Any_Type
);
5454 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
5459 -- Start of processing for Find_Comparison_Types
5462 -- If left operand is aggregate, the right operand has to
5463 -- provide a usable type for it.
5465 if Nkind
(L
) = N_Aggregate
5466 and then Nkind
(R
) /= N_Aggregate
5468 Find_Comparison_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
5472 if Nkind
(N
) = N_Function_Call
5473 and then Nkind
(Name
(N
)) = N_Expanded_Name
5475 Scop
:= Entity
(Prefix
(Name
(N
)));
5477 -- The prefix may be a package renaming, and the subsequent test
5478 -- requires the original package.
5480 if Ekind
(Scop
) = E_Package
5481 and then Present
(Renamed_Entity
(Scop
))
5483 Scop
:= Renamed_Entity
(Scop
);
5484 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5488 if not Is_Overloaded
(L
) then
5489 Try_One_Interp
(Etype
(L
));
5492 Get_First_Interp
(L
, Index
, It
);
5493 while Present
(It
.Typ
) loop
5494 Try_One_Interp
(It
.Typ
);
5495 Get_Next_Interp
(Index
, It
);
5498 end Find_Comparison_Types
;
5500 ----------------------------------------
5501 -- Find_Non_Universal_Interpretations --
5502 ----------------------------------------
5504 procedure Find_Non_Universal_Interpretations
5510 Index
: Interp_Index
;
5514 if T1
= Universal_Integer
5515 or else T1
= Universal_Real
5517 -- If the left operand of an equality operator is null, the visibility
5518 -- of the operator must be determined from the interpretation of the
5519 -- right operand. This processing must be done for Any_Access, which
5520 -- is the internal representation of the type of the literal null.
5522 or else T1
= Any_Access
5524 if not Is_Overloaded
(R
) then
5526 (N
, Op_Id
, Standard_Boolean
, Base_Type
(Etype
(R
)));
5528 Get_First_Interp
(R
, Index
, It
);
5529 while Present
(It
.Typ
) loop
5530 if Covers
(It
.Typ
, T1
) then
5532 (N
, Op_Id
, Standard_Boolean
, Base_Type
(It
.Typ
));
5535 Get_Next_Interp
(Index
, It
);
5539 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(T1
));
5541 end Find_Non_Universal_Interpretations
;
5543 ------------------------------
5544 -- Find_Concatenation_Types --
5545 ------------------------------
5547 procedure Find_Concatenation_Types
5552 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
5555 if Is_Array_Type
(Op_Type
)
5556 and then not Is_Limited_Type
(Op_Type
)
5558 and then (Has_Compatible_Type
(L
, Op_Type
)
5560 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
5562 and then (Has_Compatible_Type
(R
, Op_Type
)
5564 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
5566 Add_One_Interp
(N
, Op_Id
, Op_Type
);
5568 end Find_Concatenation_Types
;
5570 -------------------------
5571 -- Find_Equality_Types --
5572 -------------------------
5574 procedure Find_Equality_Types
5579 Index
: Interp_Index
;
5581 Found
: Boolean := False;
5584 Scop
: Entity_Id
:= Empty
;
5586 procedure Try_One_Interp
(T1
: Entity_Id
);
5587 -- The context of the equality operator plays no role in resolving the
5588 -- arguments, so that if there is more than one interpretation of the
5589 -- operands that is compatible with equality, the construct is ambiguous
5590 -- and an error can be emitted now, after trying to disambiguate, i.e.
5591 -- applying preference rules.
5593 --------------------
5594 -- Try_One_Interp --
5595 --------------------
5597 procedure Try_One_Interp
(T1
: Entity_Id
) is
5598 Bas
: constant Entity_Id
:= Base_Type
(T1
);
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. An anonymous
5604 -- type for a 'Access reference is also universal in this sense, as
5605 -- the actual type is obtained from context.
5606 -- In Ada 2005, the equality operator for anonymous access types
5607 -- is declared in Standard, and preference rules apply to it.
5609 if Present
(Scop
) then
5610 if Defined_In_Scope
(T1
, Scop
)
5611 or else T1
= Universal_Integer
5612 or else T1
= Universal_Real
5613 or else T1
= Any_Access
5614 or else T1
= Any_String
5615 or else T1
= Any_Composite
5616 or else (Ekind
(T1
) = E_Access_Subprogram_Type
5617 and then not Comes_From_Source
(T1
))
5621 elsif Ekind
(T1
) = E_Anonymous_Access_Type
5622 and then Scop
= Standard_Standard
5627 -- The scope does not contain an operator for the type
5632 -- If we have infix notation, the operator must be usable. Within
5633 -- an instance, if the type is already established we know it is
5634 -- correct. If an operand is universal it is compatible with any
5637 -- In Ada 2005, the equality on anonymous access types is declared
5638 -- in Standard, and is always visible.
5640 elsif In_Open_Scopes
(Scope
(Bas
))
5641 or else Is_Potentially_Use_Visible
(Bas
)
5642 or else In_Use
(Bas
)
5643 or else (In_Use
(Scope
(Bas
)) and then not Is_Hidden
(Bas
))
5644 or else (In_Instance
5646 (First_Subtype
(T1
) = First_Subtype
(Etype
(R
))
5648 (Is_Numeric_Type
(T1
)
5649 and then Is_Universal_Numeric_Type
(Etype
(R
)))))
5650 or else Ekind
(T1
) = E_Anonymous_Access_Type
5655 -- Save candidate type for subsequent error message, if any
5657 if not Is_Limited_Type
(T1
) then
5658 Candidate_Type
:= T1
;
5664 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
5665 -- Do not allow anonymous access types in equality operators.
5667 if Ada_Version
< Ada_2005
5668 and then Ekind
(T1
) = E_Anonymous_Access_Type
5673 -- If the right operand has a type compatible with T1, check for an
5674 -- acceptable interpretation, unless T1 is limited (no predefined
5675 -- equality available), or this is use of a "/=" for a tagged type.
5676 -- In the latter case, possible interpretations of equality need to
5677 -- be considered, we don't want the default inequality declared in
5678 -- Standard to be chosen, and the "/=" will be rewritten as a
5679 -- negation of "=" (see the end of Analyze_Equality_Op). This ensures
5680 -- that that rewriting happens during analysis rather than being
5681 -- delayed until expansion (this is needed for ASIS, which only sees
5682 -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id
5683 -- is Name_Op_Eq then we still proceed with the interpretation,
5684 -- because that indicates the potential rewriting case where the
5685 -- interpretation to consider is actually "=" and the node may be
5686 -- about to be rewritten by Analyze_Equality_Op.
5688 if T1
/= Standard_Void_Type
5689 and then Has_Compatible_Type
(R
, T1
)
5692 ((not Is_Limited_Type
(T1
)
5693 and then not Is_Limited_Composite
(T1
))
5697 and then not Is_Limited_Type
(Component_Type
(T1
))
5698 and then Available_Full_View_Of_Component
(T1
)))
5701 (Nkind
(N
) /= N_Op_Ne
5702 or else not Is_Tagged_Type
(T1
)
5703 or else Chars
(Op_Id
) = Name_Op_Eq
)
5706 and then Base_Type
(T1
) /= Base_Type
(T_F
)
5708 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
5710 if It
= No_Interp
then
5711 Ambiguous_Operands
(N
);
5712 Set_Etype
(L
, Any_Type
);
5725 if not Analyzed
(L
) then
5729 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
5731 -- Case of operator was not visible, Etype still set to Any_Type
5733 if Etype
(N
) = Any_Type
then
5737 elsif Scop
= Standard_Standard
5738 and then Ekind
(T1
) = E_Anonymous_Access_Type
5744 -- Start of processing for Find_Equality_Types
5747 -- If left operand is aggregate, the right operand has to
5748 -- provide a usable type for it.
5750 if Nkind
(L
) = N_Aggregate
5751 and then Nkind
(R
) /= N_Aggregate
5753 Find_Equality_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
5757 if Nkind
(N
) = N_Function_Call
5758 and then Nkind
(Name
(N
)) = N_Expanded_Name
5760 Scop
:= Entity
(Prefix
(Name
(N
)));
5762 -- The prefix may be a package renaming, and the subsequent test
5763 -- requires the original package.
5765 if Ekind
(Scop
) = E_Package
5766 and then Present
(Renamed_Entity
(Scop
))
5768 Scop
:= Renamed_Entity
(Scop
);
5769 Set_Entity
(Prefix
(Name
(N
)), Scop
);
5773 if not Is_Overloaded
(L
) then
5774 Try_One_Interp
(Etype
(L
));
5777 Get_First_Interp
(L
, Index
, It
);
5778 while Present
(It
.Typ
) loop
5779 Try_One_Interp
(It
.Typ
);
5780 Get_Next_Interp
(Index
, It
);
5783 end Find_Equality_Types
;
5785 -------------------------
5786 -- Find_Negation_Types --
5787 -------------------------
5789 procedure Find_Negation_Types
5794 Index
: Interp_Index
;
5798 if not Is_Overloaded
(R
) then
5799 if Etype
(R
) = Universal_Integer
then
5800 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
5801 elsif Valid_Boolean_Arg
(Etype
(R
)) then
5802 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
5806 Get_First_Interp
(R
, Index
, It
);
5807 while Present
(It
.Typ
) loop
5808 if Valid_Boolean_Arg
(It
.Typ
) then
5809 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
5812 Get_Next_Interp
(Index
, It
);
5815 end Find_Negation_Types
;
5817 ------------------------------
5818 -- Find_Primitive_Operation --
5819 ------------------------------
5821 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
5822 Obj
: constant Node_Id
:= Prefix
(N
);
5823 Op
: constant Node_Id
:= Selector_Name
(N
);
5830 Set_Etype
(Op
, Any_Type
);
5832 if Is_Access_Type
(Etype
(Obj
)) then
5833 Typ
:= Designated_Type
(Etype
(Obj
));
5838 if Is_Class_Wide_Type
(Typ
) then
5839 Typ
:= Root_Type
(Typ
);
5842 Prims
:= Primitive_Operations
(Typ
);
5844 Prim
:= First_Elmt
(Prims
);
5845 while Present
(Prim
) loop
5846 if Chars
(Node
(Prim
)) = Chars
(Op
) then
5847 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
5848 Set_Etype
(N
, Etype
(Node
(Prim
)));
5854 -- Now look for class-wide operations of the type or any of its
5855 -- ancestors by iterating over the homonyms of the selector.
5858 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
5862 Hom
:= Current_Entity
(Op
);
5863 while Present
(Hom
) loop
5864 if (Ekind
(Hom
) = E_Procedure
5866 Ekind
(Hom
) = E_Function
)
5867 and then Scope
(Hom
) = Scope
(Typ
)
5868 and then Present
(First_Formal
(Hom
))
5870 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
5872 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
5874 Ekind
(Etype
(First_Formal
(Hom
))) =
5875 E_Anonymous_Access_Type
5878 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
5881 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
5882 Set_Etype
(N
, Etype
(Hom
));
5885 Hom
:= Homonym
(Hom
);
5889 return Etype
(Op
) /= Any_Type
;
5890 end Find_Primitive_Operation
;
5892 ----------------------
5893 -- Find_Unary_Types --
5894 ----------------------
5896 procedure Find_Unary_Types
5901 Index
: Interp_Index
;
5905 if not Is_Overloaded
(R
) then
5906 if Is_Numeric_Type
(Etype
(R
)) then
5908 -- In an instance a generic actual may be a numeric type even if
5909 -- the formal in the generic unit was not. In that case, the
5910 -- predefined operator was not a possible interpretation in the
5911 -- generic, and cannot be one in the instance.
5915 not Is_Numeric_Type
(Corresponding_Generic_Type
(Etype
(R
)))
5919 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
5924 Get_First_Interp
(R
, Index
, It
);
5925 while Present
(It
.Typ
) loop
5926 if Is_Numeric_Type
(It
.Typ
) then
5930 (Corresponding_Generic_Type
(Etype
(It
.Typ
)))
5935 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
5939 Get_Next_Interp
(Index
, It
);
5942 end Find_Unary_Types
;
5948 function Junk_Operand
(N
: Node_Id
) return Boolean is
5952 if Error_Posted
(N
) then
5956 -- Get entity to be tested
5958 if Is_Entity_Name
(N
)
5959 and then Present
(Entity
(N
))
5963 -- An odd case, a procedure name gets converted to a very peculiar
5964 -- function call, and here is where we detect this happening.
5966 elsif Nkind
(N
) = N_Function_Call
5967 and then Is_Entity_Name
(Name
(N
))
5968 and then Present
(Entity
(Name
(N
)))
5972 -- Another odd case, there are at least some cases of selected
5973 -- components where the selected component is not marked as having
5974 -- an entity, even though the selector does have an entity
5976 elsif Nkind
(N
) = N_Selected_Component
5977 and then Present
(Entity
(Selector_Name
(N
)))
5979 Enode
:= Selector_Name
(N
);
5985 -- Now test the entity we got to see if it is a bad case
5987 case Ekind
(Entity
(Enode
)) is
5991 ("package name cannot be used as operand", Enode
);
5993 when Generic_Unit_Kind
=>
5995 ("generic unit name cannot be used as operand", Enode
);
5999 ("subtype name cannot be used as operand", Enode
);
6003 ("entry name cannot be used as operand", Enode
);
6007 ("procedure name cannot be used as operand", Enode
);
6011 ("exception name cannot be used as operand", Enode
);
6013 when E_Block | E_Label | E_Loop
=>
6015 ("label name cannot be used as operand", Enode
);
6025 --------------------
6026 -- Operator_Check --
6027 --------------------
6029 procedure Operator_Check
(N
: Node_Id
) is
6031 Remove_Abstract_Operations
(N
);
6033 -- Test for case of no interpretation found for operator
6035 if Etype
(N
) = Any_Type
then
6039 Op_Id
: Entity_Id
:= Empty
;
6042 R
:= Right_Opnd
(N
);
6044 if Nkind
(N
) in N_Binary_Op
then
6050 -- If either operand has no type, then don't complain further,
6051 -- since this simply means that we have a propagated error.
6054 or else Etype
(R
) = Any_Type
6055 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
6059 -- We explicitly check for the case of concatenation of component
6060 -- with component to avoid reporting spurious matching array types
6061 -- that might happen to be lurking in distant packages (such as
6062 -- run-time packages). This also prevents inconsistencies in the
6063 -- messages for certain ACVC B tests, which can vary depending on
6064 -- types declared in run-time interfaces. Another improvement when
6065 -- aggregates are present is to look for a well-typed operand.
6067 elsif Present
(Candidate_Type
)
6068 and then (Nkind
(N
) /= N_Op_Concat
6069 or else Is_Array_Type
(Etype
(L
))
6070 or else Is_Array_Type
(Etype
(R
)))
6072 if Nkind
(N
) = N_Op_Concat
then
6073 if Etype
(L
) /= Any_Composite
6074 and then Is_Array_Type
(Etype
(L
))
6076 Candidate_Type
:= Etype
(L
);
6078 elsif Etype
(R
) /= Any_Composite
6079 and then Is_Array_Type
(Etype
(R
))
6081 Candidate_Type
:= Etype
(R
);
6085 Error_Msg_NE
-- CODEFIX
6086 ("operator for} is not directly visible!",
6087 N
, First_Subtype
(Candidate_Type
));
6090 U
: constant Node_Id
:=
6091 Cunit
(Get_Source_Unit
(Candidate_Type
));
6093 if Unit_Is_Visible
(U
) then
6094 Error_Msg_N
-- CODEFIX
6095 ("use clause would make operation legal!", N
);
6097 Error_Msg_NE
-- CODEFIX
6098 ("add with_clause and use_clause for&!",
6099 N
, Defining_Entity
(Unit
(U
)));
6104 -- If either operand is a junk operand (e.g. package name), then
6105 -- post appropriate error messages, but do not complain further.
6107 -- Note that the use of OR in this test instead of OR ELSE is
6108 -- quite deliberate, we may as well check both operands in the
6109 -- binary operator case.
6111 elsif Junk_Operand
(R
)
6112 or (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
6116 -- If we have a logical operator, one of whose operands is
6117 -- Boolean, then we know that the other operand cannot resolve to
6118 -- Boolean (since we got no interpretations), but in that case we
6119 -- pretty much know that the other operand should be Boolean, so
6120 -- resolve it that way (generating an error)
6122 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
) then
6123 if Etype
(L
) = Standard_Boolean
then
6124 Resolve
(R
, Standard_Boolean
);
6126 elsif Etype
(R
) = Standard_Boolean
then
6127 Resolve
(L
, Standard_Boolean
);
6131 -- For an arithmetic operator or comparison operator, if one
6132 -- of the operands is numeric, then we know the other operand
6133 -- is not the same numeric type. If it is a non-numeric type,
6134 -- then probably it is intended to match the other operand.
6136 elsif Nkind_In
(N
, N_Op_Add
,
6142 Nkind_In
(N
, N_Op_Lt
,
6148 if Is_Numeric_Type
(Etype
(L
))
6149 and then not Is_Numeric_Type
(Etype
(R
))
6151 Resolve
(R
, Etype
(L
));
6154 elsif Is_Numeric_Type
(Etype
(R
))
6155 and then not Is_Numeric_Type
(Etype
(L
))
6157 Resolve
(L
, Etype
(R
));
6161 -- Comparisons on A'Access are common enough to deserve a
6164 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
6165 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
6166 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
6169 ("two access attributes cannot be compared directly", N
);
6171 ("\use qualified expression for one of the operands",
6175 -- Another one for C programmers
6177 elsif Nkind
(N
) = N_Op_Concat
6178 and then Valid_Boolean_Arg
(Etype
(L
))
6179 and then Valid_Boolean_Arg
(Etype
(R
))
6181 Error_Msg_N
("invalid operands for concatenation", N
);
6182 Error_Msg_N
-- CODEFIX
6183 ("\maybe AND was meant", N
);
6186 -- A special case for comparison of access parameter with null
6188 elsif Nkind
(N
) = N_Op_Eq
6189 and then Is_Entity_Name
(L
)
6190 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
6191 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
6193 and then Nkind
(R
) = N_Null
6195 Error_Msg_N
("access parameter is not allowed to be null", L
);
6196 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
6199 -- Another special case for exponentiation, where the right
6200 -- operand must be Natural, independently of the base.
6202 elsif Nkind
(N
) = N_Op_Expon
6203 and then Is_Numeric_Type
(Etype
(L
))
6204 and then not Is_Overloaded
(R
)
6206 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
6207 and then Base_Type
(Etype
(R
)) /= Universal_Integer
6209 if Ada_Version
>= Ada_2012
6210 and then Has_Dimension_System
(Etype
(L
))
6213 ("exponent for dimensioned type must be a rational" &
6214 ", found}", R
, Etype
(R
));
6217 ("exponent must be of type Natural, found}", R
, Etype
(R
));
6223 -- If we fall through then just give general message. Note that in
6224 -- the following messages, if the operand is overloaded we choose
6225 -- an arbitrary type to complain about, but that is probably more
6226 -- useful than not giving a type at all.
6228 if Nkind
(N
) in N_Unary_Op
then
6229 Error_Msg_Node_2
:= Etype
(R
);
6230 Error_Msg_N
("operator& not defined for}", N
);
6234 if Nkind
(N
) in N_Binary_Op
then
6235 if not Is_Overloaded
(L
)
6236 and then not Is_Overloaded
(R
)
6237 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
6239 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
6240 Error_Msg_N
("there is no applicable operator& for}", N
);
6243 -- Another attempt to find a fix: one of the candidate
6244 -- interpretations may not be use-visible. This has
6245 -- already been checked for predefined operators, so
6246 -- we examine only user-defined functions.
6248 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
6250 while Present
(Op_Id
) loop
6251 if Ekind
(Op_Id
) /= E_Operator
6252 and then Is_Overloadable
(Op_Id
)
6254 if not Is_Immediately_Visible
(Op_Id
)
6255 and then not In_Use
(Scope
(Op_Id
))
6256 and then not Is_Abstract_Subprogram
(Op_Id
)
6257 and then not Is_Hidden
(Op_Id
)
6258 and then Ekind
(Scope
(Op_Id
)) = E_Package
6261 (L
, Etype
(First_Formal
(Op_Id
)))
6263 (Next_Formal
(First_Formal
(Op_Id
)))
6267 Etype
(Next_Formal
(First_Formal
(Op_Id
))))
6270 ("No legal interpretation for operator&", N
);
6272 ("\use clause on& would make operation legal",
6278 Op_Id
:= Homonym
(Op_Id
);
6282 Error_Msg_N
("invalid operand types for operator&", N
);
6284 if Nkind
(N
) /= N_Op_Concat
then
6285 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
6286 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
6296 -----------------------------------------
6297 -- Process_Implicit_Dereference_Prefix --
6298 -----------------------------------------
6300 function Process_Implicit_Dereference_Prefix
6302 P
: Entity_Id
) return Entity_Id
6305 Typ
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
6309 and then (Operating_Mode
= Check_Semantics
or else not Expander_Active
)
6311 -- We create a dummy reference to E to ensure that the reference
6312 -- is not considered as part of an assignment (an implicit
6313 -- dereference can never assign to its prefix). The Comes_From_Source
6314 -- attribute needs to be propagated for accurate warnings.
6316 Ref
:= New_Reference_To
(E
, Sloc
(P
));
6317 Set_Comes_From_Source
(Ref
, Comes_From_Source
(P
));
6318 Generate_Reference
(E
, Ref
);
6321 -- An implicit dereference is a legal occurrence of an
6322 -- incomplete type imported through a limited_with clause,
6323 -- if the full view is visible.
6325 if From_With_Type
(Typ
)
6326 and then not From_With_Type
(Scope
(Typ
))
6328 (Is_Immediately_Visible
(Scope
(Typ
))
6330 (Is_Child_Unit
(Scope
(Typ
))
6331 and then Is_Visible_Lib_Unit
(Scope
(Typ
))))
6333 return Available_View
(Typ
);
6337 end Process_Implicit_Dereference_Prefix
;
6339 --------------------------------
6340 -- Remove_Abstract_Operations --
6341 --------------------------------
6343 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
6344 Abstract_Op
: Entity_Id
:= Empty
;
6345 Address_Kludge
: Boolean := False;
6349 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
6350 -- activate this if either extensions are enabled, or if the abstract
6351 -- operation in question comes from a predefined file. This latter test
6352 -- allows us to use abstract to make operations invisible to users. In
6353 -- particular, if type Address is non-private and abstract subprograms
6354 -- are used to hide its operators, they will be truly hidden.
6356 type Operand_Position
is (First_Op
, Second_Op
);
6357 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
6359 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
6360 -- Ambiguities may arise when the operands are literal and the address
6361 -- operations in s-auxdec are visible. In that case, remove the
6362 -- interpretation of a literal as Address, to retain the semantics of
6363 -- Address as a private type.
6365 ------------------------------------
6366 -- Remove_Address_Interpretations --
6367 ------------------------------------
6369 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
6373 if Is_Overloaded
(N
) then
6374 Get_First_Interp
(N
, I
, It
);
6375 while Present
(It
.Nam
) loop
6376 Formal
:= First_Entity
(It
.Nam
);
6378 if Op
= Second_Op
then
6379 Formal
:= Next_Entity
(Formal
);
6382 if Is_Descendent_Of_Address
(Etype
(Formal
)) then
6383 Address_Kludge
:= True;
6387 Get_Next_Interp
(I
, It
);
6390 end Remove_Address_Interpretations
;
6392 -- Start of processing for Remove_Abstract_Operations
6395 if Is_Overloaded
(N
) then
6396 if Debug_Flag_V
then
6397 Write_Str
("Remove_Abstract_Operations: ");
6398 Write_Overloads
(N
);
6401 Get_First_Interp
(N
, I
, It
);
6403 while Present
(It
.Nam
) loop
6404 if Is_Overloadable
(It
.Nam
)
6405 and then Is_Abstract_Subprogram
(It
.Nam
)
6406 and then not Is_Dispatching_Operation
(It
.Nam
)
6408 Abstract_Op
:= It
.Nam
;
6410 if Is_Descendent_Of_Address
(It
.Typ
) then
6411 Address_Kludge
:= True;
6415 -- In Ada 2005, this operation does not participate in overload
6416 -- resolution. If the operation is defined in a predefined
6417 -- unit, it is one of the operations declared abstract in some
6418 -- variants of System, and it must be removed as well.
6420 elsif Ada_Version
>= Ada_2005
6421 or else Is_Predefined_File_Name
6422 (Unit_File_Name
(Get_Source_Unit
(It
.Nam
)))
6429 Get_Next_Interp
(I
, It
);
6432 if No
(Abstract_Op
) then
6434 -- If some interpretation yields an integer type, it is still
6435 -- possible that there are address interpretations. Remove them
6436 -- if one operand is a literal, to avoid spurious ambiguities
6437 -- on systems where Address is a visible integer type.
6439 if Is_Overloaded
(N
)
6440 and then Nkind
(N
) in N_Op
6441 and then Is_Integer_Type
(Etype
(N
))
6443 if Nkind
(N
) in N_Binary_Op
then
6444 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
6445 Remove_Address_Interpretations
(Second_Op
);
6447 elsif Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
6448 Remove_Address_Interpretations
(First_Op
);
6453 elsif Nkind
(N
) in N_Op
then
6455 -- Remove interpretations that treat literals as addresses. This
6456 -- is never appropriate, even when Address is defined as a visible
6457 -- Integer type. The reason is that we would really prefer Address
6458 -- to behave as a private type, even in this case, which is there
6459 -- only to accommodate oddities of VMS address sizes. If Address
6460 -- is a visible integer type, we get lots of overload ambiguities.
6462 if Nkind
(N
) in N_Binary_Op
then
6464 U1
: constant Boolean :=
6465 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
6466 U2
: constant Boolean :=
6467 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
6471 Remove_Address_Interpretations
(Second_Op
);
6475 Remove_Address_Interpretations
(First_Op
);
6478 if not (U1
and U2
) then
6480 -- Remove corresponding predefined operator, which is
6481 -- always added to the overload set.
6483 Get_First_Interp
(N
, I
, It
);
6484 while Present
(It
.Nam
) loop
6485 if Scope
(It
.Nam
) = Standard_Standard
6486 and then Base_Type
(It
.Typ
) =
6487 Base_Type
(Etype
(Abstract_Op
))
6492 Get_Next_Interp
(I
, It
);
6495 elsif Is_Overloaded
(N
)
6496 and then Present
(Univ_Type
)
6498 -- If both operands have a universal interpretation,
6499 -- it is still necessary to remove interpretations that
6500 -- yield Address. Any remaining ambiguities will be
6501 -- removed in Disambiguate.
6503 Get_First_Interp
(N
, I
, It
);
6504 while Present
(It
.Nam
) loop
6505 if Is_Descendent_Of_Address
(It
.Typ
) then
6508 elsif not Is_Type
(It
.Nam
) then
6509 Set_Entity
(N
, It
.Nam
);
6512 Get_Next_Interp
(I
, It
);
6518 elsif Nkind
(N
) = N_Function_Call
6520 (Nkind
(Name
(N
)) = N_Operator_Symbol
6522 (Nkind
(Name
(N
)) = N_Expanded_Name
6524 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
6528 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
6529 U1
: constant Boolean :=
6530 Present
(Universal_Interpretation
(Arg1
));
6531 U2
: constant Boolean :=
6532 Present
(Next
(Arg1
)) and then
6533 Present
(Universal_Interpretation
(Next
(Arg1
)));
6537 Remove_Address_Interpretations
(First_Op
);
6541 Remove_Address_Interpretations
(Second_Op
);
6544 if not (U1
and U2
) then
6545 Get_First_Interp
(N
, I
, It
);
6546 while Present
(It
.Nam
) loop
6547 if Scope
(It
.Nam
) = Standard_Standard
6548 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
6553 Get_Next_Interp
(I
, It
);
6559 -- If the removal has left no valid interpretations, emit an error
6560 -- message now and label node as illegal.
6562 if Present
(Abstract_Op
) then
6563 Get_First_Interp
(N
, I
, It
);
6567 -- Removal of abstract operation left no viable candidate
6569 Set_Etype
(N
, Any_Type
);
6570 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
6572 ("cannot call abstract operation& declared#", N
, Abstract_Op
);
6574 -- In Ada 2005, an abstract operation may disable predefined
6575 -- operators. Since the context is not yet known, we mark the
6576 -- predefined operators as potentially hidden. Do not include
6577 -- predefined operators when addresses are involved since this
6578 -- case is handled separately.
6580 elsif Ada_Version
>= Ada_2005
6581 and then not Address_Kludge
6583 while Present
(It
.Nam
) loop
6584 if Is_Numeric_Type
(It
.Typ
)
6585 and then Scope
(It
.Typ
) = Standard_Standard
6587 Set_Abstract_Op
(I
, Abstract_Op
);
6590 Get_Next_Interp
(I
, It
);
6595 if Debug_Flag_V
then
6596 Write_Str
("Remove_Abstract_Operations done: ");
6597 Write_Overloads
(N
);
6600 end Remove_Abstract_Operations
;
6602 ----------------------------
6603 -- Try_Container_Indexing --
6604 ----------------------------
6606 function Try_Container_Indexing
6609 Exprs
: List_Id
) return Boolean
6611 Loc
: constant Source_Ptr
:= Sloc
(N
);
6615 Func_Name
: Node_Id
;
6620 -- Check whether type has a specified indexing aspect
6624 if Is_Variable
(Prefix
) then
6625 Func_Name
:= Find_Aspect
(Etype
(Prefix
), Aspect_Variable_Indexing
);
6628 if No
(Func_Name
) then
6629 Func_Name
:= Find_Aspect
(Etype
(Prefix
), Aspect_Constant_Indexing
);
6632 -- If aspect does not exist the expression is illegal. Error is
6633 -- diagnosed in caller.
6635 if No
(Func_Name
) then
6637 -- The prefix itself may be an indexing of a container
6638 -- rewrite as such and re-analyze.
6640 if Has_Implicit_Dereference
(Etype
(Prefix
)) then
6641 Build_Explicit_Dereference
6642 (Prefix
, First_Discriminant
(Etype
(Prefix
)));
6643 return Try_Container_Indexing
(N
, Prefix
, Exprs
);
6650 Assoc
:= New_List
(Relocate_Node
(Prefix
));
6652 -- A generalized iterator may have nore than one index expression, so
6653 -- transfer all of them to the argument list to be used in the call.
6658 Arg
:= First
(Exprs
);
6659 while Present
(Arg
) loop
6660 Append
(Relocate_Node
(Arg
), Assoc
);
6665 if not Is_Overloaded
(Func_Name
) then
6666 Func
:= Entity
(Func_Name
);
6668 Make_Function_Call
(Loc
,
6669 Name
=> New_Occurrence_Of
(Func
, Loc
),
6670 Parameter_Associations
=> Assoc
);
6671 Rewrite
(N
, Indexing
);
6674 -- If the return type of the indexing function is a reference type,
6675 -- add the dereference as a possible interpretation. Note that the
6676 -- indexing aspect may be a function that returns the element type
6677 -- with no intervening implicit dereference.
6679 if Has_Discriminants
(Etype
(Func
)) then
6680 Disc
:= First_Discriminant
(Etype
(Func
));
6681 while Present
(Disc
) loop
6682 if Has_Implicit_Dereference
(Disc
) then
6683 Add_One_Interp
(N
, Disc
, Designated_Type
(Etype
(Disc
)));
6687 Next_Discriminant
(Disc
);
6692 Indexing
:= Make_Function_Call
(Loc
,
6693 Name
=> Make_Identifier
(Loc
, Chars
(Func_Name
)),
6694 Parameter_Associations
=> Assoc
);
6696 Rewrite
(N
, Indexing
);
6704 Get_First_Interp
(Func_Name
, I
, It
);
6705 Set_Etype
(N
, Any_Type
);
6706 while Present
(It
.Nam
) loop
6707 Analyze_One_Call
(N
, It
.Nam
, False, Success
);
6709 Set_Etype
(Name
(N
), It
.Typ
);
6710 Set_Entity
(Name
(N
), It
.Nam
);
6712 -- Add implicit dereference interpretation
6714 if Has_Discriminants
(Etype
(It
.Nam
)) then
6715 Disc
:= First_Discriminant
(Etype
(It
.Nam
));
6716 while Present
(Disc
) loop
6717 if Has_Implicit_Dereference
(Disc
) then
6719 (N
, Disc
, Designated_Type
(Etype
(Disc
)));
6723 Next_Discriminant
(Disc
);
6729 Get_Next_Interp
(I
, It
);
6734 if Etype
(N
) = Any_Type
then
6736 ("container cannot be indexed with&", N
, Etype
(First
(Exprs
)));
6737 Rewrite
(N
, New_Occurrence_Of
(Any_Id
, Loc
));
6743 end Try_Container_Indexing
;
6745 -----------------------
6746 -- Try_Indirect_Call --
6747 -----------------------
6749 function Try_Indirect_Call
6752 Typ
: Entity_Id
) return Boolean
6758 pragma Warnings
(Off
, Call_OK
);
6761 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
6763 Actual
:= First_Actual
(N
);
6764 Formal
:= First_Formal
(Designated_Type
(Typ
));
6765 while Present
(Actual
) and then Present
(Formal
) loop
6766 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
6771 Next_Formal
(Formal
);
6774 if No
(Actual
) and then No
(Formal
) then
6775 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
6777 -- Nam is a candidate interpretation for the name in the call,
6778 -- if it is not an indirect call.
6780 if not Is_Type
(Nam
)
6781 and then Is_Entity_Name
(Name
(N
))
6783 Set_Entity
(Name
(N
), Nam
);
6790 end Try_Indirect_Call
;
6792 ----------------------
6793 -- Try_Indexed_Call --
6794 ----------------------
6796 function Try_Indexed_Call
6800 Skip_First
: Boolean) return Boolean
6802 Loc
: constant Source_Ptr
:= Sloc
(N
);
6803 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
6808 Actual
:= First
(Actuals
);
6810 -- If the call was originally written in prefix form, skip the first
6811 -- actual, which is obviously not defaulted.
6817 Index
:= First_Index
(Typ
);
6818 while Present
(Actual
) and then Present
(Index
) loop
6820 -- If the parameter list has a named association, the expression
6821 -- is definitely a call and not an indexed component.
6823 if Nkind
(Actual
) = N_Parameter_Association
then
6827 if Is_Entity_Name
(Actual
)
6828 and then Is_Type
(Entity
(Actual
))
6829 and then No
(Next
(Actual
))
6831 -- A single actual that is a type name indicates a slice if the
6832 -- type is discrete, and an error otherwise.
6834 if Is_Discrete_Type
(Entity
(Actual
)) then
6838 Make_Function_Call
(Loc
,
6839 Name
=> Relocate_Node
(Name
(N
))),
6841 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
6846 Error_Msg_N
("invalid use of type in expression", Actual
);
6847 Set_Etype
(N
, Any_Type
);
6852 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
6860 if No
(Actual
) and then No
(Index
) then
6861 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
6863 -- Nam is a candidate interpretation for the name in the call,
6864 -- if it is not an indirect call.
6866 if not Is_Type
(Nam
)
6867 and then Is_Entity_Name
(Name
(N
))
6869 Set_Entity
(Name
(N
), Nam
);
6876 end Try_Indexed_Call
;
6878 --------------------------
6879 -- Try_Object_Operation --
6880 --------------------------
6882 function Try_Object_Operation
6883 (N
: Node_Id
; CW_Test_Only
: Boolean := False) return Boolean
6885 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
6886 Is_Subprg_Call
: constant Boolean := K
in N_Subprogram_Call
;
6887 Loc
: constant Source_Ptr
:= Sloc
(N
);
6888 Obj
: constant Node_Id
:= Prefix
(N
);
6890 Subprog
: constant Node_Id
:=
6891 Make_Identifier
(Sloc
(Selector_Name
(N
)),
6892 Chars
=> Chars
(Selector_Name
(N
)));
6893 -- Identifier on which possible interpretations will be collected
6895 Report_Error
: Boolean := False;
6896 -- If no candidate interpretation matches the context, redo the
6897 -- analysis with error enabled to provide additional information.
6900 Candidate
: Entity_Id
:= Empty
;
6901 New_Call_Node
: Node_Id
:= Empty
;
6902 Node_To_Replace
: Node_Id
;
6903 Obj_Type
: Entity_Id
:= Etype
(Obj
);
6904 Success
: Boolean := False;
6906 function Valid_Candidate
6909 Subp
: Entity_Id
) return Entity_Id
;
6910 -- If the subprogram is a valid interpretation, record it, and add
6911 -- to the list of interpretations of Subprog. Otherwise return Empty.
6913 procedure Complete_Object_Operation
6914 (Call_Node
: Node_Id
;
6915 Node_To_Replace
: Node_Id
);
6916 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
6917 -- Call_Node, insert the object (or its dereference) as the first actual
6918 -- in the call, and complete the analysis of the call.
6920 procedure Report_Ambiguity
(Op
: Entity_Id
);
6921 -- If a prefixed procedure call is ambiguous, indicate whether the
6922 -- call includes an implicit dereference or an implicit 'Access.
6924 procedure Transform_Object_Operation
6925 (Call_Node
: out Node_Id
;
6926 Node_To_Replace
: out Node_Id
);
6927 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
6928 -- Call_Node is the resulting subprogram call, Node_To_Replace is
6929 -- either N or the parent of N, and Subprog is a reference to the
6930 -- subprogram we are trying to match.
6932 function Try_Class_Wide_Operation
6933 (Call_Node
: Node_Id
;
6934 Node_To_Replace
: Node_Id
) return Boolean;
6935 -- Traverse all ancestor types looking for a class-wide subprogram
6936 -- for which the current operation is a valid non-dispatching call.
6938 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
6939 -- If prefix is overloaded, its interpretation may include different
6940 -- tagged types, and we must examine the primitive operations and
6941 -- the class-wide operations of each in order to find candidate
6942 -- interpretations for the call as a whole.
6944 function Try_Primitive_Operation
6945 (Call_Node
: Node_Id
;
6946 Node_To_Replace
: Node_Id
) return Boolean;
6947 -- Traverse the list of primitive subprograms looking for a dispatching
6948 -- operation for which the current node is a valid call .
6950 ---------------------
6951 -- Valid_Candidate --
6952 ---------------------
6954 function Valid_Candidate
6957 Subp
: Entity_Id
) return Entity_Id
6959 Arr_Type
: Entity_Id
;
6960 Comp_Type
: Entity_Id
;
6963 -- If the subprogram is a valid interpretation, record it in global
6964 -- variable Subprog, to collect all possible overloadings.
6967 if Subp
/= Entity
(Subprog
) then
6968 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
6972 -- If the call may be an indexed call, retrieve component type of
6973 -- resulting expression, and add possible interpretation.
6978 if Nkind
(Call
) = N_Function_Call
6979 and then Nkind
(Parent
(N
)) = N_Indexed_Component
6980 and then Needs_One_Actual
(Subp
)
6982 if Is_Array_Type
(Etype
(Subp
)) then
6983 Arr_Type
:= Etype
(Subp
);
6985 elsif Is_Access_Type
(Etype
(Subp
))
6986 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
6988 Arr_Type
:= Designated_Type
(Etype
(Subp
));
6992 if Present
(Arr_Type
) then
6994 -- Verify that the actuals (excluding the object) match the types
7002 Actual
:= Next
(First_Actual
(Call
));
7003 Index
:= First_Index
(Arr_Type
);
7004 while Present
(Actual
) and then Present
(Index
) loop
7005 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
7010 Next_Actual
(Actual
);
7016 and then Present
(Arr_Type
)
7018 Comp_Type
:= Component_Type
(Arr_Type
);
7022 if Present
(Comp_Type
)
7023 and then Etype
(Subprog
) /= Comp_Type
7025 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
7029 if Etype
(Call
) /= Any_Type
then
7034 end Valid_Candidate
;
7036 -------------------------------
7037 -- Complete_Object_Operation --
7038 -------------------------------
7040 procedure Complete_Object_Operation
7041 (Call_Node
: Node_Id
;
7042 Node_To_Replace
: Node_Id
)
7044 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
7045 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
7046 First_Actual
: Node_Id
;
7049 -- Place the name of the operation, with its interpretations,
7050 -- on the rewritten call.
7052 Set_Name
(Call_Node
, Subprog
);
7054 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
7056 -- For cross-reference purposes, treat the new node as being in
7057 -- the source if the original one is. Set entity and type, even
7058 -- though they may be overwritten during resolution if overloaded.
7060 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
7061 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
7063 if Nkind
(N
) = N_Selected_Component
7064 and then not Inside_A_Generic
7066 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
7067 Set_Etype
(Selector_Name
(N
), Etype
(Entity
(Subprog
)));
7070 -- If need be, rewrite first actual as an explicit dereference
7071 -- If the call is overloaded, the rewriting can only be done
7072 -- once the primitive operation is identified.
7074 if Is_Overloaded
(Subprog
) then
7076 -- The prefix itself may be overloaded, and its interpretations
7077 -- must be propagated to the new actual in the call.
7079 if Is_Overloaded
(Obj
) then
7080 Save_Interps
(Obj
, First_Actual
);
7083 Rewrite
(First_Actual
, Obj
);
7085 elsif not Is_Access_Type
(Formal_Type
)
7086 and then Is_Access_Type
(Etype
(Obj
))
7088 Rewrite
(First_Actual
,
7089 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
7090 Analyze
(First_Actual
);
7092 -- If we need to introduce an explicit dereference, verify that
7093 -- the resulting actual is compatible with the mode of the formal.
7095 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
7096 and then Is_Access_Constant
(Etype
(Obj
))
7099 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
7102 -- Conversely, if the formal is an access parameter and the object
7103 -- is not, replace the actual with a 'Access reference. Its analysis
7104 -- will check that the object is aliased.
7106 elsif Is_Access_Type
(Formal_Type
)
7107 and then not Is_Access_Type
(Etype
(Obj
))
7109 -- A special case: A.all'access is illegal if A is an access to a
7110 -- constant and the context requires an access to a variable.
7112 if not Is_Access_Constant
(Formal_Type
) then
7113 if (Nkind
(Obj
) = N_Explicit_Dereference
7114 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
7115 or else not Is_Variable
(Obj
)
7118 ("actual for& must be a variable", Obj
, Control
);
7122 Rewrite
(First_Actual
,
7123 Make_Attribute_Reference
(Loc
,
7124 Attribute_Name
=> Name_Access
,
7125 Prefix
=> Relocate_Node
(Obj
)));
7127 if not Is_Aliased_View
(Obj
) then
7129 ("object in prefixed call to& must be aliased"
7130 & " (RM-2005 4.3.1 (13))",
7131 Prefix
(First_Actual
), Subprog
);
7134 Analyze
(First_Actual
);
7137 if Is_Overloaded
(Obj
) then
7138 Save_Interps
(Obj
, First_Actual
);
7141 Rewrite
(First_Actual
, Obj
);
7144 Rewrite
(Node_To_Replace
, Call_Node
);
7146 -- Propagate the interpretations collected in subprog to the new
7147 -- function call node, to be resolved from context.
7149 if Is_Overloaded
(Subprog
) then
7150 Save_Interps
(Subprog
, Node_To_Replace
);
7153 Analyze
(Node_To_Replace
);
7155 -- If the operation has been rewritten into a call, which may get
7156 -- subsequently an explicit dereference, preserve the type on the
7157 -- original node (selected component or indexed component) for
7158 -- subsequent legality tests, e.g. Is_Variable. which examines
7159 -- the original node.
7161 if Nkind
(Node_To_Replace
) = N_Function_Call
then
7163 (Original_Node
(Node_To_Replace
), Etype
(Node_To_Replace
));
7166 end Complete_Object_Operation
;
7168 ----------------------
7169 -- Report_Ambiguity --
7170 ----------------------
7172 procedure Report_Ambiguity
(Op
: Entity_Id
) is
7173 Access_Actual
: constant Boolean :=
7174 Is_Access_Type
(Etype
(Prefix
(N
)));
7175 Access_Formal
: Boolean := False;
7178 Error_Msg_Sloc
:= Sloc
(Op
);
7180 if Present
(First_Formal
(Op
)) then
7181 Access_Formal
:= Is_Access_Type
(Etype
(First_Formal
(Op
)));
7184 if Access_Formal
and then not Access_Actual
then
7185 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7187 ("\possible interpretation"
7188 & " (inherited, with implicit 'Access) #", N
);
7191 ("\possible interpretation (with implicit 'Access) #", N
);
7194 elsif not Access_Formal
and then Access_Actual
then
7195 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7197 ("\possible interpretation"
7198 & " ( inherited, with implicit dereference) #", N
);
7201 ("\possible interpretation (with implicit dereference) #", N
);
7205 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
7206 Error_Msg_N
("\possible interpretation (inherited)#", N
);
7208 Error_Msg_N
-- CODEFIX
7209 ("\possible interpretation#", N
);
7212 end Report_Ambiguity
;
7214 --------------------------------
7215 -- Transform_Object_Operation --
7216 --------------------------------
7218 procedure Transform_Object_Operation
7219 (Call_Node
: out Node_Id
;
7220 Node_To_Replace
: out Node_Id
)
7222 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
7223 -- Placeholder used as a first parameter in the call, replaced
7224 -- eventually by the proper object.
7226 Parent_Node
: constant Node_Id
:= Parent
(N
);
7232 -- Common case covering 1) Call to a procedure and 2) Call to a
7233 -- function that has some additional actuals.
7235 if Nkind
(Parent_Node
) in N_Subprogram_Call
7237 -- N is a selected component node containing the name of the
7238 -- subprogram. If N is not the name of the parent node we must
7239 -- not replace the parent node by the new construct. This case
7240 -- occurs when N is a parameterless call to a subprogram that
7241 -- is an actual parameter of a call to another subprogram. For
7243 -- Some_Subprogram (..., Obj.Operation, ...)
7245 and then Name
(Parent_Node
) = N
7247 Node_To_Replace
:= Parent_Node
;
7249 Actuals
:= Parameter_Associations
(Parent_Node
);
7251 if Present
(Actuals
) then
7252 Prepend
(Dummy
, Actuals
);
7254 Actuals
:= New_List
(Dummy
);
7257 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
7259 Make_Procedure_Call_Statement
(Loc
,
7260 Name
=> New_Copy
(Subprog
),
7261 Parameter_Associations
=> Actuals
);
7265 Make_Function_Call
(Loc
,
7266 Name
=> New_Copy
(Subprog
),
7267 Parameter_Associations
=> Actuals
);
7271 -- Before analysis, a function call appears as an indexed component
7272 -- if there are no named associations.
7274 elsif Nkind
(Parent_Node
) = N_Indexed_Component
7275 and then N
= Prefix
(Parent_Node
)
7277 Node_To_Replace
:= Parent_Node
;
7278 Actuals
:= Expressions
(Parent_Node
);
7280 Actual
:= First
(Actuals
);
7281 while Present
(Actual
) loop
7286 Prepend
(Dummy
, Actuals
);
7289 Make_Function_Call
(Loc
,
7290 Name
=> New_Copy
(Subprog
),
7291 Parameter_Associations
=> Actuals
);
7293 -- Parameterless call: Obj.F is rewritten as F (Obj)
7296 Node_To_Replace
:= N
;
7299 Make_Function_Call
(Loc
,
7300 Name
=> New_Copy
(Subprog
),
7301 Parameter_Associations
=> New_List
(Dummy
));
7303 end Transform_Object_Operation
;
7305 ------------------------------
7306 -- Try_Class_Wide_Operation --
7307 ------------------------------
7309 function Try_Class_Wide_Operation
7310 (Call_Node
: Node_Id
;
7311 Node_To_Replace
: Node_Id
) return Boolean
7313 Anc_Type
: Entity_Id
;
7314 Matching_Op
: Entity_Id
:= Empty
;
7317 procedure Traverse_Homonyms
7318 (Anc_Type
: Entity_Id
;
7319 Error
: out Boolean);
7320 -- Traverse the homonym chain of the subprogram searching for those
7321 -- homonyms whose first formal has the Anc_Type's class-wide type,
7322 -- or an anonymous access type designating the class-wide type. If
7323 -- an ambiguity is detected, then Error is set to True.
7325 procedure Traverse_Interfaces
7326 (Anc_Type
: Entity_Id
;
7327 Error
: out Boolean);
7328 -- Traverse the list of interfaces, if any, associated with Anc_Type
7329 -- and search for acceptable class-wide homonyms associated with each
7330 -- interface. If an ambiguity is detected, then Error is set to True.
7332 -----------------------
7333 -- Traverse_Homonyms --
7334 -----------------------
7336 procedure Traverse_Homonyms
7337 (Anc_Type
: Entity_Id
;
7338 Error
: out Boolean)
7340 Cls_Type
: Entity_Id
;
7348 Cls_Type
:= Class_Wide_Type
(Anc_Type
);
7350 Hom
:= Current_Entity
(Subprog
);
7352 -- Find a non-hidden operation whose first parameter is of the
7353 -- class-wide type, a subtype thereof, or an anonymous access
7354 -- to same. If in an instance, the operation can be considered
7355 -- even if hidden (it may be hidden because the instantiation is
7356 -- expanded after the containing package has been analyzed).
7358 while Present
(Hom
) loop
7359 if Ekind_In
(Hom
, E_Procedure
, E_Function
)
7360 and then (not Is_Hidden
(Hom
) or else In_Instance
)
7361 and then Scope
(Hom
) = Scope
(Anc_Type
)
7362 and then Present
(First_Formal
(Hom
))
7364 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
7366 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
7368 Ekind
(Etype
(First_Formal
(Hom
))) =
7369 E_Anonymous_Access_Type
7372 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
7375 -- If the context is a procedure call, ignore functions
7376 -- in the name of the call.
7378 if Ekind
(Hom
) = E_Function
7379 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
7380 and then N
= Name
(Parent
(N
))
7384 -- If the context is a function call, ignore procedures
7385 -- in the name of the call.
7387 elsif Ekind
(Hom
) = E_Procedure
7388 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
7393 Set_Etype
(Call_Node
, Any_Type
);
7394 Set_Is_Overloaded
(Call_Node
, False);
7397 if No
(Matching_Op
) then
7398 Hom_Ref
:= New_Reference_To
(Hom
, Sloc
(Subprog
));
7399 Set_Etype
(Call_Node
, Any_Type
);
7400 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
7402 Set_Name
(Call_Node
, Hom_Ref
);
7407 Report
=> Report_Error
,
7409 Skip_First
=> True);
7412 Valid_Candidate
(Success
, Call_Node
, Hom
);
7418 Report
=> Report_Error
,
7420 Skip_First
=> True);
7422 if Present
(Valid_Candidate
(Success
, Call_Node
, Hom
))
7423 and then Nkind
(Call_Node
) /= N_Function_Call
7425 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
7426 Report_Ambiguity
(Matching_Op
);
7427 Report_Ambiguity
(Hom
);
7435 Hom
:= Homonym
(Hom
);
7437 end Traverse_Homonyms
;
7439 -------------------------
7440 -- Traverse_Interfaces --
7441 -------------------------
7443 procedure Traverse_Interfaces
7444 (Anc_Type
: Entity_Id
;
7445 Error
: out Boolean)
7447 Intface_List
: constant List_Id
:=
7448 Abstract_Interface_List
(Anc_Type
);
7454 if Is_Non_Empty_List
(Intface_List
) then
7455 Intface
:= First
(Intface_List
);
7456 while Present
(Intface
) loop
7458 -- Look for acceptable class-wide homonyms associated with
7461 Traverse_Homonyms
(Etype
(Intface
), Error
);
7467 -- Continue the search by looking at each of the interface's
7468 -- associated interface ancestors.
7470 Traverse_Interfaces
(Etype
(Intface
), Error
);
7479 end Traverse_Interfaces
;
7481 -- Start of processing for Try_Class_Wide_Operation
7484 -- If we are searching only for conflicting class-wide subprograms
7485 -- then initialize directly Matching_Op with the target entity.
7487 if CW_Test_Only
then
7488 Matching_Op
:= Entity
(Selector_Name
(N
));
7491 -- Loop through ancestor types (including interfaces), traversing
7492 -- the homonym chain of the subprogram, trying out those homonyms
7493 -- whose first formal has the class-wide type of the ancestor, or
7494 -- an anonymous access type designating the class-wide type.
7496 Anc_Type
:= Obj_Type
;
7498 -- Look for a match among homonyms associated with the ancestor
7500 Traverse_Homonyms
(Anc_Type
, Error
);
7506 -- Continue the search for matches among homonyms associated with
7507 -- any interfaces implemented by the ancestor.
7509 Traverse_Interfaces
(Anc_Type
, Error
);
7515 exit when Etype
(Anc_Type
) = Anc_Type
;
7516 Anc_Type
:= Etype
(Anc_Type
);
7519 if Present
(Matching_Op
) then
7520 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
7523 return Present
(Matching_Op
);
7524 end Try_Class_Wide_Operation
;
7526 -----------------------------------
7527 -- Try_One_Prefix_Interpretation --
7528 -----------------------------------
7530 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
7534 if Is_Access_Type
(Obj_Type
) then
7535 Obj_Type
:= Designated_Type
(Obj_Type
);
7538 if Ekind
(Obj_Type
) = E_Private_Subtype
then
7539 Obj_Type
:= Base_Type
(Obj_Type
);
7542 if Is_Class_Wide_Type
(Obj_Type
) then
7543 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
7546 -- The type may have be obtained through a limited_with clause,
7547 -- in which case the primitive operations are available on its
7548 -- non-limited view. If still incomplete, retrieve full view.
7550 if Ekind
(Obj_Type
) = E_Incomplete_Type
7551 and then From_With_Type
(Obj_Type
)
7553 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
7556 -- If the object is not tagged, or the type is still an incomplete
7557 -- type, this is not a prefixed call.
7559 if not Is_Tagged_Type
(Obj_Type
)
7560 or else Is_Incomplete_Type
(Obj_Type
)
7566 Dup_Call_Node
: constant Node_Id
:= New_Copy
(New_Call_Node
);
7567 CW_Result
: Boolean;
7568 Prim_Result
: Boolean;
7569 pragma Unreferenced
(CW_Result
);
7572 if not CW_Test_Only
then
7574 Try_Primitive_Operation
7575 (Call_Node
=> New_Call_Node
,
7576 Node_To_Replace
=> Node_To_Replace
);
7579 -- Check if there is a class-wide subprogram covering the
7580 -- primitive. This check must be done even if a candidate
7581 -- was found in order to report ambiguous calls.
7583 if not (Prim_Result
) then
7585 Try_Class_Wide_Operation
7586 (Call_Node
=> New_Call_Node
,
7587 Node_To_Replace
=> Node_To_Replace
);
7589 -- If we found a primitive we search for class-wide subprograms
7590 -- using a duplicate of the call node (done to avoid missing its
7591 -- decoration if there is no ambiguity).
7595 Try_Class_Wide_Operation
7596 (Call_Node
=> Dup_Call_Node
,
7597 Node_To_Replace
=> Node_To_Replace
);
7600 end Try_One_Prefix_Interpretation
;
7602 -----------------------------
7603 -- Try_Primitive_Operation --
7604 -----------------------------
7606 function Try_Primitive_Operation
7607 (Call_Node
: Node_Id
;
7608 Node_To_Replace
: Node_Id
) return Boolean
7611 Prim_Op
: Entity_Id
;
7612 Matching_Op
: Entity_Id
:= Empty
;
7613 Prim_Op_Ref
: Node_Id
:= Empty
;
7615 Corr_Type
: Entity_Id
:= Empty
;
7616 -- If the prefix is a synchronized type, the controlling type of
7617 -- the primitive operation is the corresponding record type, else
7618 -- this is the object type itself.
7620 Success
: Boolean := False;
7622 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
7623 -- For tagged types the candidate interpretations are found in
7624 -- the list of primitive operations of the type and its ancestors.
7625 -- For formal tagged types we have to find the operations declared
7626 -- in the same scope as the type (including in the generic formal
7627 -- part) because the type itself carries no primitive operations,
7628 -- except for formal derived types that inherit the operations of
7629 -- the parent and progenitors.
7630 -- If the context is a generic subprogram body, the generic formals
7631 -- are visible by name, but are not in the entity list of the
7632 -- subprogram because that list starts with the subprogram formals.
7633 -- We retrieve the candidate operations from the generic declaration.
7635 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
7636 -- An operation that overrides an inherited operation in the private
7637 -- part of its package may be hidden, but if the inherited operation
7638 -- is visible a direct call to it will dispatch to the private one,
7639 -- which is therefore a valid candidate.
7641 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
7642 -- Verify that the prefix, dereferenced if need be, is a valid
7643 -- controlling argument in a call to Op. The remaining actuals
7644 -- are checked in the subsequent call to Analyze_One_Call.
7646 ------------------------------
7647 -- Collect_Generic_Type_Ops --
7648 ------------------------------
7650 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
7651 Bas
: constant Entity_Id
:= Base_Type
(T
);
7652 Candidates
: constant Elist_Id
:= New_Elmt_List
;
7656 procedure Check_Candidate
;
7657 -- The operation is a candidate if its first parameter is a
7658 -- controlling operand of the desired type.
7660 -----------------------
7661 -- Check_Candidate; --
7662 -----------------------
7664 procedure Check_Candidate
is
7666 Formal
:= First_Formal
(Subp
);
7669 and then Is_Controlling_Formal
(Formal
)
7671 (Base_Type
(Etype
(Formal
)) = Bas
7673 (Is_Access_Type
(Etype
(Formal
))
7674 and then Designated_Type
(Etype
(Formal
)) = Bas
))
7676 Append_Elmt
(Subp
, Candidates
);
7678 end Check_Candidate
;
7680 -- Start of processing for Collect_Generic_Type_Ops
7683 if Is_Derived_Type
(T
) then
7684 return Primitive_Operations
(T
);
7686 elsif Ekind_In
(Scope
(T
), E_Procedure
, E_Function
) then
7688 -- Scan the list of generic formals to find subprograms
7689 -- that may have a first controlling formal of the type.
7691 if Nkind
(Unit_Declaration_Node
(Scope
(T
)))
7692 = N_Generic_Subprogram_Declaration
7699 First
(Generic_Formal_Declarations
7700 (Unit_Declaration_Node
(Scope
(T
))));
7701 while Present
(Decl
) loop
7702 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
7703 Subp
:= Defining_Entity
(Decl
);
7714 -- Scan the list of entities declared in the same scope as
7715 -- the type. In general this will be an open scope, given that
7716 -- the call we are analyzing can only appear within a generic
7717 -- declaration or body (either the one that declares T, or a
7720 -- For a subtype representing a generic actual type, go to the
7723 if Is_Generic_Actual_Type
(T
) then
7724 Subp
:= First_Entity
(Scope
(Base_Type
(T
)));
7726 Subp
:= First_Entity
(Scope
(T
));
7729 while Present
(Subp
) loop
7730 if Is_Overloadable
(Subp
) then
7739 end Collect_Generic_Type_Ops
;
7741 ---------------------------
7742 -- Is_Private_Overriding --
7743 ---------------------------
7745 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
7746 Visible_Op
: constant Entity_Id
:= Homonym
(Op
);
7749 return Present
(Visible_Op
)
7750 and then Scope
(Op
) = Scope
(Visible_Op
)
7751 and then not Comes_From_Source
(Visible_Op
)
7752 and then Alias
(Visible_Op
) = Op
7753 and then not Is_Hidden
(Visible_Op
);
7754 end Is_Private_Overriding
;
7756 -----------------------------
7757 -- Valid_First_Argument_Of --
7758 -----------------------------
7760 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
7761 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
7764 if Is_Concurrent_Type
(Typ
)
7765 and then Present
(Corresponding_Record_Type
(Typ
))
7767 Typ
:= Corresponding_Record_Type
(Typ
);
7770 -- Simple case. Object may be a subtype of the tagged type or
7771 -- may be the corresponding record of a synchronized type.
7773 return Obj_Type
= Typ
7774 or else Base_Type
(Obj_Type
) = Typ
7775 or else Corr_Type
= Typ
7777 -- Prefix can be dereferenced
7780 (Is_Access_Type
(Corr_Type
)
7781 and then Designated_Type
(Corr_Type
) = Typ
)
7783 -- Formal is an access parameter, for which the object
7784 -- can provide an access.
7787 (Ekind
(Typ
) = E_Anonymous_Access_Type
7789 Base_Type
(Designated_Type
(Typ
)) = Base_Type
(Corr_Type
));
7790 end Valid_First_Argument_Of
;
7792 -- Start of processing for Try_Primitive_Operation
7795 -- Look for subprograms in the list of primitive operations. The name
7796 -- must be identical, and the kind of call indicates the expected
7797 -- kind of operation (function or procedure). If the type is a
7798 -- (tagged) synchronized type, the primitive ops are attached to the
7799 -- corresponding record (base) type.
7801 if Is_Concurrent_Type
(Obj_Type
) then
7802 if Present
(Corresponding_Record_Type
(Obj_Type
)) then
7803 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
7804 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
7806 Corr_Type
:= Obj_Type
;
7807 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
7810 elsif not Is_Generic_Type
(Obj_Type
) then
7811 Corr_Type
:= Obj_Type
;
7812 Elmt
:= First_Elmt
(Primitive_Operations
(Obj_Type
));
7815 Corr_Type
:= Obj_Type
;
7816 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
7819 while Present
(Elmt
) loop
7820 Prim_Op
:= Node
(Elmt
);
7822 if Chars
(Prim_Op
) = Chars
(Subprog
)
7823 and then Present
(First_Formal
(Prim_Op
))
7824 and then Valid_First_Argument_Of
(Prim_Op
)
7826 (Nkind
(Call_Node
) = N_Function_Call
)
7827 = (Ekind
(Prim_Op
) = E_Function
)
7829 -- Ada 2005 (AI-251): If this primitive operation corresponds
7830 -- with an immediate ancestor interface there is no need to add
7831 -- it to the list of interpretations; the corresponding aliased
7832 -- primitive is also in this list of primitive operations and
7833 -- will be used instead.
7835 if (Present
(Interface_Alias
(Prim_Op
))
7836 and then Is_Ancestor
(Find_Dispatching_Type
7837 (Alias
(Prim_Op
)), Corr_Type
))
7839 -- Do not consider hidden primitives unless the type is in an
7840 -- open scope or we are within an instance, where visibility
7841 -- is known to be correct, or else if this is an overriding
7842 -- operation in the private part for an inherited operation.
7844 or else (Is_Hidden
(Prim_Op
)
7845 and then not Is_Immediately_Visible
(Obj_Type
)
7846 and then not In_Instance
7847 and then not Is_Private_Overriding
(Prim_Op
))
7852 Set_Etype
(Call_Node
, Any_Type
);
7853 Set_Is_Overloaded
(Call_Node
, False);
7855 if No
(Matching_Op
) then
7856 Prim_Op_Ref
:= New_Reference_To
(Prim_Op
, Sloc
(Subprog
));
7857 Candidate
:= Prim_Op
;
7859 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
7861 Set_Name
(Call_Node
, Prim_Op_Ref
);
7867 Report
=> Report_Error
,
7869 Skip_First
=> True);
7871 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
7873 -- More than one interpretation, collect for subsequent
7874 -- disambiguation. If this is a procedure call and there
7875 -- is another match, report ambiguity now.
7881 Report
=> Report_Error
,
7883 Skip_First
=> True);
7885 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
7886 and then Nkind
(Call_Node
) /= N_Function_Call
7888 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
7889 Report_Ambiguity
(Matching_Op
);
7890 Report_Ambiguity
(Prim_Op
);
7900 if Present
(Matching_Op
) then
7901 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
7904 return Present
(Matching_Op
);
7905 end Try_Primitive_Operation
;
7907 -- Start of processing for Try_Object_Operation
7910 Analyze_Expression
(Obj
);
7912 -- Analyze the actuals if node is known to be a subprogram call
7914 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
7915 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
7916 while Present
(Actual
) loop
7917 Analyze_Expression
(Actual
);
7922 -- Build a subprogram call node, using a copy of Obj as its first
7923 -- actual. This is a placeholder, to be replaced by an explicit
7924 -- dereference when needed.
7926 Transform_Object_Operation
7927 (Call_Node
=> New_Call_Node
,
7928 Node_To_Replace
=> Node_To_Replace
);
7930 Set_Etype
(New_Call_Node
, Any_Type
);
7931 Set_Etype
(Subprog
, Any_Type
);
7932 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
7934 if not Is_Overloaded
(Obj
) then
7935 Try_One_Prefix_Interpretation
(Obj_Type
);
7942 Get_First_Interp
(Obj
, I
, It
);
7943 while Present
(It
.Nam
) loop
7944 Try_One_Prefix_Interpretation
(It
.Typ
);
7945 Get_Next_Interp
(I
, It
);
7950 if Etype
(New_Call_Node
) /= Any_Type
then
7952 -- No need to complete the tree transformations if we are only
7953 -- searching for conflicting class-wide subprograms
7955 if CW_Test_Only
then
7958 Complete_Object_Operation
7959 (Call_Node
=> New_Call_Node
,
7960 Node_To_Replace
=> Node_To_Replace
);
7964 elsif Present
(Candidate
) then
7966 -- The argument list is not type correct. Re-analyze with error
7967 -- reporting enabled, and use one of the possible candidates.
7968 -- In All_Errors_Mode, re-analyze all failed interpretations.
7970 if All_Errors_Mode
then
7971 Report_Error
:= True;
7972 if Try_Primitive_Operation
7973 (Call_Node
=> New_Call_Node
,
7974 Node_To_Replace
=> Node_To_Replace
)
7977 Try_Class_Wide_Operation
7978 (Call_Node
=> New_Call_Node
,
7979 Node_To_Replace
=> Node_To_Replace
)
7986 (N
=> New_Call_Node
,
7990 Skip_First
=> True);
7993 -- No need for further errors
7998 -- There was no candidate operation, so report it as an error
7999 -- in the caller: Analyze_Selected_Component.
8003 end Try_Object_Operation
;
8009 procedure wpo
(T
: Entity_Id
) is
8014 if not Is_Tagged_Type
(T
) then
8018 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
8019 while Present
(E
) loop
8021 Write_Int
(Int
(Op
));
8022 Write_Str
(" === ");
8023 Write_Name
(Chars
(Op
));
8025 Write_Name
(Chars
(Scope
(Op
)));