1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Itypes
; use Itypes
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Namet
; use Namet
;
37 with Namet
.Sp
; use Namet
.Sp
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Output
; use Output
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
45 with Sem_Aux
; use Sem_Aux
;
46 with Sem_Case
; use Sem_Case
;
47 with Sem_Cat
; use Sem_Cat
;
48 with Sem_Ch3
; use Sem_Ch3
;
49 with Sem_Ch6
; use Sem_Ch6
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Dim
; use Sem_Dim
;
52 with Sem_Disp
; use Sem_Disp
;
53 with Sem_Dist
; use Sem_Dist
;
54 with Sem_Eval
; use Sem_Eval
;
55 with Sem_Res
; use Sem_Res
;
56 with Sem_Type
; use Sem_Type
;
57 with Sem_Util
; use Sem_Util
;
58 with Sem_Warn
; use Sem_Warn
;
59 with Stand
; use Stand
;
60 with Sinfo
; use Sinfo
;
61 with Snames
; use Snames
;
62 with Tbuild
; use Tbuild
;
63 with Uintp
; use Uintp
;
65 package body Sem_Ch4
is
67 -- Tables which speed up the identification of dangerous calls to Ada 2012
68 -- functions with writable actuals (AI05-0144).
70 -- The following table enumerates the Ada constructs which may evaluate in
71 -- arbitrary order. It does not cover all the language constructs which can
72 -- be evaluated in arbitrary order but the subset needed for AI05-0144.
74 Has_Arbitrary_Evaluation_Order
: constant array (Node_Kind
) of Boolean :=
76 N_Assignment_Statement
=> True,
77 N_Entry_Call_Statement
=> True,
78 N_Extension_Aggregate
=> True,
79 N_Full_Type_Declaration
=> True,
80 N_Indexed_Component
=> True,
81 N_Object_Declaration
=> True,
85 N_Array_Type_Definition
=> True,
86 N_Membership_Test
=> True,
88 N_Subprogram_Call
=> True,
91 -- The following table enumerates the nodes on which we stop climbing when
92 -- locating the outermost Ada construct that can be evaluated in arbitrary
95 Stop_Subtree_Climbing
: constant array (Node_Kind
) of Boolean :=
97 N_Assignment_Statement
=> True,
98 N_Entry_Call_Statement
=> True,
99 N_Extended_Return_Statement
=> True,
100 N_Extension_Aggregate
=> True,
101 N_Full_Type_Declaration
=> True,
102 N_Object_Declaration
=> True,
103 N_Object_Renaming_Declaration
=> True,
104 N_Package_Specification
=> True,
106 N_Procedure_Call_Statement
=> True,
107 N_Simple_Return_Statement
=> True,
108 N_Has_Condition
=> True,
111 -----------------------
112 -- Local Subprograms --
113 -----------------------
115 procedure Analyze_Concatenation_Rest
(N
: Node_Id
);
116 -- Does the "rest" of the work of Analyze_Concatenation, after the left
117 -- operand has been analyzed. See Analyze_Concatenation for details.
119 procedure Analyze_Expression
(N
: Node_Id
);
120 -- For expressions that are not names, this is just a call to analyze. If
121 -- the expression is a name, it may be a call to a parameterless function,
122 -- and if so must be converted into an explicit call node and analyzed as
123 -- such. This deproceduring must be done during the first pass of overload
124 -- resolution, because otherwise a procedure call with overloaded actuals
125 -- may fail to resolve.
127 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
);
128 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call is an
129 -- operator name or an expanded name whose selector is an operator name,
130 -- and one possible interpretation is as a predefined operator.
132 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
);
133 -- If the prefix of a selected_component is overloaded, the proper
134 -- interpretation that yields a record type with the proper selector
135 -- name must be selected.
137 procedure Analyze_User_Defined_Binary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
138 -- Procedure to analyze a user defined binary operator, which is resolved
139 -- like a function, but instead of a list of actuals it is presented
140 -- with the left and right operands of an operator node.
142 procedure Analyze_User_Defined_Unary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
143 -- Procedure to analyze a user defined unary operator, which is resolved
144 -- like a function, but instead of a list of actuals, it is presented with
145 -- the operand of the operator node.
147 procedure Ambiguous_Operands
(N
: Node_Id
);
148 -- For equality, membership, and comparison operators with overloaded
149 -- arguments, list possible interpretations.
151 procedure Analyze_One_Call
155 Success
: out Boolean;
156 Skip_First
: Boolean := False);
157 -- Check one interpretation of an overloaded subprogram name for
158 -- compatibility with the types of the actuals in a call. If there is a
159 -- single interpretation which does not match, post error if Report is
162 -- Nam is the entity that provides the formals against which the actuals
163 -- are checked. Nam is either the name of a subprogram, or the internal
164 -- subprogram type constructed for an access_to_subprogram. If the actuals
165 -- are compatible with Nam, then Nam is added to the list of candidate
166 -- interpretations for N, and Success is set to True.
168 -- The flag Skip_First is used when analyzing a call that was rewritten
169 -- from object notation. In this case the first actual may have to receive
170 -- an explicit dereference, depending on the first formal of the operation
171 -- being called. The caller will have verified that the object is legal
172 -- for the call. If the remaining parameters match, the first parameter
173 -- will rewritten as a dereference if needed, prior to completing analysis.
175 procedure Check_Misspelled_Selector
178 -- Give possible misspelling message if Sel seems likely to be a mis-
179 -- spelling of one of the selectors of the Prefix. This is called by
180 -- Analyze_Selected_Component after producing an invalid selector error
183 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean;
184 -- Verify that type T is declared in scope S. Used to find interpretations
185 -- for operators given by expanded names. This is abstracted as a separate
186 -- function to handle extensions to System, where S is System, but T is
187 -- declared in the extension.
189 procedure Find_Arithmetic_Types
193 -- L and R are the operands of an arithmetic operator. Find consistent
194 -- pairs of interpretations for L and R that have a numeric type consistent
195 -- with the semantics of the operator.
197 procedure Find_Comparison_Types
201 -- L and R are operands of a comparison operator. Find consistent pairs of
202 -- interpretations for L and R.
204 procedure Find_Concatenation_Types
208 -- For the four varieties of concatenation
210 procedure Find_Equality_Types
214 -- Ditto for equality operators
216 procedure Find_Boolean_Types
220 -- Ditto for binary logical operations
222 procedure Find_Negation_Types
226 -- Find consistent interpretation for operand of negation operator
228 procedure Find_Non_Universal_Interpretations
233 -- For equality and comparison operators, the result is always boolean, and
234 -- the legality of the operation is determined from the visibility of the
235 -- operand types. If one of the operands has a universal interpretation,
236 -- the legality check uses some compatible non-universal interpretation of
237 -- the other operand. N can be an operator node, or a function call whose
238 -- name is an operator designator. Any_Access, which is the initial type of
239 -- the literal NULL, is a universal type for the purpose of this routine.
241 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean;
242 -- Find candidate interpretations for the name Obj.Proc when it appears in
243 -- a subprogram renaming declaration.
245 procedure Find_Unary_Types
249 -- Unary arithmetic types: plus, minus, abs
251 procedure Check_Arithmetic_Pair
255 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types
256 -- for left and right operand. Determine whether they constitute a valid
257 -- pair for the given operator, and record the corresponding interpretation
258 -- of the operator node. The node N may be an operator node (the usual
259 -- case) or a function call whose prefix is an operator designator. In
260 -- both cases Op_Id is the operator name itself.
262 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
);
263 -- Give detailed information on overloaded call where none of the
264 -- interpretations match. N is the call node, Nam the designator for
265 -- the overloaded entity being called.
267 function Junk_Operand
(N
: Node_Id
) return Boolean;
268 -- Test for an operand that is an inappropriate entity (e.g. a package
269 -- name or a label). If so, issue an error message and return True. If
270 -- the operand is not an inappropriate entity kind, return False.
272 procedure Operator_Check
(N
: Node_Id
);
273 -- Verify that an operator has received some valid interpretation. If none
274 -- was found, determine whether a use clause would make the operation
275 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
276 -- every type compatible with the operator, even if the operator for the
277 -- type is not directly visible. The routine uses this type to emit a more
278 -- informative message.
280 function Process_Implicit_Dereference_Prefix
282 P
: Node_Id
) return Entity_Id
;
283 -- Called when P is the prefix of an implicit dereference, denoting an
284 -- object E. The function returns the designated type of the prefix, taking
285 -- into account that the designated type of an anonymous access type may be
286 -- a limited view, when the non-limited view is visible.
288 -- If in semantics only mode (-gnatc or generic), the function also records
289 -- that the prefix is a reference to E, if any. Normally, such a reference
290 -- is generated only when the implicit dereference is expanded into an
291 -- explicit one, but for consistency we must generate the reference when
292 -- expansion is disabled as well.
294 procedure Remove_Abstract_Operations
(N
: Node_Id
);
295 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
296 -- operation is not a candidate interpretation.
298 function Try_Container_Indexing
301 Exprs
: List_Id
) return Boolean;
302 -- AI05-0139: Generalized indexing to support iterators over containers
304 function Try_Indexed_Call
308 Skip_First
: Boolean) return Boolean;
309 -- If a function has defaults for all its actuals, a call to it may in fact
310 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
311 -- interpretation as an indexing, prior to analysis as a call. If both are
312 -- possible, the node is overloaded with both interpretations (same symbol
313 -- but two different types). If the call is written in prefix form, the
314 -- prefix becomes the first parameter in the call, and only the remaining
315 -- actuals must be checked for the presence of defaults.
317 function Try_Indirect_Call
320 Typ
: Entity_Id
) return Boolean;
321 -- Similarly, a function F that needs no actuals can return an access to a
322 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
323 -- the call may be overloaded with both interpretations.
325 procedure wpo
(T
: Entity_Id
);
326 pragma Warnings
(Off
, wpo
);
327 -- Used for debugging: obtain list of primitive operations even if
328 -- type is not frozen and dispatch table is not built yet.
330 ------------------------
331 -- Ambiguous_Operands --
332 ------------------------
334 procedure Ambiguous_Operands
(N
: Node_Id
) is
335 procedure List_Operand_Interps
(Opnd
: Node_Id
);
337 --------------------------
338 -- List_Operand_Interps --
339 --------------------------
341 procedure List_Operand_Interps
(Opnd
: Node_Id
) is
343 pragma Warnings
(Off
, Nam
);
347 if Is_Overloaded
(Opnd
) then
348 if Nkind
(Opnd
) in N_Op
then
351 elsif Nkind
(Opnd
) = N_Function_Call
then
354 elsif Ada_Version
>= Ada_2012
then
360 Get_First_Interp
(Opnd
, I
, It
);
361 while Present
(It
.Nam
) loop
362 if Has_Implicit_Dereference
(It
.Typ
) then
364 ("can be interpreted as implicit dereference", Opnd
);
368 Get_Next_Interp
(I
, It
);
379 if Opnd
= Left_Opnd
(N
) then
381 ("\left operand has the following interpretations", N
);
384 ("\right operand has the following interpretations", N
);
388 List_Interps
(Nam
, Err
);
389 end List_Operand_Interps
;
391 -- Start of processing for Ambiguous_Operands
394 if Nkind
(N
) in N_Membership_Test
then
395 Error_Msg_N
("ambiguous operands for membership", N
);
397 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
) then
398 Error_Msg_N
("ambiguous operands for equality", N
);
401 Error_Msg_N
("ambiguous operands for comparison", N
);
404 if All_Errors_Mode
then
405 List_Operand_Interps
(Left_Opnd
(N
));
406 List_Operand_Interps
(Right_Opnd
(N
));
408 Error_Msg_N
("\use -gnatf switch for details", N
);
410 end Ambiguous_Operands
;
412 -----------------------
413 -- Analyze_Aggregate --
414 -----------------------
416 -- Most of the analysis of Aggregates requires that the type be known,
417 -- and is therefore put off until resolution.
419 procedure Analyze_Aggregate
(N
: Node_Id
) is
421 if No
(Etype
(N
)) then
422 Set_Etype
(N
, Any_Composite
);
424 end Analyze_Aggregate
;
426 -----------------------
427 -- Analyze_Allocator --
428 -----------------------
430 procedure Analyze_Allocator
(N
: Node_Id
) is
431 Loc
: constant Source_Ptr
:= Sloc
(N
);
432 Sav_Errs
: constant Nat
:= Serious_Errors_Detected
;
433 E
: Node_Id
:= Expression
(N
);
434 Acc_Type
: Entity_Id
;
441 Check_SPARK_05_Restriction
("allocator is not allowed", N
);
443 -- Deal with allocator restrictions
445 -- In accordance with H.4(7), the No_Allocators restriction only applies
446 -- to user-written allocators. The same consideration applies to the
447 -- No_Standard_Allocators_Before_Elaboration restriction.
449 if Comes_From_Source
(N
) then
450 Check_Restriction
(No_Allocators
, N
);
452 -- Processing for No_Standard_Allocators_After_Elaboration, loop to
453 -- look at enclosing context, checking task/main subprogram case.
457 while Present
(P
) loop
459 -- For the task case we need a handled sequence of statements,
460 -- where the occurrence of the allocator is within the statements
461 -- and the parent is a task body
463 if Nkind
(P
) = N_Handled_Sequence_Of_Statements
464 and then Is_List_Member
(C
)
465 and then List_Containing
(C
) = Statements
(P
)
467 Onode
:= Original_Node
(Parent
(P
));
469 -- Check for allocator within task body, this is a definite
470 -- violation of No_Allocators_After_Elaboration we can detect
473 if Nkind
(Onode
) = N_Task_Body
then
475 (No_Standard_Allocators_After_Elaboration
, N
);
480 -- The other case is appearance in a subprogram body. This is
481 -- a violation if this is a library level subprogram with no
482 -- parameters. Note that this is now a static error even if the
483 -- subprogram is not the main program (this is a change, in an
484 -- earlier version only the main program was affected, and the
485 -- check had to be done in the binder.
487 if Nkind
(P
) = N_Subprogram_Body
488 and then Nkind
(Parent
(P
)) = N_Compilation_Unit
489 and then No
(Parameter_Specifications
(Specification
(P
)))
492 (No_Standard_Allocators_After_Elaboration
, N
);
500 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
501 -- any. The expected type for the name is any type. A non-overloading
502 -- rule then requires it to be of a type descended from
503 -- System.Storage_Pools.Subpools.Subpool_Handle.
505 -- This isn't exactly what the AI says, but it seems to be the right
506 -- rule. The AI should be fixed.???
509 Subpool
: constant Node_Id
:= Subpool_Handle_Name
(N
);
512 if Present
(Subpool
) then
515 if Is_Overloaded
(Subpool
) then
516 Error_Msg_N
("ambiguous subpool handle", Subpool
);
519 -- Check that Etype (Subpool) is descended from Subpool_Handle
525 -- Analyze the qualified expression or subtype indication
527 if Nkind
(E
) = N_Qualified_Expression
then
528 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
529 Set_Etype
(Acc_Type
, Acc_Type
);
530 Find_Type
(Subtype_Mark
(E
));
532 -- Analyze the qualified expression, and apply the name resolution
533 -- rule given in 4.7(3).
536 Type_Id
:= Etype
(E
);
537 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
539 -- A qualified expression requires an exact match of the type,
540 -- class-wide matching is not allowed.
542 -- if Is_Class_Wide_Type (Type_Id)
543 -- and then Base_Type
544 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
546 -- Wrong_Type (Expression (E), Type_Id);
549 -- We don't analyze the qualified expression itself because it's
550 -- part of the allocator. It is fully analyzed and resolved when
551 -- the allocator is resolved with the context type.
553 Set_Etype
(E
, Type_Id
);
555 -- Case where allocator has a subtype indication
560 Base_Typ
: Entity_Id
;
563 -- If the allocator includes a N_Subtype_Indication then a
564 -- constraint is present, otherwise the node is a subtype mark.
565 -- Introduce an explicit subtype declaration into the tree
566 -- defining some anonymous subtype and rewrite the allocator to
567 -- use this subtype rather than the subtype indication.
569 -- It is important to introduce the explicit subtype declaration
570 -- so that the bounds of the subtype indication are attached to
571 -- the tree in case the allocator is inside a generic unit.
573 -- Finally, if there is no subtype indication and the type is
574 -- a tagged unconstrained type with discriminants, the designated
575 -- object is constrained by their default values, and it is
576 -- simplest to introduce an explicit constraint now. In some cases
577 -- this is done during expansion, but freeze actions are certain
578 -- to be emitted in the proper order if constraint is explicit.
580 if Is_Entity_Name
(E
) and then Expander_Active
then
582 Type_Id
:= Entity
(E
);
584 if Is_Tagged_Type
(Type_Id
)
585 and then Has_Discriminants
(Type_Id
)
586 and then not Is_Constrained
(Type_Id
)
589 (Discriminant_Default_Value
590 (First_Discriminant
(Type_Id
)))
593 Constr
: constant List_Id
:= New_List
;
594 Loc
: constant Source_Ptr
:= Sloc
(E
);
595 Discr
: Entity_Id
:= First_Discriminant
(Type_Id
);
598 if Present
(Discriminant_Default_Value
(Discr
)) then
599 while Present
(Discr
) loop
600 Append
(Discriminant_Default_Value
(Discr
), Constr
);
601 Next_Discriminant
(Discr
);
605 Make_Subtype_Indication
(Loc
,
606 Subtype_Mark
=> New_Occurrence_Of
(Type_Id
, Loc
),
608 Make_Index_Or_Discriminant_Constraint
(Loc
,
609 Constraints
=> Constr
)));
615 if Nkind
(E
) = N_Subtype_Indication
then
617 -- A constraint is only allowed for a composite type in Ada
618 -- 95. In Ada 83, a constraint is also allowed for an
619 -- access-to-composite type, but the constraint is ignored.
621 Find_Type
(Subtype_Mark
(E
));
622 Base_Typ
:= Entity
(Subtype_Mark
(E
));
624 if Is_Elementary_Type
(Base_Typ
) then
625 if not (Ada_Version
= Ada_83
626 and then Is_Access_Type
(Base_Typ
))
628 Error_Msg_N
("constraint not allowed here", E
);
630 if Nkind
(Constraint
(E
)) =
631 N_Index_Or_Discriminant_Constraint
633 Error_Msg_N
-- CODEFIX
634 ("\if qualified expression was meant, " &
635 "use apostrophe", Constraint
(E
));
639 -- Get rid of the bogus constraint:
641 Rewrite
(E
, New_Copy_Tree
(Subtype_Mark
(E
)));
642 Analyze_Allocator
(N
);
646 if Expander_Active
then
647 Def_Id
:= Make_Temporary
(Loc
, 'S');
650 Make_Subtype_Declaration
(Loc
,
651 Defining_Identifier
=> Def_Id
,
652 Subtype_Indication
=> Relocate_Node
(E
)));
654 if Sav_Errs
/= Serious_Errors_Detected
655 and then Nkind
(Constraint
(E
)) =
656 N_Index_Or_Discriminant_Constraint
658 Error_Msg_N
-- CODEFIX
659 ("if qualified expression was meant, "
660 & "use apostrophe!", Constraint
(E
));
663 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
664 Rewrite
(Expression
(N
), E
);
668 Type_Id
:= Process_Subtype
(E
, N
);
669 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
670 Set_Etype
(Acc_Type
, Acc_Type
);
671 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
672 Check_Fully_Declared
(Type_Id
, N
);
674 -- Ada 2005 (AI-231): If the designated type is itself an access
675 -- type that excludes null, its default initialization will
676 -- be a null object, and we can insert an unconditional raise
677 -- before the allocator.
679 -- Ada 2012 (AI-104): A not null indication here is altogether
682 if Can_Never_Be_Null
(Type_Id
) then
684 Not_Null_Check
: constant Node_Id
:=
685 Make_Raise_Constraint_Error
(Sloc
(E
),
686 Reason
=> CE_Null_Not_Allowed
);
689 if Expander_Active
then
690 Insert_Action
(N
, Not_Null_Check
);
691 Analyze
(Not_Null_Check
);
693 elsif Warn_On_Ada_2012_Compatibility
then
695 ("null value not allowed here in Ada 2012?y?", E
);
700 -- Check for missing initialization. Skip this check if we already
701 -- had errors on analyzing the allocator, since in that case these
702 -- are probably cascaded errors.
704 if not Is_Definite_Subtype
(Type_Id
)
705 and then Serious_Errors_Detected
= Sav_Errs
707 -- The build-in-place machinery may produce an allocator when
708 -- the designated type is indefinite but the underlying type is
709 -- not. In this case the unknown discriminants are meaningless
710 -- and should not trigger error messages. Check the parent node
711 -- because the allocator is marked as coming from source.
713 if Present
(Underlying_Type
(Type_Id
))
714 and then Is_Definite_Subtype
(Underlying_Type
(Type_Id
))
715 and then not Comes_From_Source
(Parent
(N
))
719 -- An unusual case arises when the parent of a derived type is
720 -- a limited record extension with unknown discriminants, and
721 -- its full view has no discriminants.
723 -- A more general fix might be to create the proper underlying
724 -- type for such a derived type, but it is a record type with
725 -- no private attributes, so this required extending the
726 -- meaning of this attribute. ???
728 elsif Ekind
(Etype
(Type_Id
)) = E_Record_Type_With_Private
729 and then Present
(Underlying_Type
(Etype
(Type_Id
)))
731 not Has_Discriminants
(Underlying_Type
(Etype
(Type_Id
)))
732 and then not Comes_From_Source
(Parent
(N
))
736 elsif Is_Class_Wide_Type
(Type_Id
) then
738 ("initialization required in class-wide allocation", N
);
741 if Ada_Version
< Ada_2005
742 and then Is_Limited_Type
(Type_Id
)
744 Error_Msg_N
("unconstrained allocation not allowed", N
);
746 if Is_Array_Type
(Type_Id
) then
748 ("\constraint with array bounds required", N
);
750 elsif Has_Unknown_Discriminants
(Type_Id
) then
753 else pragma Assert
(Has_Discriminants
(Type_Id
));
755 ("\constraint with discriminant values required", N
);
758 -- Limited Ada 2005 and general non-limited case
762 ("uninitialized unconstrained allocation not "
765 if Is_Array_Type
(Type_Id
) then
767 ("\qualified expression or constraint with "
768 & "array bounds required", N
);
770 elsif Has_Unknown_Discriminants
(Type_Id
) then
771 Error_Msg_N
("\qualified expression required", N
);
773 else pragma Assert
(Has_Discriminants
(Type_Id
));
775 ("\qualified expression or constraint with "
776 & "discriminant values required", N
);
784 if Is_Abstract_Type
(Type_Id
) then
785 Error_Msg_N
("cannot allocate abstract object", E
);
788 if Has_Task
(Designated_Type
(Acc_Type
)) then
789 Check_Restriction
(No_Tasking
, N
);
790 Check_Restriction
(Max_Tasks
, N
);
791 Check_Restriction
(No_Task_Allocators
, N
);
794 -- Check restriction against dynamically allocated protected objects
796 if Has_Protected
(Designated_Type
(Acc_Type
)) then
797 Check_Restriction
(No_Protected_Type_Allocators
, N
);
800 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
801 -- type is nested, and the designated type needs finalization. The rule
802 -- is conservative in that class-wide types need finalization.
804 if Needs_Finalization
(Designated_Type
(Acc_Type
))
805 and then not Is_Library_Level_Entity
(Acc_Type
)
807 Check_Restriction
(No_Nested_Finalization
, N
);
810 -- Check that an allocator of a nested access type doesn't create a
811 -- protected object when restriction No_Local_Protected_Objects applies.
813 if Has_Protected
(Designated_Type
(Acc_Type
))
814 and then not Is_Library_Level_Entity
(Acc_Type
)
816 Check_Restriction
(No_Local_Protected_Objects
, N
);
819 -- Likewise for No_Local_Timing_Events
821 if Has_Timing_Event
(Designated_Type
(Acc_Type
))
822 and then not Is_Library_Level_Entity
(Acc_Type
)
824 Check_Restriction
(No_Local_Timing_Events
, N
);
827 -- If the No_Streams restriction is set, check that the type of the
828 -- object is not, and does not contain, any subtype derived from
829 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
830 -- Has_Stream just for efficiency reasons. There is no point in
831 -- spending time on a Has_Stream check if the restriction is not set.
833 if Restriction_Check_Required
(No_Streams
) then
834 if Has_Stream
(Designated_Type
(Acc_Type
)) then
835 Check_Restriction
(No_Streams
, N
);
839 Set_Etype
(N
, Acc_Type
);
841 if not Is_Library_Level_Entity
(Acc_Type
) then
842 Check_Restriction
(No_Local_Allocators
, N
);
845 if Serious_Errors_Detected
> Sav_Errs
then
846 Set_Error_Posted
(N
);
847 Set_Etype
(N
, Any_Type
);
849 end Analyze_Allocator
;
851 ---------------------------
852 -- Analyze_Arithmetic_Op --
853 ---------------------------
855 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
856 L
: constant Node_Id
:= Left_Opnd
(N
);
857 R
: constant Node_Id
:= Right_Opnd
(N
);
861 Candidate_Type
:= Empty
;
862 Analyze_Expression
(L
);
863 Analyze_Expression
(R
);
865 -- If the entity is already set, the node is the instantiation of a
866 -- generic node with a non-local reference, or was manufactured by a
867 -- call to Make_Op_xxx. In either case the entity is known to be valid,
868 -- and we do not need to collect interpretations, instead we just get
869 -- the single possible interpretation.
873 if Present
(Op_Id
) then
874 if Ekind
(Op_Id
) = E_Operator
then
876 if Nkind_In
(N
, N_Op_Divide
, N_Op_Mod
, N_Op_Multiply
, N_Op_Rem
)
877 and then Treat_Fixed_As_Integer
(N
)
881 Set_Etype
(N
, Any_Type
);
882 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
886 Set_Etype
(N
, Any_Type
);
887 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
890 -- Entity is not already set, so we do need to collect interpretations
893 Set_Etype
(N
, Any_Type
);
895 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
896 while Present
(Op_Id
) loop
897 if Ekind
(Op_Id
) = E_Operator
898 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
900 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
902 -- The following may seem superfluous, because an operator cannot
903 -- be generic, but this ignores the cleverness of the author of
906 elsif Is_Overloadable
(Op_Id
) then
907 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
910 Op_Id
:= Homonym
(Op_Id
);
915 Check_Function_Writable_Actuals
(N
);
916 end Analyze_Arithmetic_Op
;
922 -- Function, procedure, and entry calls are checked here. The Name in
923 -- the call may be overloaded. The actuals have been analyzed and may
924 -- themselves be overloaded. On exit from this procedure, the node N
925 -- may have zero, one or more interpretations. In the first case an
926 -- error message is produced. In the last case, the node is flagged
927 -- as overloaded and the interpretations are collected in All_Interp.
929 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
930 -- the type-checking is similar to that of other calls.
932 procedure Analyze_Call
(N
: Node_Id
) is
933 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
934 Loc
: constant Source_Ptr
:= Sloc
(N
);
939 Success
: Boolean := False;
941 Deref
: Boolean := False;
942 -- Flag indicates whether an interpretation of the prefix is a
943 -- parameterless call that returns an access_to_subprogram.
945 procedure Check_Mixed_Parameter_And_Named_Associations
;
946 -- Check that parameter and named associations are not mixed. This is
947 -- a restriction in SPARK mode.
949 procedure Check_Writable_Actuals
(N
: Node_Id
);
950 -- If the call has out or in-out parameters then mark its outermost
951 -- enclosing construct as a node on which the writable actuals check
952 -- must be performed.
954 function Name_Denotes_Function
return Boolean;
955 -- If the type of the name is an access to subprogram, this may be the
956 -- type of a name, or the return type of the function being called. If
957 -- the name is not an entity then it can denote a protected function.
958 -- Until we distinguish Etype from Return_Type, we must use this routine
959 -- to resolve the meaning of the name in the call.
961 procedure No_Interpretation
;
962 -- Output error message when no valid interpretation exists
964 --------------------------------------------------
965 -- Check_Mixed_Parameter_And_Named_Associations --
966 --------------------------------------------------
968 procedure Check_Mixed_Parameter_And_Named_Associations
is
970 Named_Seen
: Boolean;
975 Actual
:= First
(Actuals
);
976 while Present
(Actual
) loop
977 case Nkind
(Actual
) is
978 when N_Parameter_Association
=>
980 Check_SPARK_05_Restriction
981 ("named association cannot follow positional one",
992 end Check_Mixed_Parameter_And_Named_Associations
;
994 ----------------------------
995 -- Check_Writable_Actuals --
996 ----------------------------
998 -- The identification of conflicts in calls to functions with writable
999 -- actuals is performed in the analysis phase of the front end to ensure
1000 -- that it reports exactly the same errors compiling with and without
1001 -- expansion enabled. It is performed in two stages:
1003 -- 1) When a call to a function with out-mode parameters is found,
1004 -- we climb to the outermost enclosing construct that can be
1005 -- evaluated in arbitrary order and we mark it with the flag
1008 -- 2) When the analysis of the marked node is complete, we traverse
1009 -- its decorated subtree searching for conflicts (see function
1010 -- Sem_Util.Check_Function_Writable_Actuals).
1012 -- The unique exception to this general rule is for aggregates, since
1013 -- their analysis is performed by the front end in the resolution
1014 -- phase. For aggregates we do not climb to their enclosing construct:
1015 -- we restrict the analysis to the subexpressions initializing the
1016 -- aggregate components.
1018 -- This implies that the analysis of expressions containing aggregates
1019 -- is not complete, since there may be conflicts on writable actuals
1020 -- involving subexpressions of the enclosing logical or arithmetic
1021 -- expressions. However, we cannot wait and perform the analysis when
1022 -- the whole subtree is resolved, since the subtrees may be transformed,
1023 -- thus adding extra complexity and computation cost to identify and
1024 -- report exactly the same errors compiling with and without expansion
1027 procedure Check_Writable_Actuals
(N
: Node_Id
) is
1029 if Comes_From_Source
(N
)
1030 and then Present
(Get_Subprogram_Entity
(N
))
1031 and then Has_Out_Or_In_Out_Parameter
(Get_Subprogram_Entity
(N
))
1033 -- For procedures and entries there is no need to climb since
1034 -- we only need to check if the actuals of this call invoke
1035 -- functions whose out-mode parameters overlap.
1037 if Nkind
(N
) /= N_Function_Call
then
1038 Set_Check_Actuals
(N
);
1040 -- For calls to functions we climb to the outermost enclosing
1041 -- construct where the out-mode actuals of this function may
1042 -- introduce conflicts.
1046 Outermost
: Node_Id
;
1050 while Present
(P
) loop
1052 -- For object declarations we can climb to the node from
1053 -- its object definition branch or from its initializing
1054 -- expression. We prefer to mark the child node as the
1055 -- outermost construct to avoid adding further complexity
1056 -- to the routine that will later take care of
1057 -- performing the writable actuals check.
1059 if Has_Arbitrary_Evaluation_Order
(Nkind
(P
))
1060 and then not Nkind_In
(P
, N_Assignment_Statement
,
1061 N_Object_Declaration
)
1066 -- Avoid climbing more than needed!
1068 exit when Stop_Subtree_Climbing
(Nkind
(P
))
1069 or else (Nkind
(P
) = N_Range
1071 Nkind_In
(Parent
(P
), N_In
, N_Not_In
));
1076 Set_Check_Actuals
(Outermost
);
1080 end Check_Writable_Actuals
;
1082 ---------------------------
1083 -- Name_Denotes_Function --
1084 ---------------------------
1086 function Name_Denotes_Function
return Boolean is
1088 if Is_Entity_Name
(Nam
) then
1089 return Ekind
(Entity
(Nam
)) = E_Function
;
1090 elsif Nkind
(Nam
) = N_Selected_Component
then
1091 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
1095 end Name_Denotes_Function
;
1097 -----------------------
1098 -- No_Interpretation --
1099 -----------------------
1101 procedure No_Interpretation
is
1102 L
: constant Boolean := Is_List_Member
(N
);
1103 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
1106 -- If the node is in a list whose parent is not an expression then it
1107 -- must be an attempted procedure call.
1109 if L
and then K
not in N_Subexpr
then
1110 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
1112 ("must instantiate generic procedure& before call",
1115 Error_Msg_N
("procedure or entry name expected", Nam
);
1118 -- Check for tasking cases where only an entry call will do
1121 and then Nkind_In
(K
, N_Entry_Call_Alternative
,
1122 N_Triggering_Alternative
)
1124 Error_Msg_N
("entry name expected", Nam
);
1126 -- Otherwise give general error message
1129 Error_Msg_N
("invalid prefix in call", Nam
);
1131 end No_Interpretation
;
1133 -- Start of processing for Analyze_Call
1136 if Restriction_Check_Required
(SPARK_05
) then
1137 Check_Mixed_Parameter_And_Named_Associations
;
1140 -- Initialize the type of the result of the call to the error type,
1141 -- which will be reset if the type is successfully resolved.
1143 Set_Etype
(N
, Any_Type
);
1147 if not Is_Overloaded
(Nam
) then
1149 -- Only one interpretation to check
1151 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
1152 Nam_Ent
:= Etype
(Nam
);
1154 -- If the prefix is an access_to_subprogram, this may be an indirect
1155 -- call. This is the case if the name in the call is not an entity
1156 -- name, or if it is a function name in the context of a procedure
1157 -- call. In this latter case, we have a call to a parameterless
1158 -- function that returns a pointer_to_procedure which is the entity
1159 -- being called. Finally, F (X) may be a call to a parameterless
1160 -- function that returns a pointer to a function with parameters.
1161 -- Note that if F returns an access-to-subprogram whose designated
1162 -- type is an array, F (X) cannot be interpreted as an indirect call
1163 -- through the result of the call to F.
1165 elsif Is_Access_Type
(Etype
(Nam
))
1166 and then Ekind
(Designated_Type
(Etype
(Nam
))) = E_Subprogram_Type
1168 (not Name_Denotes_Function
1169 or else Nkind
(N
) = N_Procedure_Call_Statement
1171 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1172 and then Is_Entity_Name
(Nam
)
1173 and then No
(First_Formal
(Entity
(Nam
)))
1175 Is_Array_Type
(Etype
(Designated_Type
(Etype
(Nam
))))
1176 and then Present
(Actuals
)))
1178 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
1179 Insert_Explicit_Dereference
(Nam
);
1181 -- Selected component case. Simple entry or protected operation,
1182 -- where the entry name is given by the selector name.
1184 elsif Nkind
(Nam
) = N_Selected_Component
then
1185 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
1187 if not Ekind_In
(Nam_Ent
, E_Entry
,
1192 Error_Msg_N
("name in call is not a callable entity", Nam
);
1193 Set_Etype
(N
, Any_Type
);
1197 -- If the name is an Indexed component, it can be a call to a member
1198 -- of an entry family. The prefix must be a selected component whose
1199 -- selector is the entry. Analyze_Procedure_Call normalizes several
1200 -- kinds of call into this form.
1202 elsif Nkind
(Nam
) = N_Indexed_Component
then
1203 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
1204 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
1206 Error_Msg_N
("name in call is not a callable entity", Nam
);
1207 Set_Etype
(N
, Any_Type
);
1211 elsif not Is_Entity_Name
(Nam
) then
1212 Error_Msg_N
("name in call is not a callable entity", Nam
);
1213 Set_Etype
(N
, Any_Type
);
1217 Nam_Ent
:= Entity
(Nam
);
1219 -- If not overloadable, this may be a generalized indexing
1220 -- operation with named associations. Rewrite again as an
1221 -- indexed component and analyze as container indexing.
1223 if not Is_Overloadable
(Nam_Ent
) then
1225 (Find_Value_Of_Aspect
1226 (Etype
(Nam_Ent
), Aspect_Constant_Indexing
))
1229 Make_Indexed_Component
(Sloc
(N
),
1231 Expressions
=> Parameter_Associations
(N
)));
1233 if Try_Container_Indexing
(N
, Nam
, Expressions
(N
)) then
1247 -- Operations generated for RACW stub types are called only through
1248 -- dispatching, and can never be the static interpretation of a call.
1250 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
1255 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
1257 -- If this is an indirect call, the return type of the access_to
1258 -- subprogram may be an incomplete type. At the point of the call,
1259 -- use the full type if available, and at the same time update the
1260 -- return type of the access_to_subprogram.
1263 and then Nkind
(Nam
) = N_Explicit_Dereference
1264 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
1265 and then Present
(Full_View
(Etype
(N
)))
1267 Set_Etype
(N
, Full_View
(Etype
(N
)));
1268 Set_Etype
(Nam_Ent
, Etype
(N
));
1274 -- An overloaded selected component must denote overloaded operations
1275 -- of a concurrent type. The interpretations are attached to the
1276 -- simple name of those operations.
1278 if Nkind
(Nam
) = N_Selected_Component
then
1279 Nam
:= Selector_Name
(Nam
);
1282 Get_First_Interp
(Nam
, X
, It
);
1283 while Present
(It
.Nam
) loop
1287 -- Name may be call that returns an access to subprogram, or more
1288 -- generally an overloaded expression one of whose interpretations
1289 -- yields an access to subprogram. If the name is an entity, we do
1290 -- not dereference, because the node is a call that returns the
1291 -- access type: note difference between f(x), where the call may
1292 -- return an access subprogram type, and f(x)(y), where the type
1293 -- returned by the call to f is implicitly dereferenced to analyze
1296 if Is_Access_Type
(Nam_Ent
) then
1297 Nam_Ent
:= Designated_Type
(Nam_Ent
);
1299 elsif Is_Access_Type
(Etype
(Nam_Ent
))
1301 (not Is_Entity_Name
(Nam
)
1302 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1303 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
1306 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
1308 if Is_Entity_Name
(Nam
) then
1313 -- If the call has been rewritten from a prefixed call, the first
1314 -- parameter has been analyzed, but may need a subsequent
1315 -- dereference, so skip its analysis now.
1317 if N
/= Original_Node
(N
)
1318 and then Nkind
(Original_Node
(N
)) = Nkind
(N
)
1319 and then Nkind
(Name
(N
)) /= Nkind
(Name
(Original_Node
(N
)))
1320 and then Present
(Parameter_Associations
(N
))
1321 and then Present
(Etype
(First
(Parameter_Associations
(N
))))
1324 (N
, Nam_Ent
, False, Success
, Skip_First
=> True);
1326 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
1329 -- If the interpretation succeeds, mark the proper type of the
1330 -- prefix (any valid candidate will do). If not, remove the
1331 -- candidate interpretation. If this is a parameterless call
1332 -- on an anonymous access to subprogram, X is a variable with
1333 -- an access discriminant D, the entity in the interpretation is
1334 -- D, so rewrite X as X.D.all.
1338 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1340 if Ekind
(It
.Nam
) = E_Discriminant
1341 and then Has_Implicit_Dereference
(It
.Nam
)
1344 Make_Explicit_Dereference
(Loc
,
1346 Make_Selected_Component
(Loc
,
1348 New_Occurrence_Of
(Entity
(Nam
), Loc
),
1350 New_Occurrence_Of
(It
.Nam
, Loc
))));
1356 Set_Entity
(Nam
, It
.Nam
);
1357 Insert_Explicit_Dereference
(Nam
);
1358 Set_Etype
(Nam
, Nam_Ent
);
1362 Set_Etype
(Nam
, It
.Typ
);
1365 elsif Nkind_In
(Name
(N
), N_Function_Call
, N_Selected_Component
)
1370 Get_Next_Interp
(X
, It
);
1373 -- If the name is the result of a function call, it can only be a
1374 -- call to a function returning an access to subprogram. Insert
1375 -- explicit dereference.
1377 if Nkind
(Nam
) = N_Function_Call
then
1378 Insert_Explicit_Dereference
(Nam
);
1381 if Etype
(N
) = Any_Type
then
1383 -- None of the interpretations is compatible with the actuals
1385 Diagnose_Call
(N
, Nam
);
1387 -- Special checks for uninstantiated put routines
1389 if Nkind
(N
) = N_Procedure_Call_Statement
1390 and then Is_Entity_Name
(Nam
)
1391 and then Chars
(Nam
) = Name_Put
1392 and then List_Length
(Actuals
) = 1
1395 Arg
: constant Node_Id
:= First
(Actuals
);
1399 if Nkind
(Arg
) = N_Parameter_Association
then
1400 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
1405 if Is_Signed_Integer_Type
(Typ
) then
1407 ("possible missing instantiation of "
1408 & "'Text_'I'O.'Integer_'I'O!", Nam
);
1410 elsif Is_Modular_Integer_Type
(Typ
) then
1412 ("possible missing instantiation of "
1413 & "'Text_'I'O.'Modular_'I'O!", Nam
);
1415 elsif Is_Floating_Point_Type
(Typ
) then
1417 ("possible missing instantiation of "
1418 & "'Text_'I'O.'Float_'I'O!", Nam
);
1420 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1422 ("possible missing instantiation of "
1423 & "'Text_'I'O.'Fixed_'I'O!", Nam
);
1425 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1427 ("possible missing instantiation of "
1428 & "'Text_'I'O.'Decimal_'I'O!", Nam
);
1430 elsif Is_Enumeration_Type
(Typ
) then
1432 ("possible missing instantiation of "
1433 & "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1438 elsif not Is_Overloaded
(N
)
1439 and then Is_Entity_Name
(Nam
)
1441 -- Resolution yields a single interpretation. Verify that the
1442 -- reference has capitalization consistent with the declaration.
1444 Set_Entity_With_Checks
(Nam
, Entity
(Nam
));
1445 Generate_Reference
(Entity
(Nam
), Nam
);
1447 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1449 Remove_Abstract_Operations
(N
);
1455 if Ada_Version
>= Ada_2012
then
1457 -- Check if the call contains a function with writable actuals
1459 Check_Writable_Actuals
(N
);
1461 -- If found and the outermost construct that can be evaluated in
1462 -- an arbitrary order is precisely this call, then check all its
1465 Check_Function_Writable_Actuals
(N
);
1467 -- The return type of the function may be incomplete. This can be
1468 -- the case if the type is a generic formal, or a limited view. It
1469 -- can also happen when the function declaration appears before the
1470 -- full view of the type (which is legal in Ada 2012) and the call
1471 -- appears in a different unit, in which case the incomplete view
1472 -- must be replaced with the full view (or the non-limited view)
1473 -- to prevent subsequent type errors. Note that the usual install/
1474 -- removal of limited_with clauses is not sufficient to handle this
1475 -- case, because the limited view may have been captured is another
1476 -- compilation unit that defines the current function.
1478 if Is_Incomplete_Type
(Etype
(N
)) then
1479 if Present
(Full_View
(Etype
(N
))) then
1480 if Is_Entity_Name
(Nam
) then
1481 Set_Etype
(Nam
, Full_View
(Etype
(N
)));
1482 Set_Etype
(Entity
(Nam
), Full_View
(Etype
(N
)));
1485 Set_Etype
(N
, Full_View
(Etype
(N
)));
1487 elsif From_Limited_With
(Etype
(N
))
1488 and then Present
(Non_Limited_View
(Etype
(N
)))
1490 Set_Etype
(N
, Non_Limited_View
(Etype
(N
)));
1496 -----------------------------
1497 -- Analyze_Case_Expression --
1498 -----------------------------
1500 procedure Analyze_Case_Expression
(N
: Node_Id
) is
1501 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
1502 -- Error routine invoked by the generic instantiation below when
1503 -- the case expression has a non static choice.
1505 package Case_Choices_Analysis
is new
1506 Generic_Analyze_Choices
1507 (Process_Associated_Node
=> No_OP
);
1508 use Case_Choices_Analysis
;
1510 package Case_Choices_Checking
is new
1511 Generic_Check_Choices
1512 (Process_Empty_Choice
=> No_OP
,
1513 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
1514 Process_Associated_Node
=> No_OP
);
1515 use Case_Choices_Checking
;
1517 -----------------------------
1518 -- Non_Static_Choice_Error --
1519 -----------------------------
1521 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
1523 Flag_Non_Static_Expr
1524 ("choice given in case expression is not static!", Choice
);
1525 end Non_Static_Choice_Error
;
1529 Expr
: constant Node_Id
:= Expression
(N
);
1531 Exp_Type
: Entity_Id
;
1532 Exp_Btype
: Entity_Id
;
1534 FirstX
: Node_Id
:= Empty
;
1535 -- First expression in the case for which there is some type information
1536 -- available, i.e. it is not Any_Type, which can happen because of some
1537 -- error, or from the use of e.g. raise Constraint_Error.
1539 Others_Present
: Boolean;
1540 -- Indicates if Others was present
1542 Wrong_Alt
: Node_Id
:= Empty
;
1543 -- For error reporting
1545 -- Start of processing for Analyze_Case_Expression
1548 if Comes_From_Source
(N
) then
1549 Check_Compiler_Unit
("case expression", N
);
1552 Analyze_And_Resolve
(Expr
, Any_Discrete
);
1553 Check_Unset_Reference
(Expr
);
1554 Exp_Type
:= Etype
(Expr
);
1555 Exp_Btype
:= Base_Type
(Exp_Type
);
1557 Alt
:= First
(Alternatives
(N
));
1558 while Present
(Alt
) loop
1559 if Error_Posted
(Expression
(Alt
)) then
1563 Analyze
(Expression
(Alt
));
1565 if No
(FirstX
) and then Etype
(Expression
(Alt
)) /= Any_Type
then
1566 FirstX
:= Expression
(Alt
);
1572 -- Get our initial type from the first expression for which we got some
1573 -- useful type information from the expression.
1579 if not Is_Overloaded
(FirstX
) then
1580 Set_Etype
(N
, Etype
(FirstX
));
1588 Set_Etype
(N
, Any_Type
);
1590 Get_First_Interp
(FirstX
, I
, It
);
1591 while Present
(It
.Nam
) loop
1593 -- For each interpretation of the first expression, we only
1594 -- add the interpretation if every other expression in the
1595 -- case expression alternatives has a compatible type.
1597 Alt
:= Next
(First
(Alternatives
(N
)));
1598 while Present
(Alt
) loop
1599 exit when not Has_Compatible_Type
(Expression
(Alt
), It
.Typ
);
1604 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1609 Get_Next_Interp
(I
, It
);
1614 Exp_Btype
:= Base_Type
(Exp_Type
);
1616 -- The expression must be of a discrete type which must be determinable
1617 -- independently of the context in which the expression occurs, but
1618 -- using the fact that the expression must be of a discrete type.
1619 -- Moreover, the type this expression must not be a character literal
1620 -- (which is always ambiguous).
1622 -- If error already reported by Resolve, nothing more to do
1624 if Exp_Btype
= Any_Discrete
or else Exp_Btype
= Any_Type
then
1627 -- Special casee message for character literal
1629 elsif Exp_Btype
= Any_Character
then
1631 ("character literal as case expression is ambiguous", Expr
);
1635 if Etype
(N
) = Any_Type
and then Present
(Wrong_Alt
) then
1637 ("type incompatible with that of previous alternatives",
1638 Expression
(Wrong_Alt
));
1642 -- If the case expression is a formal object of mode in out, then
1643 -- treat it as having a nonstatic subtype by forcing use of the base
1644 -- type (which has to get passed to Check_Case_Choices below). Also
1645 -- use base type when the case expression is parenthesized.
1647 if Paren_Count
(Expr
) > 0
1648 or else (Is_Entity_Name
(Expr
)
1649 and then Ekind
(Entity
(Expr
)) = E_Generic_In_Out_Parameter
)
1651 Exp_Type
:= Exp_Btype
;
1654 -- The case expression alternatives cover the range of a static subtype
1655 -- subject to aspect Static_Predicate. Do not check the choices when the
1656 -- case expression has not been fully analyzed yet because this may lead
1659 if Is_OK_Static_Subtype
(Exp_Type
)
1660 and then Has_Static_Predicate_Aspect
(Exp_Type
)
1661 and then In_Spec_Expression
1665 -- Call Analyze_Choices and Check_Choices to do the rest of the work
1668 Analyze_Choices
(Alternatives
(N
), Exp_Type
);
1669 Check_Choices
(N
, Alternatives
(N
), Exp_Type
, Others_Present
);
1672 if Exp_Type
= Universal_Integer
and then not Others_Present
then
1674 ("case on universal integer requires OTHERS choice", Expr
);
1676 end Analyze_Case_Expression
;
1678 ---------------------------
1679 -- Analyze_Comparison_Op --
1680 ---------------------------
1682 procedure Analyze_Comparison_Op
(N
: Node_Id
) is
1683 L
: constant Node_Id
:= Left_Opnd
(N
);
1684 R
: constant Node_Id
:= Right_Opnd
(N
);
1685 Op_Id
: Entity_Id
:= Entity
(N
);
1688 Set_Etype
(N
, Any_Type
);
1689 Candidate_Type
:= Empty
;
1691 Analyze_Expression
(L
);
1692 Analyze_Expression
(R
);
1694 if Present
(Op_Id
) then
1695 if Ekind
(Op_Id
) = E_Operator
then
1696 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1698 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1701 if Is_Overloaded
(L
) then
1702 Set_Etype
(L
, Intersect_Types
(L
, R
));
1706 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1707 while Present
(Op_Id
) loop
1708 if Ekind
(Op_Id
) = E_Operator
then
1709 Find_Comparison_Types
(L
, R
, Op_Id
, N
);
1711 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1714 Op_Id
:= Homonym
(Op_Id
);
1719 Check_Function_Writable_Actuals
(N
);
1720 end Analyze_Comparison_Op
;
1722 ---------------------------
1723 -- Analyze_Concatenation --
1724 ---------------------------
1726 procedure Analyze_Concatenation
(N
: Node_Id
) is
1728 -- We wish to avoid deep recursion, because concatenations are often
1729 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1730 -- operands nonrecursively until we find something that is not a
1731 -- concatenation (A in this case), or has already been analyzed. We
1732 -- analyze that, and then walk back up the tree following Parent
1733 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1734 -- work at each level. The Parent pointers allow us to avoid recursion,
1735 -- and thus avoid running out of memory.
1741 Candidate_Type
:= Empty
;
1743 -- The following code is equivalent to:
1745 -- Set_Etype (N, Any_Type);
1746 -- Analyze_Expression (Left_Opnd (N));
1747 -- Analyze_Concatenation_Rest (N);
1749 -- where the Analyze_Expression call recurses back here if the left
1750 -- operand is a concatenation.
1752 -- Walk down left operands
1755 Set_Etype
(NN
, Any_Type
);
1756 L
:= Left_Opnd
(NN
);
1757 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1761 -- Now (given the above example) NN is A&B and L is A
1763 -- First analyze L ...
1765 Analyze_Expression
(L
);
1767 -- ... then walk NN back up until we reach N (where we started), calling
1768 -- Analyze_Concatenation_Rest along the way.
1771 Analyze_Concatenation_Rest
(NN
);
1775 end Analyze_Concatenation
;
1777 --------------------------------
1778 -- Analyze_Concatenation_Rest --
1779 --------------------------------
1781 -- If the only one-dimensional array type in scope is String,
1782 -- this is the resulting type of the operation. Otherwise there
1783 -- will be a concatenation operation defined for each user-defined
1784 -- one-dimensional array.
1786 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1787 L
: constant Node_Id
:= Left_Opnd
(N
);
1788 R
: constant Node_Id
:= Right_Opnd
(N
);
1789 Op_Id
: Entity_Id
:= Entity
(N
);
1794 Analyze_Expression
(R
);
1796 -- If the entity is present, the node appears in an instance, and
1797 -- denotes a predefined concatenation operation. The resulting type is
1798 -- obtained from the arguments when possible. If the arguments are
1799 -- aggregates, the array type and the concatenation type must be
1802 if Present
(Op_Id
) then
1803 if Ekind
(Op_Id
) = E_Operator
then
1804 LT
:= Base_Type
(Etype
(L
));
1805 RT
:= Base_Type
(Etype
(R
));
1807 if Is_Array_Type
(LT
)
1808 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1810 Add_One_Interp
(N
, Op_Id
, LT
);
1812 elsif Is_Array_Type
(RT
)
1813 and then LT
= Base_Type
(Component_Type
(RT
))
1815 Add_One_Interp
(N
, Op_Id
, RT
);
1817 -- If one operand is a string type or a user-defined array type,
1818 -- and the other is a literal, result is of the specific type.
1821 (Root_Type
(LT
) = Standard_String
1822 or else Scope
(LT
) /= Standard_Standard
)
1823 and then Etype
(R
) = Any_String
1825 Add_One_Interp
(N
, Op_Id
, LT
);
1828 (Root_Type
(RT
) = Standard_String
1829 or else Scope
(RT
) /= Standard_Standard
)
1830 and then Etype
(L
) = Any_String
1832 Add_One_Interp
(N
, Op_Id
, RT
);
1834 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
1835 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1838 -- Type and its operations must be visible
1840 Set_Entity
(N
, Empty
);
1841 Analyze_Concatenation
(N
);
1845 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1849 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
1850 while Present
(Op_Id
) loop
1851 if Ekind
(Op_Id
) = E_Operator
then
1853 -- Do not consider operators declared in dead code, they can
1854 -- not be part of the resolution.
1856 if Is_Eliminated
(Op_Id
) then
1859 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
1863 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1866 Op_Id
:= Homonym
(Op_Id
);
1871 end Analyze_Concatenation_Rest
;
1873 -------------------------
1874 -- Analyze_Equality_Op --
1875 -------------------------
1877 procedure Analyze_Equality_Op
(N
: Node_Id
) is
1878 Loc
: constant Source_Ptr
:= Sloc
(N
);
1879 L
: constant Node_Id
:= Left_Opnd
(N
);
1880 R
: constant Node_Id
:= Right_Opnd
(N
);
1884 Set_Etype
(N
, Any_Type
);
1885 Candidate_Type
:= Empty
;
1887 Analyze_Expression
(L
);
1888 Analyze_Expression
(R
);
1890 -- If the entity is set, the node is a generic instance with a non-local
1891 -- reference to the predefined operator or to a user-defined function.
1892 -- It can also be an inequality that is expanded into the negation of a
1893 -- call to a user-defined equality operator.
1895 -- For the predefined case, the result is Boolean, regardless of the
1896 -- type of the operands. The operands may even be limited, if they are
1897 -- generic actuals. If they are overloaded, label the left argument with
1898 -- the common type that must be present, or with the type of the formal
1899 -- of the user-defined function.
1901 if Present
(Entity
(N
)) then
1902 Op_Id
:= Entity
(N
);
1904 if Ekind
(Op_Id
) = E_Operator
then
1905 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
1907 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
1910 if Is_Overloaded
(L
) then
1911 if Ekind
(Op_Id
) = E_Operator
then
1912 Set_Etype
(L
, Intersect_Types
(L
, R
));
1914 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
1919 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
1920 while Present
(Op_Id
) loop
1921 if Ekind
(Op_Id
) = E_Operator
then
1922 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1924 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1927 Op_Id
:= Homonym
(Op_Id
);
1931 -- If there was no match, and the operator is inequality, this may be
1932 -- a case where inequality has not been made explicit, as for tagged
1933 -- types. Analyze the node as the negation of an equality operation.
1934 -- This cannot be done earlier, because before analysis we cannot rule
1935 -- out the presence of an explicit inequality.
1937 if Etype
(N
) = Any_Type
1938 and then Nkind
(N
) = N_Op_Ne
1940 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
1941 while Present
(Op_Id
) loop
1942 if Ekind
(Op_Id
) = E_Operator
then
1943 Find_Equality_Types
(L
, R
, Op_Id
, N
);
1945 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
1948 Op_Id
:= Homonym
(Op_Id
);
1951 if Etype
(N
) /= Any_Type
then
1952 Op_Id
:= Entity
(N
);
1958 Left_Opnd
=> Left_Opnd
(N
),
1959 Right_Opnd
=> Right_Opnd
(N
))));
1961 Set_Entity
(Right_Opnd
(N
), Op_Id
);
1967 Check_Function_Writable_Actuals
(N
);
1968 end Analyze_Equality_Op
;
1970 ----------------------------------
1971 -- Analyze_Explicit_Dereference --
1972 ----------------------------------
1974 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
1975 Loc
: constant Source_Ptr
:= Sloc
(N
);
1976 P
: constant Node_Id
:= Prefix
(N
);
1982 function Is_Function_Type
return Boolean;
1983 -- Check whether node may be interpreted as an implicit function call
1985 ----------------------
1986 -- Is_Function_Type --
1987 ----------------------
1989 function Is_Function_Type
return Boolean is
1994 if not Is_Overloaded
(N
) then
1995 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
1996 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
1999 Get_First_Interp
(N
, I
, It
);
2000 while Present
(It
.Nam
) loop
2001 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
2002 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
2007 Get_Next_Interp
(I
, It
);
2012 end Is_Function_Type
;
2014 -- Start of processing for Analyze_Explicit_Dereference
2017 -- If source node, check SPARK restriction. We guard this with the
2018 -- source node check, because ???
2020 if Comes_From_Source
(N
) then
2021 Check_SPARK_05_Restriction
("explicit dereference is not allowed", N
);
2024 -- In formal verification mode, keep track of all reads and writes
2025 -- through explicit dereferences.
2027 if GNATprove_Mode
then
2028 SPARK_Specific
.Generate_Dereference
(N
);
2032 Set_Etype
(N
, Any_Type
);
2034 -- Test for remote access to subprogram type, and if so return
2035 -- after rewriting the original tree.
2037 if Remote_AST_E_Dereference
(P
) then
2041 -- Normal processing for other than remote access to subprogram type
2043 if not Is_Overloaded
(P
) then
2044 if Is_Access_Type
(Etype
(P
)) then
2046 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
2047 -- avoid other problems caused by the Private_Subtype and it is
2048 -- safe to go to the Base_Type because this is the same as
2049 -- converting the access value to its Base_Type.
2052 DT
: Entity_Id
:= Designated_Type
(Etype
(P
));
2055 if Ekind
(DT
) = E_Private_Subtype
2056 and then Is_For_Access_Subtype
(DT
)
2058 DT
:= Base_Type
(DT
);
2061 -- An explicit dereference is a legal occurrence of an
2062 -- incomplete type imported through a limited_with clause, if
2063 -- the full view is visible, or if we are within an instance
2064 -- body, where the enclosing body has a regular with_clause
2067 if From_Limited_With
(DT
)
2068 and then not From_Limited_With
(Scope
(DT
))
2070 (Is_Immediately_Visible
(Scope
(DT
))
2072 (Is_Child_Unit
(Scope
(DT
))
2073 and then Is_Visible_Lib_Unit
(Scope
(DT
)))
2074 or else In_Instance_Body
)
2076 Set_Etype
(N
, Available_View
(DT
));
2083 elsif Etype
(P
) /= Any_Type
then
2084 Error_Msg_N
("prefix of dereference must be an access type", N
);
2089 Get_First_Interp
(P
, I
, It
);
2090 while Present
(It
.Nam
) loop
2093 if Is_Access_Type
(T
) then
2094 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
2097 Get_Next_Interp
(I
, It
);
2100 -- Error if no interpretation of the prefix has an access type
2102 if Etype
(N
) = Any_Type
then
2104 ("access type required in prefix of explicit dereference", P
);
2105 Set_Etype
(N
, Any_Type
);
2111 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
2113 and then (Nkind
(Parent
(N
)) /= N_Function_Call
2114 or else N
/= Name
(Parent
(N
)))
2116 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2117 or else N
/= Name
(Parent
(N
)))
2119 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
2120 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
2122 (Attribute_Name
(Parent
(N
)) /= Name_Address
2124 Attribute_Name
(Parent
(N
)) /= Name_Access
))
2126 -- Name is a function call with no actuals, in a context that
2127 -- requires deproceduring (including as an actual in an enclosing
2128 -- function or procedure call). There are some pathological cases
2129 -- where the prefix might include functions that return access to
2130 -- subprograms and others that return a regular type. Disambiguation
2131 -- of those has to take place in Resolve.
2134 Make_Function_Call
(Loc
,
2135 Name
=> Make_Explicit_Dereference
(Loc
, P
),
2136 Parameter_Associations
=> New_List
);
2138 -- If the prefix is overloaded, remove operations that have formals,
2139 -- we know that this is a parameterless call.
2141 if Is_Overloaded
(P
) then
2142 Get_First_Interp
(P
, I
, It
);
2143 while Present
(It
.Nam
) loop
2146 if No
(First_Formal
(Base_Type
(Designated_Type
(T
)))) then
2152 Get_Next_Interp
(I
, It
);
2159 elsif not Is_Function_Type
2160 and then Is_Overloaded
(N
)
2162 -- The prefix may include access to subprograms and other access
2163 -- types. If the context selects the interpretation that is a
2164 -- function call (not a procedure call) we cannot rewrite the node
2165 -- yet, but we include the result of the call interpretation.
2167 Get_First_Interp
(N
, I
, It
);
2168 while Present
(It
.Nam
) loop
2169 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
2170 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
2171 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2173 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
2176 Get_Next_Interp
(I
, It
);
2180 -- A value of remote access-to-class-wide must not be dereferenced
2183 Validate_Remote_Access_To_Class_Wide_Type
(N
);
2184 end Analyze_Explicit_Dereference
;
2186 ------------------------
2187 -- Analyze_Expression --
2188 ------------------------
2190 procedure Analyze_Expression
(N
: Node_Id
) is
2193 -- If the expression is an indexed component that will be rewritten
2194 -- as a container indexing, it has already been analyzed.
2196 if Nkind
(N
) = N_Indexed_Component
2197 and then Present
(Generalized_Indexing
(N
))
2203 Check_Parameterless_Call
(N
);
2205 end Analyze_Expression
;
2207 -------------------------------------
2208 -- Analyze_Expression_With_Actions --
2209 -------------------------------------
2211 procedure Analyze_Expression_With_Actions
(N
: Node_Id
) is
2215 A
:= First
(Actions
(N
));
2216 while Present
(A
) loop
2221 Analyze_Expression
(Expression
(N
));
2222 Set_Etype
(N
, Etype
(Expression
(N
)));
2223 end Analyze_Expression_With_Actions
;
2225 ---------------------------
2226 -- Analyze_If_Expression --
2227 ---------------------------
2229 procedure Analyze_If_Expression
(N
: Node_Id
) is
2230 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2231 Then_Expr
: Node_Id
;
2232 Else_Expr
: Node_Id
;
2235 -- Defend against error of missing expressions from previous error
2237 if No
(Condition
) then
2238 Check_Error_Detected
;
2242 Then_Expr
:= Next
(Condition
);
2244 if No
(Then_Expr
) then
2245 Check_Error_Detected
;
2249 Else_Expr
:= Next
(Then_Expr
);
2251 if Comes_From_Source
(N
) then
2252 Check_SPARK_05_Restriction
("if expression is not allowed", N
);
2255 if Comes_From_Source
(N
) then
2256 Check_Compiler_Unit
("if expression", N
);
2259 -- Analyze and resolve the condition. We need to resolve this now so
2260 -- that it gets folded to True/False if possible, before we analyze
2261 -- the THEN/ELSE branches, because when analyzing these branches, we
2262 -- may call Is_Statically_Unevaluated, which expects the condition of
2263 -- an enclosing IF to have been analyze/resolved/evaluated.
2265 Analyze_Expression
(Condition
);
2266 Resolve
(Condition
, Any_Boolean
);
2268 -- Analyze THEN expression and (if present) ELSE expression. For those
2269 -- we delay resolution in the normal manner, because of overloading etc.
2271 Analyze_Expression
(Then_Expr
);
2273 if Present
(Else_Expr
) then
2274 Analyze_Expression
(Else_Expr
);
2277 -- If then expression not overloaded, then that decides the type
2279 if not Is_Overloaded
(Then_Expr
) then
2280 Set_Etype
(N
, Etype
(Then_Expr
));
2282 -- Case where then expression is overloaded
2290 Set_Etype
(N
, Any_Type
);
2292 -- Loop through interpretations of Then_Expr
2294 Get_First_Interp
(Then_Expr
, I
, It
);
2295 while Present
(It
.Nam
) loop
2297 -- Add possible interpretation of Then_Expr if no Else_Expr, or
2298 -- Else_Expr is present and has a compatible type.
2301 or else Has_Compatible_Type
(Else_Expr
, It
.Typ
)
2303 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
2306 Get_Next_Interp
(I
, It
);
2309 -- If no valid interpretation has been found, then the type of the
2310 -- ELSE expression does not match any interpretation of the THEN
2313 if Etype
(N
) = Any_Type
then
2315 ("type incompatible with that of `THEN` expression",
2321 end Analyze_If_Expression
;
2323 ------------------------------------
2324 -- Analyze_Indexed_Component_Form --
2325 ------------------------------------
2327 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
2328 P
: constant Node_Id
:= Prefix
(N
);
2329 Exprs
: constant List_Id
:= Expressions
(N
);
2335 procedure Process_Function_Call
;
2336 -- Prefix in indexed component form is an overloadable entity, so the
2337 -- node is a function call. Reformat it as such.
2339 procedure Process_Indexed_Component
;
2340 -- Prefix in indexed component form is actually an indexed component.
2341 -- This routine processes it, knowing that the prefix is already
2344 procedure Process_Indexed_Component_Or_Slice
;
2345 -- An indexed component with a single index may designate a slice if
2346 -- the index is a subtype mark. This routine disambiguates these two
2347 -- cases by resolving the prefix to see if it is a subtype mark.
2349 procedure Process_Overloaded_Indexed_Component
;
2350 -- If the prefix of an indexed component is overloaded, the proper
2351 -- interpretation is selected by the index types and the context.
2353 ---------------------------
2354 -- Process_Function_Call --
2355 ---------------------------
2357 procedure Process_Function_Call
is
2358 Loc
: constant Source_Ptr
:= Sloc
(N
);
2362 Change_Node
(N
, N_Function_Call
);
2364 Set_Parameter_Associations
(N
, Exprs
);
2366 -- Analyze actuals prior to analyzing the call itself
2368 Actual
:= First
(Parameter_Associations
(N
));
2369 while Present
(Actual
) loop
2371 Check_Parameterless_Call
(Actual
);
2373 -- Move to next actual. Note that we use Next, not Next_Actual
2374 -- here. The reason for this is a bit subtle. If a function call
2375 -- includes named associations, the parser recognizes the node
2376 -- as a call, and it is analyzed as such. If all associations are
2377 -- positional, the parser builds an indexed_component node, and
2378 -- it is only after analysis of the prefix that the construct
2379 -- is recognized as a call, in which case Process_Function_Call
2380 -- rewrites the node and analyzes the actuals. If the list of
2381 -- actuals is malformed, the parser may leave the node as an
2382 -- indexed component (despite the presence of named associations).
2383 -- The iterator Next_Actual is equivalent to Next if the list is
2384 -- positional, but follows the normalized chain of actuals when
2385 -- named associations are present. In this case normalization has
2386 -- not taken place, and actuals remain unanalyzed, which leads to
2387 -- subsequent crashes or loops if there is an attempt to continue
2388 -- analysis of the program.
2390 -- IF there is a single actual and it is a type name, the node
2391 -- can only be interpreted as a slice of a parameterless call.
2392 -- Rebuild the node as such and analyze.
2394 if No
(Next
(Actual
))
2395 and then Is_Entity_Name
(Actual
)
2396 and then Is_Type
(Entity
(Actual
))
2397 and then Is_Discrete_Type
(Entity
(Actual
))
2403 New_Occurrence_Of
(Entity
(Actual
), Loc
)));
2413 end Process_Function_Call
;
2415 -------------------------------
2416 -- Process_Indexed_Component --
2417 -------------------------------
2419 procedure Process_Indexed_Component
is
2421 Array_Type
: Entity_Id
;
2423 Pent
: Entity_Id
:= Empty
;
2426 Exp
:= First
(Exprs
);
2428 if Is_Overloaded
(P
) then
2429 Process_Overloaded_Indexed_Component
;
2432 Array_Type
:= Etype
(P
);
2434 if Is_Entity_Name
(P
) then
2436 elsif Nkind
(P
) = N_Selected_Component
2437 and then Is_Entity_Name
(Selector_Name
(P
))
2439 Pent
:= Entity
(Selector_Name
(P
));
2442 -- Prefix must be appropriate for an array type, taking into
2443 -- account a possible implicit dereference.
2445 if Is_Access_Type
(Array_Type
) then
2447 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2448 Array_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, P
);
2451 if Is_Array_Type
(Array_Type
) then
2453 -- In order to correctly access First_Index component later,
2454 -- replace string literal subtype by its parent type.
2456 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
2457 Array_Type
:= Etype
(Array_Type
);
2460 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
2462 Set_Etype
(N
, Any_Type
);
2464 if not Has_Compatible_Type
(Exp
, Entry_Index_Type
(Pent
)) then
2465 Error_Msg_N
("invalid index type in entry name", N
);
2467 elsif Present
(Next
(Exp
)) then
2468 Error_Msg_N
("too many subscripts in entry reference", N
);
2471 Set_Etype
(N
, Etype
(P
));
2476 elsif Is_Record_Type
(Array_Type
)
2477 and then Remote_AST_I_Dereference
(P
)
2481 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2484 elsif Array_Type
= Any_Type
then
2485 Set_Etype
(N
, Any_Type
);
2487 -- In most cases the analysis of the prefix will have emitted
2488 -- an error already, but if the prefix may be interpreted as a
2489 -- call in prefixed notation, the report is left to the caller.
2490 -- To prevent cascaded errors, report only if no previous ones.
2492 if Serious_Errors_Detected
= 0 then
2493 Error_Msg_N
("invalid prefix in indexed component", P
);
2495 if Nkind
(P
) = N_Expanded_Name
then
2496 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
2502 -- Here we definitely have a bad indexing
2505 if Nkind
(Parent
(N
)) = N_Requeue_Statement
2506 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
2509 ("REQUEUE does not permit parameters", First
(Exprs
));
2511 elsif Is_Entity_Name
(P
)
2512 and then Etype
(P
) = Standard_Void_Type
2514 Error_Msg_NE
("incorrect use of &", P
, Entity
(P
));
2517 Error_Msg_N
("array type required in indexed component", P
);
2520 Set_Etype
(N
, Any_Type
);
2524 Index
:= First_Index
(Array_Type
);
2525 while Present
(Index
) and then Present
(Exp
) loop
2526 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2527 Wrong_Type
(Exp
, Etype
(Index
));
2528 Set_Etype
(N
, Any_Type
);
2536 Set_Etype
(N
, Component_Type
(Array_Type
));
2537 Check_Implicit_Dereference
(N
, Etype
(N
));
2539 if Present
(Index
) then
2541 ("too few subscripts in array reference", First
(Exprs
));
2543 elsif Present
(Exp
) then
2544 Error_Msg_N
("too many subscripts in array reference", Exp
);
2547 end Process_Indexed_Component
;
2549 ----------------------------------------
2550 -- Process_Indexed_Component_Or_Slice --
2551 ----------------------------------------
2553 procedure Process_Indexed_Component_Or_Slice
is
2555 Exp
:= First
(Exprs
);
2556 while Present
(Exp
) loop
2557 Analyze_Expression
(Exp
);
2561 Exp
:= First
(Exprs
);
2563 -- If one index is present, and it is a subtype name, then the node
2564 -- denotes a slice (note that the case of an explicit range for a
2565 -- slice was already built as an N_Slice node in the first place,
2566 -- so that case is not handled here).
2568 -- We use a replace rather than a rewrite here because this is one
2569 -- of the cases in which the tree built by the parser is plain wrong.
2572 and then Is_Entity_Name
(Exp
)
2573 and then Is_Type
(Entity
(Exp
))
2576 Make_Slice
(Sloc
(N
),
2578 Discrete_Range
=> New_Copy
(Exp
)));
2581 -- Otherwise (more than one index present, or single index is not
2582 -- a subtype name), then we have the indexed component case.
2585 Process_Indexed_Component
;
2587 end Process_Indexed_Component_Or_Slice
;
2589 ------------------------------------------
2590 -- Process_Overloaded_Indexed_Component --
2591 ------------------------------------------
2593 procedure Process_Overloaded_Indexed_Component
is
2602 Set_Etype
(N
, Any_Type
);
2604 Get_First_Interp
(P
, I
, It
);
2605 while Present
(It
.Nam
) loop
2608 if Is_Access_Type
(Typ
) then
2609 Typ
:= Designated_Type
(Typ
);
2611 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2614 if Is_Array_Type
(Typ
) then
2616 -- Got a candidate: verify that index types are compatible
2618 Index
:= First_Index
(Typ
);
2620 Exp
:= First
(Exprs
);
2621 while Present
(Index
) and then Present
(Exp
) loop
2622 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2634 if Found
and then No
(Index
) and then No
(Exp
) then
2636 CT
: constant Entity_Id
:=
2637 Base_Type
(Component_Type
(Typ
));
2639 Add_One_Interp
(N
, CT
, CT
);
2640 Check_Implicit_Dereference
(N
, CT
);
2644 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2649 Get_Next_Interp
(I
, It
);
2652 if Etype
(N
) = Any_Type
then
2653 Error_Msg_N
("no legal interpretation for indexed component", N
);
2654 Set_Is_Overloaded
(N
, False);
2658 end Process_Overloaded_Indexed_Component
;
2660 -- Start of processing for Analyze_Indexed_Component_Form
2663 -- Get name of array, function or type
2667 -- If P is an explicit dereference whose prefix is of a remote access-
2668 -- to-subprogram type, then N has already been rewritten as a subprogram
2669 -- call and analyzed.
2671 if Nkind
(N
) in N_Subprogram_Call
then
2674 -- When the prefix is attribute 'Loop_Entry and the sole expression of
2675 -- the indexed component denotes a loop name, the indexed form is turned
2676 -- into an attribute reference.
2678 elsif Nkind
(N
) = N_Attribute_Reference
2679 and then Attribute_Name
(N
) = Name_Loop_Entry
2684 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
2686 P_T
:= Base_Type
(Etype
(P
));
2688 if Is_Entity_Name
(P
) and then Present
(Entity
(P
)) then
2691 if Is_Type
(U_N
) then
2693 -- Reformat node as a type conversion
2695 E
:= Remove_Head
(Exprs
);
2697 if Present
(First
(Exprs
)) then
2699 ("argument of type conversion must be single expression", N
);
2702 Change_Node
(N
, N_Type_Conversion
);
2703 Set_Subtype_Mark
(N
, P
);
2705 Set_Expression
(N
, E
);
2707 -- After changing the node, call for the specific Analysis
2708 -- routine directly, to avoid a double call to the expander.
2710 Analyze_Type_Conversion
(N
);
2714 if Is_Overloadable
(U_N
) then
2715 Process_Function_Call
;
2717 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
2718 or else (Is_Access_Type
(Etype
(P
))
2720 Ekind
(Designated_Type
(Etype
(P
))) =
2723 -- Call to access_to-subprogram with possible implicit dereference
2725 Process_Function_Call
;
2727 elsif Is_Generic_Subprogram
(U_N
) then
2729 -- A common beginner's (or C++ templates fan) error
2731 Error_Msg_N
("generic subprogram cannot be called", N
);
2732 Set_Etype
(N
, Any_Type
);
2736 Process_Indexed_Component_Or_Slice
;
2739 -- If not an entity name, prefix is an expression that may denote
2740 -- an array or an access-to-subprogram.
2743 if Ekind
(P_T
) = E_Subprogram_Type
2744 or else (Is_Access_Type
(P_T
)
2746 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
2748 Process_Function_Call
;
2750 elsif Nkind
(P
) = N_Selected_Component
2751 and then Present
(Entity
(Selector_Name
(P
)))
2752 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
2754 Process_Function_Call
;
2756 -- In ASIS mode within a generic, a prefixed call is analyzed and
2757 -- partially rewritten but the original indexed component has not
2758 -- yet been rewritten as a call. Perform the replacement now.
2760 elsif Nkind
(P
) = N_Selected_Component
2761 and then Nkind
(Parent
(P
)) = N_Function_Call
2764 Rewrite
(N
, Parent
(P
));
2768 -- Indexed component, slice, or a call to a member of a family
2769 -- entry, which will be converted to an entry call later.
2771 Process_Indexed_Component_Or_Slice
;
2775 Analyze_Dimension
(N
);
2776 end Analyze_Indexed_Component_Form
;
2778 ------------------------
2779 -- Analyze_Logical_Op --
2780 ------------------------
2782 procedure Analyze_Logical_Op
(N
: Node_Id
) is
2783 L
: constant Node_Id
:= Left_Opnd
(N
);
2784 R
: constant Node_Id
:= Right_Opnd
(N
);
2785 Op_Id
: Entity_Id
:= Entity
(N
);
2788 Set_Etype
(N
, Any_Type
);
2789 Candidate_Type
:= Empty
;
2791 Analyze_Expression
(L
);
2792 Analyze_Expression
(R
);
2794 if Present
(Op_Id
) then
2796 if Ekind
(Op_Id
) = E_Operator
then
2797 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2799 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2803 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2804 while Present
(Op_Id
) loop
2805 if Ekind
(Op_Id
) = E_Operator
then
2806 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
2808 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2811 Op_Id
:= Homonym
(Op_Id
);
2816 Check_Function_Writable_Actuals
(N
);
2817 end Analyze_Logical_Op
;
2819 ---------------------------
2820 -- Analyze_Membership_Op --
2821 ---------------------------
2823 procedure Analyze_Membership_Op
(N
: Node_Id
) is
2824 Loc
: constant Source_Ptr
:= Sloc
(N
);
2825 L
: constant Node_Id
:= Left_Opnd
(N
);
2826 R
: constant Node_Id
:= Right_Opnd
(N
);
2828 Index
: Interp_Index
;
2830 Found
: Boolean := False;
2834 procedure Try_One_Interp
(T1
: Entity_Id
);
2835 -- Routine to try one proposed interpretation. Note that the context
2836 -- of the operation plays no role in resolving the arguments, so that
2837 -- if there is more than one interpretation of the operands that is
2838 -- compatible with a membership test, the operation is ambiguous.
2840 --------------------
2841 -- Try_One_Interp --
2842 --------------------
2844 procedure Try_One_Interp
(T1
: Entity_Id
) is
2846 if Has_Compatible_Type
(R
, T1
) then
2848 and then Base_Type
(T1
) /= Base_Type
(T_F
)
2850 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
2852 if It
= No_Interp
then
2853 Ambiguous_Operands
(N
);
2854 Set_Etype
(L
, Any_Type
);
2871 procedure Analyze_Set_Membership
;
2872 -- If a set of alternatives is present, analyze each and find the
2873 -- common type to which they must all resolve.
2875 ----------------------------
2876 -- Analyze_Set_Membership --
2877 ----------------------------
2879 procedure Analyze_Set_Membership
is
2881 Index
: Interp_Index
;
2883 Candidate_Interps
: Node_Id
;
2884 Common_Type
: Entity_Id
:= Empty
;
2887 if Comes_From_Source
(N
) then
2888 Check_Compiler_Unit
("set membership", N
);
2892 Candidate_Interps
:= L
;
2894 if not Is_Overloaded
(L
) then
2895 Common_Type
:= Etype
(L
);
2897 Alt
:= First
(Alternatives
(N
));
2898 while Present
(Alt
) loop
2901 if not Has_Compatible_Type
(Alt
, Common_Type
) then
2902 Wrong_Type
(Alt
, Common_Type
);
2909 Alt
:= First
(Alternatives
(N
));
2910 while Present
(Alt
) loop
2912 if not Is_Overloaded
(Alt
) then
2913 Common_Type
:= Etype
(Alt
);
2916 Get_First_Interp
(Alt
, Index
, It
);
2917 while Present
(It
.Typ
) loop
2919 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
2921 Remove_Interp
(Index
);
2924 Get_Next_Interp
(Index
, It
);
2927 Get_First_Interp
(Alt
, Index
, It
);
2930 Error_Msg_N
("alternative has no legal type", Alt
);
2934 -- If alternative is not overloaded, we have a unique type
2937 Set_Etype
(Alt
, It
.Typ
);
2938 Get_Next_Interp
(Index
, It
);
2941 Set_Is_Overloaded
(Alt
, False);
2942 Common_Type
:= Etype
(Alt
);
2945 Candidate_Interps
:= Alt
;
2952 Set_Etype
(N
, Standard_Boolean
);
2954 if Present
(Common_Type
) then
2955 Set_Etype
(L
, Common_Type
);
2957 -- The left operand may still be overloaded, to be resolved using
2961 Error_Msg_N
("cannot resolve membership operation", N
);
2963 end Analyze_Set_Membership
;
2965 -- Start of processing for Analyze_Membership_Op
2968 Analyze_Expression
(L
);
2970 if No
(R
) and then Ada_Version
>= Ada_2012
then
2971 Analyze_Set_Membership
;
2972 Check_Function_Writable_Actuals
(N
);
2977 if Nkind
(R
) = N_Range
2978 or else (Nkind
(R
) = N_Attribute_Reference
2979 and then Attribute_Name
(R
) = Name_Range
)
2983 if not Is_Overloaded
(L
) then
2984 Try_One_Interp
(Etype
(L
));
2987 Get_First_Interp
(L
, Index
, It
);
2988 while Present
(It
.Typ
) loop
2989 Try_One_Interp
(It
.Typ
);
2990 Get_Next_Interp
(Index
, It
);
2994 -- If not a range, it can be a subtype mark, or else it is a degenerate
2995 -- membership test with a singleton value, i.e. a test for equality,
2996 -- if the types are compatible.
3001 if Is_Entity_Name
(R
)
3002 and then Is_Type
(Entity
(R
))
3005 Check_Fully_Declared
(Entity
(R
), R
);
3007 elsif Ada_Version
>= Ada_2012
3008 and then Has_Compatible_Type
(R
, Etype
(L
))
3010 if Nkind
(N
) = N_In
then
3026 -- In all versions of the language, if we reach this point there
3027 -- is a previous error that will be diagnosed below.
3033 -- Compatibility between expression and subtype mark or range is
3034 -- checked during resolution. The result of the operation is Boolean
3037 Set_Etype
(N
, Standard_Boolean
);
3039 if Comes_From_Source
(N
)
3040 and then Present
(Right_Opnd
(N
))
3041 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
3043 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
3046 Check_Function_Writable_Actuals
(N
);
3047 end Analyze_Membership_Op
;
3053 procedure Analyze_Mod
(N
: Node_Id
) is
3055 -- A special warning check, if we have an expression of the form:
3056 -- expr mod 2 * literal
3057 -- where literal is 64 or less, then probably what was meant was
3058 -- expr mod 2 ** literal
3059 -- so issue an appropriate warning.
3061 if Warn_On_Suspicious_Modulus_Value
3062 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
3063 and then Intval
(Right_Opnd
(N
)) = Uint_2
3064 and then Nkind
(Parent
(N
)) = N_Op_Multiply
3065 and then Nkind
(Right_Opnd
(Parent
(N
))) = N_Integer_Literal
3066 and then Intval
(Right_Opnd
(Parent
(N
))) <= Uint_64
3069 ("suspicious MOD value, was '*'* intended'??M?", Parent
(N
));
3072 -- Remaining processing is same as for other arithmetic operators
3074 Analyze_Arithmetic_Op
(N
);
3077 ----------------------
3078 -- Analyze_Negation --
3079 ----------------------
3081 procedure Analyze_Negation
(N
: Node_Id
) is
3082 R
: constant Node_Id
:= Right_Opnd
(N
);
3083 Op_Id
: Entity_Id
:= Entity
(N
);
3086 Set_Etype
(N
, Any_Type
);
3087 Candidate_Type
:= Empty
;
3089 Analyze_Expression
(R
);
3091 if Present
(Op_Id
) then
3092 if Ekind
(Op_Id
) = E_Operator
then
3093 Find_Negation_Types
(R
, Op_Id
, N
);
3095 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
3099 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
3100 while Present
(Op_Id
) loop
3101 if Ekind
(Op_Id
) = E_Operator
then
3102 Find_Negation_Types
(R
, Op_Id
, N
);
3104 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
3107 Op_Id
:= Homonym
(Op_Id
);
3112 end Analyze_Negation
;
3118 procedure Analyze_Null
(N
: Node_Id
) is
3120 Check_SPARK_05_Restriction
("null is not allowed", N
);
3122 Set_Etype
(N
, Any_Access
);
3125 ----------------------
3126 -- Analyze_One_Call --
3127 ----------------------
3129 procedure Analyze_One_Call
3133 Success
: out Boolean;
3134 Skip_First
: Boolean := False)
3136 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
3137 Prev_T
: constant Entity_Id
:= Etype
(N
);
3139 Must_Skip
: constant Boolean := Skip_First
3140 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
3142 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
3143 and then Nkind
(Prefix
(Original_Node
(N
)))
3144 = N_Selected_Component
);
3145 -- The first formal must be omitted from the match when trying to find
3146 -- a primitive operation that is a possible interpretation, and also
3147 -- after the call has been rewritten, because the corresponding actual
3148 -- is already known to be compatible, and because this may be an
3149 -- indexing of a call with default parameters.
3153 Is_Indexed
: Boolean := False;
3154 Is_Indirect
: Boolean := False;
3155 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
3158 function Compatible_Types_In_Predicate
3160 T2
: Entity_Id
) return Boolean;
3161 -- For an Ada 2012 predicate or invariant, a call may mention an
3162 -- incomplete type, while resolution of the corresponding predicate
3163 -- function may see the full view, as a consequence of the delayed
3164 -- resolution of the corresponding expressions. This may occur in
3165 -- the body of a predicate function, or in a call to such. Anomalies
3166 -- involving private and full views can also happen. In each case,
3167 -- rewrite node or add conversions to remove spurious type errors.
3169 procedure Indicate_Name_And_Type
;
3170 -- If candidate interpretation matches, indicate name and type of result
3173 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
3174 -- There may be a user-defined operator that hides the current
3175 -- interpretation. We must check for this independently of the
3176 -- analysis of the call with the user-defined operation, because
3177 -- the parameter names may be wrong and yet the hiding takes place.
3178 -- This fixes a problem with ACATS test B34014O.
3180 -- When the type Address is a visible integer type, and the DEC
3181 -- system extension is visible, the predefined operator may be
3182 -- hidden as well, by one of the address operations in auxdec.
3183 -- Finally, The abstract operations on address do not hide the
3184 -- predefined operator (this is the purpose of making them abstract).
3186 -----------------------------------
3187 -- Compatible_Types_In_Predicate --
3188 -----------------------------------
3190 function Compatible_Types_In_Predicate
3192 T2
: Entity_Id
) return Boolean
3194 function Common_Type
(T
: Entity_Id
) return Entity_Id
;
3195 -- Find non-private full view if any, without going to ancestor type
3196 -- (as opposed to Underlying_Type).
3202 function Common_Type
(T
: Entity_Id
) return Entity_Id
is
3204 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
3205 return Base_Type
(Full_View
(T
));
3207 return Base_Type
(T
);
3211 -- Start of processing for Compatible_Types_In_Predicate
3214 if (Ekind
(Current_Scope
) = E_Function
3215 and then Is_Predicate_Function
(Current_Scope
))
3217 (Ekind
(Nam
) = E_Function
3218 and then Is_Predicate_Function
(Nam
))
3220 if Is_Incomplete_Type
(T1
)
3221 and then Present
(Full_View
(T1
))
3222 and then Full_View
(T1
) = T2
3224 Set_Etype
(Formal
, Etype
(Actual
));
3227 elsif Common_Type
(T1
) = Common_Type
(T2
) then
3228 Rewrite
(Actual
, Unchecked_Convert_To
(Etype
(Formal
), Actual
));
3238 end Compatible_Types_In_Predicate
;
3240 ----------------------------
3241 -- Indicate_Name_And_Type --
3242 ----------------------------
3244 procedure Indicate_Name_And_Type
is
3246 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
3247 Check_Implicit_Dereference
(N
, Etype
(Nam
));
3250 -- If the prefix of the call is a name, indicate the entity
3251 -- being called. If it is not a name, it is an expression that
3252 -- denotes an access to subprogram or else an entry or family. In
3253 -- the latter case, the name is a selected component, and the entity
3254 -- being called is noted on the selector.
3256 if not Is_Type
(Nam
) then
3257 if Is_Entity_Name
(Name
(N
)) then
3258 Set_Entity
(Name
(N
), Nam
);
3259 Set_Etype
(Name
(N
), Etype
(Nam
));
3261 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
3262 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
3266 if Debug_Flag_E
and not Report
then
3267 Write_Str
(" Overloaded call ");
3268 Write_Int
(Int
(N
));
3269 Write_Str
(" compatible with ");
3270 Write_Int
(Int
(Nam
));
3273 end Indicate_Name_And_Type
;
3275 ------------------------
3276 -- Operator_Hidden_By --
3277 ------------------------
3279 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
3280 Act1
: constant Node_Id
:= First_Actual
(N
);
3281 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
3282 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
3283 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
3286 if Ekind
(Fun
) /= E_Function
or else Is_Abstract_Subprogram
(Fun
) then
3289 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
3292 elsif Present
(Form2
) then
3294 or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
3299 elsif Present
(Act2
) then
3303 -- Now we know that the arity of the operator matches the function,
3304 -- and the function call is a valid interpretation. The function
3305 -- hides the operator if it has the right signature, or if one of
3306 -- its operands is a non-abstract operation on Address when this is
3307 -- a visible integer type.
3309 return Hides_Op
(Fun
, Nam
)
3310 or else Is_Descendant_Of_Address
(Etype
(Form1
))
3313 and then Is_Descendant_Of_Address
(Etype
(Form2
)));
3314 end Operator_Hidden_By
;
3316 -- Start of processing for Analyze_One_Call
3321 -- If the subprogram has no formals or if all the formals have defaults,
3322 -- and the return type is an array type, the node may denote an indexing
3323 -- of the result of a parameterless call. In Ada 2005, the subprogram
3324 -- may have one non-defaulted formal, and the call may have been written
3325 -- in prefix notation, so that the rebuilt parameter list has more than
3328 if not Is_Overloadable
(Nam
)
3329 and then Ekind
(Nam
) /= E_Subprogram_Type
3330 and then Ekind
(Nam
) /= E_Entry_Family
3335 -- An indexing requires at least one actual. The name of the call cannot
3336 -- be an implicit indirect call, so it cannot be a generated explicit
3339 if not Is_Empty_List
(Actuals
)
3341 (Needs_No_Actuals
(Nam
)
3343 (Needs_One_Actual
(Nam
)
3344 and then Present
(Next_Actual
(First
(Actuals
)))))
3346 if Is_Array_Type
(Subp_Type
)
3348 (Nkind
(Name
(N
)) /= N_Explicit_Dereference
3349 or else Comes_From_Source
(Name
(N
)))
3351 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
3353 elsif Is_Access_Type
(Subp_Type
)
3354 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
3358 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
3360 -- The prefix can also be a parameterless function that returns an
3361 -- access to subprogram, in which case this is an indirect call.
3362 -- If this succeeds, an explicit dereference is added later on,
3363 -- in Analyze_Call or Resolve_Call.
3365 elsif Is_Access_Type
(Subp_Type
)
3366 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
3368 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
3373 -- If the call has been transformed into a slice, it is of the form
3374 -- F (Subtype) where F is parameterless. The node has been rewritten in
3375 -- Try_Indexed_Call and there is nothing else to do.
3378 and then Nkind
(N
) = N_Slice
3384 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
3388 -- If an indirect call is a possible interpretation, indicate
3389 -- success to the caller. This may be an indexing of an explicit
3390 -- dereference of a call that returns an access type (see above).
3394 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
3395 and then Comes_From_Source
(Name
(N
)))
3400 -- Mismatch in number or names of parameters
3402 elsif Debug_Flag_E
then
3403 Write_Str
(" normalization fails in call ");
3404 Write_Int
(Int
(N
));
3405 Write_Str
(" with subprogram ");
3406 Write_Int
(Int
(Nam
));
3410 -- If the context expects a function call, discard any interpretation
3411 -- that is a procedure. If the node is not overloaded, leave as is for
3412 -- better error reporting when type mismatch is found.
3414 elsif Nkind
(N
) = N_Function_Call
3415 and then Is_Overloaded
(Name
(N
))
3416 and then Ekind
(Nam
) = E_Procedure
3420 -- Ditto for function calls in a procedure context
3422 elsif Nkind
(N
) = N_Procedure_Call_Statement
3423 and then Is_Overloaded
(Name
(N
))
3424 and then Etype
(Nam
) /= Standard_Void_Type
3428 elsif No
(Actuals
) then
3430 -- If Normalize succeeds, then there are default parameters for
3433 Indicate_Name_And_Type
;
3435 elsif Ekind
(Nam
) = E_Operator
then
3436 if Nkind
(N
) = N_Procedure_Call_Statement
then
3440 -- This can occur when the prefix of the call is an operator
3441 -- name or an expanded name whose selector is an operator name.
3443 Analyze_Operator_Call
(N
, Nam
);
3445 if Etype
(N
) /= Prev_T
then
3447 -- Check that operator is not hidden by a function interpretation
3449 if Is_Overloaded
(Name
(N
)) then
3455 Get_First_Interp
(Name
(N
), I
, It
);
3456 while Present
(It
.Nam
) loop
3457 if Operator_Hidden_By
(It
.Nam
) then
3458 Set_Etype
(N
, Prev_T
);
3462 Get_Next_Interp
(I
, It
);
3467 -- If operator matches formals, record its name on the call.
3468 -- If the operator is overloaded, Resolve will select the
3469 -- correct one from the list of interpretations. The call
3470 -- node itself carries the first candidate.
3472 Set_Entity
(Name
(N
), Nam
);
3475 elsif Report
and then Etype
(N
) = Any_Type
then
3476 Error_Msg_N
("incompatible arguments for operator", N
);
3480 -- Normalize_Actuals has chained the named associations in the
3481 -- correct order of the formals.
3483 Actual
:= First_Actual
(N
);
3484 Formal
:= First_Formal
(Nam
);
3486 -- If we are analyzing a call rewritten from object notation, skip
3487 -- first actual, which may be rewritten later as an explicit
3491 Next_Actual
(Actual
);
3492 Next_Formal
(Formal
);
3495 while Present
(Actual
) and then Present
(Formal
) loop
3496 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
3497 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
3499 -- The actual can be compatible with the formal, but we must
3500 -- also check that the context is not an address type that is
3501 -- visibly an integer type. In this case the use of literals is
3502 -- illegal, except in the body of descendants of system, where
3503 -- arithmetic operations on address are of course used.
3505 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
3507 (Etype
(Actual
) /= Universal_Integer
3508 or else not Is_Descendant_Of_Address
(Etype
(Formal
))
3509 or else In_Predefined_Unit
(N
))
3511 Next_Actual
(Actual
);
3512 Next_Formal
(Formal
);
3514 -- In Allow_Integer_Address mode, we allow an actual integer to
3515 -- match a formal address type and vice versa. We only do this
3516 -- if we are certain that an error will otherwise be issued
3518 elsif Address_Integer_Convert_OK
3519 (Etype
(Actual
), Etype
(Formal
))
3520 and then (Report
and not Is_Indexed
and not Is_Indirect
)
3522 -- Handle this case by introducing an unchecked conversion
3525 Unchecked_Convert_To
(Etype
(Formal
),
3526 Relocate_Node
(Actual
)));
3527 Analyze_And_Resolve
(Actual
, Etype
(Formal
));
3528 Next_Actual
(Actual
);
3529 Next_Formal
(Formal
);
3531 -- Under relaxed RM semantics silently replace occurrences of
3532 -- null by System.Address_Null. We only do this if we know that
3533 -- an error will otherwise be issued.
3535 elsif Null_To_Null_Address_Convert_OK
(Actual
, Etype
(Formal
))
3536 and then (Report
and not Is_Indexed
and not Is_Indirect
)
3538 Replace_Null_By_Null_Address
(Actual
);
3539 Analyze_And_Resolve
(Actual
, Etype
(Formal
));
3540 Next_Actual
(Actual
);
3541 Next_Formal
(Formal
);
3543 elsif Compatible_Types_In_Predicate
3544 (Etype
(Formal
), Etype
(Actual
))
3546 Next_Actual
(Actual
);
3547 Next_Formal
(Formal
);
3549 -- In a complex case where an enclosing generic and a nested
3550 -- generic package, both declared with partially parameterized
3551 -- formal subprograms with the same names, are instantiated
3552 -- with the same type, the types of the actual parameter and
3553 -- that of the formal may appear incompatible at first sight.
3556 -- type Outer_T is private;
3557 -- with function Func (Formal : Outer_T)
3558 -- return ... is <>;
3560 -- package Outer_Gen is
3562 -- type Inner_T is private;
3563 -- with function Func (Formal : Inner_T) -- (1)
3564 -- return ... is <>;
3566 -- package Inner_Gen is
3567 -- function Inner_Func (Formal : Inner_T) -- (2)
3568 -- return ... is (Func (Formal));
3570 -- end Outer_Generic;
3572 -- package Outer_Inst is new Outer_Gen (Actual_T);
3573 -- package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T);
3575 -- In the example above, the type of parameter
3576 -- Inner_Func.Formal at (2) is incompatible with the type of
3577 -- Func.Formal at (1) in the context of instantiations
3578 -- Outer_Inst and Inner_Inst. In reality both types are generic
3579 -- actual subtypes renaming base type Actual_T as part of the
3580 -- generic prologues for the instantiations.
3582 -- Recognize this case and add a type conversion to allow this
3583 -- kind of generic actual subtype conformance. Note that this
3584 -- is done only when the call is non-overloaded because the
3585 -- resolution mechanism already has the means to disambiguate
3588 elsif not Is_Overloaded
(Name
(N
))
3589 and then Is_Type
(Etype
(Actual
))
3590 and then Is_Type
(Etype
(Formal
))
3591 and then Is_Generic_Actual_Type
(Etype
(Actual
))
3592 and then Is_Generic_Actual_Type
(Etype
(Formal
))
3593 and then Base_Type
(Etype
(Actual
)) =
3594 Base_Type
(Etype
(Formal
))
3597 Convert_To
(Etype
(Formal
), Relocate_Node
(Actual
)));
3598 Analyze_And_Resolve
(Actual
, Etype
(Formal
));
3599 Next_Actual
(Actual
);
3600 Next_Formal
(Formal
);
3602 -- Handle failed type check
3605 if Debug_Flag_E
then
3606 Write_Str
(" type checking fails in call ");
3607 Write_Int
(Int
(N
));
3608 Write_Str
(" with formal ");
3609 Write_Int
(Int
(Formal
));
3610 Write_Str
(" in subprogram ");
3611 Write_Int
(Int
(Nam
));
3615 -- Comment needed on the following test???
3617 if Report
and not Is_Indexed
and not Is_Indirect
then
3619 -- Ada 2005 (AI-251): Complete the error notification
3620 -- to help new Ada 2005 users.
3622 if Is_Class_Wide_Type
(Etype
(Formal
))
3623 and then Is_Interface
(Etype
(Etype
(Formal
)))
3624 and then not Interface_Present_In_Ancestor
3625 (Typ
=> Etype
(Actual
),
3626 Iface
=> Etype
(Etype
(Formal
)))
3629 ("(Ada 2005) does not implement interface }",
3630 Actual
, Etype
(Etype
(Formal
)));
3633 Wrong_Type
(Actual
, Etype
(Formal
));
3635 if Nkind
(Actual
) = N_Op_Eq
3636 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
3638 Formal
:= First_Formal
(Nam
);
3639 while Present
(Formal
) loop
3640 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
3641 Error_Msg_N
-- CODEFIX
3642 ("possible misspelling of `='>`!", Actual
);
3646 Next_Formal
(Formal
);
3650 if All_Errors_Mode
then
3651 Error_Msg_Sloc
:= Sloc
(Nam
);
3653 if Etype
(Formal
) = Any_Type
then
3655 ("there is no legal actual parameter", Actual
);
3658 if Is_Overloadable
(Nam
)
3659 and then Present
(Alias
(Nam
))
3660 and then not Comes_From_Source
(Nam
)
3663 ("\\ =='> in call to inherited operation & #!",
3666 elsif Ekind
(Nam
) = E_Subprogram_Type
then
3668 Access_To_Subprogram_Typ
:
3669 constant Entity_Id
:=
3671 (Associated_Node_For_Itype
(Nam
));
3674 ("\\ =='> in call to dereference of &#!",
3675 Actual
, Access_To_Subprogram_Typ
);
3680 ("\\ =='> in call to &#!", Actual
, Nam
);
3690 -- Normalize_Actuals has verified that a default value exists
3691 -- for this formal. Current actual names a subsequent formal.
3693 Next_Formal
(Formal
);
3697 -- On exit, all actuals match
3699 Indicate_Name_And_Type
;
3701 end Analyze_One_Call
;
3703 ---------------------------
3704 -- Analyze_Operator_Call --
3705 ---------------------------
3707 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
3708 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
3709 Act1
: constant Node_Id
:= First_Actual
(N
);
3710 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
3713 -- Binary operator case
3715 if Present
(Act2
) then
3717 -- If more than two operands, then not binary operator after all
3719 if Present
(Next_Actual
(Act2
)) then
3723 -- Otherwise action depends on operator
3734 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
3740 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
3747 Find_Comparison_Types
(Act1
, Act2
, Op_Id
, N
);
3752 Find_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
3754 when Name_Op_Concat
=>
3755 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
3757 -- Is this when others, or should it be an abort???
3763 -- Unary operator case
3771 Find_Unary_Types
(Act1
, Op_Id
, N
);
3774 Find_Negation_Types
(Act1
, Op_Id
, N
);
3776 -- Is this when others correct, or should it be an abort???
3782 end Analyze_Operator_Call
;
3784 -------------------------------------------
3785 -- Analyze_Overloaded_Selected_Component --
3786 -------------------------------------------
3788 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
3789 Nam
: constant Node_Id
:= Prefix
(N
);
3790 Sel
: constant Node_Id
:= Selector_Name
(N
);
3797 Set_Etype
(Sel
, Any_Type
);
3799 Get_First_Interp
(Nam
, I
, It
);
3800 while Present
(It
.Typ
) loop
3801 if Is_Access_Type
(It
.Typ
) then
3802 T
:= Designated_Type
(It
.Typ
);
3803 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
3808 -- Locate the component. For a private prefix the selector can denote
3811 if Is_Record_Type
(T
) or else Is_Private_Type
(T
) then
3813 -- If the prefix is a class-wide type, the visible components are
3814 -- those of the base type.
3816 if Is_Class_Wide_Type
(T
) then
3820 Comp
:= First_Entity
(T
);
3821 while Present
(Comp
) loop
3822 if Chars
(Comp
) = Chars
(Sel
)
3823 and then Is_Visible_Component
(Comp
)
3826 -- AI05-105: if the context is an object renaming with
3827 -- an anonymous access type, the expected type of the
3828 -- object must be anonymous. This is a name resolution rule.
3830 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
3831 or else No
(Access_Definition
(Parent
(N
)))
3832 or else Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Type
3834 Ekind
(Etype
(Comp
)) = E_Anonymous_Access_Subprogram_Type
3836 Set_Entity
(Sel
, Comp
);
3837 Set_Etype
(Sel
, Etype
(Comp
));
3838 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
3839 Check_Implicit_Dereference
(N
, Etype
(Comp
));
3841 -- This also specifies a candidate to resolve the name.
3842 -- Further overloading will be resolved from context.
3843 -- The selector name itself does not carry overloading
3846 Set_Etype
(Nam
, It
.Typ
);
3849 -- Named access type in the context of a renaming
3850 -- declaration with an access definition. Remove
3851 -- inapplicable candidate.
3860 elsif Is_Concurrent_Type
(T
) then
3861 Comp
:= First_Entity
(T
);
3862 while Present
(Comp
)
3863 and then Comp
/= First_Private_Entity
(T
)
3865 if Chars
(Comp
) = Chars
(Sel
) then
3866 if Is_Overloadable
(Comp
) then
3867 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
3869 Set_Entity_With_Checks
(Sel
, Comp
);
3870 Generate_Reference
(Comp
, Sel
);
3873 Set_Etype
(Sel
, Etype
(Comp
));
3874 Set_Etype
(N
, Etype
(Comp
));
3875 Set_Etype
(Nam
, It
.Typ
);
3877 -- For access type case, introduce explicit dereference for
3878 -- more uniform treatment of entry calls. Do this only once
3879 -- if several interpretations yield an access type.
3881 if Is_Access_Type
(Etype
(Nam
))
3882 and then Nkind
(Nam
) /= N_Explicit_Dereference
3884 Insert_Explicit_Dereference
(Nam
);
3886 (Warn_On_Dereference
, "?d?implicit dereference", N
);
3893 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
3896 Get_Next_Interp
(I
, It
);
3899 if Etype
(N
) = Any_Type
3900 and then not Try_Object_Operation
(N
)
3902 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
3903 Set_Entity
(Sel
, Any_Id
);
3904 Set_Etype
(Sel
, Any_Type
);
3906 end Analyze_Overloaded_Selected_Component
;
3908 ----------------------------------
3909 -- Analyze_Qualified_Expression --
3910 ----------------------------------
3912 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
3913 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
3914 Expr
: constant Node_Id
:= Expression
(N
);
3920 Analyze_Expression
(Expr
);
3922 Set_Etype
(N
, Any_Type
);
3927 if T
= Any_Type
then
3931 Check_Fully_Declared
(T
, N
);
3933 -- If expected type is class-wide, check for exact match before
3934 -- expansion, because if the expression is a dispatching call it
3935 -- may be rewritten as explicit dereference with class-wide result.
3936 -- If expression is overloaded, retain only interpretations that
3937 -- will yield exact matches.
3939 if Is_Class_Wide_Type
(T
) then
3940 if not Is_Overloaded
(Expr
) then
3941 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
) then
3942 if Nkind
(Expr
) = N_Aggregate
then
3943 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
3945 Wrong_Type
(Expr
, T
);
3950 Get_First_Interp
(Expr
, I
, It
);
3952 while Present
(It
.Nam
) loop
3953 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
3957 Get_Next_Interp
(I
, It
);
3963 end Analyze_Qualified_Expression
;
3965 -----------------------------------
3966 -- Analyze_Quantified_Expression --
3967 -----------------------------------
3969 procedure Analyze_Quantified_Expression
(N
: Node_Id
) is
3970 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean;
3971 -- If the iterator is part of a quantified expression, and the range is
3972 -- known to be statically empty, emit a warning and replace expression
3973 -- with its static value. Returns True if the replacement occurs.
3975 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean;
3976 -- Determine whether if expression If_Expr lacks an else part or if it
3977 -- has one, it evaluates to True.
3979 --------------------
3980 -- Is_Empty_Range --
3981 --------------------
3983 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean is
3984 Loc
: constant Source_Ptr
:= Sloc
(N
);
3987 if Is_Array_Type
(Typ
)
3988 and then Compile_Time_Known_Bounds
(Typ
)
3990 (Expr_Value
(Type_Low_Bound
(Etype
(First_Index
(Typ
)))) >
3991 Expr_Value
(Type_High_Bound
(Etype
(First_Index
(Typ
)))))
3993 Preanalyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
3995 if All_Present
(N
) then
3997 ("??quantified expression with ALL "
3998 & "over a null range has value True", N
);
3999 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
4003 ("??quantified expression with SOME "
4004 & "over a null range has value False", N
);
4005 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
4016 -----------------------------
4017 -- No_Else_Or_Trivial_True --
4018 -----------------------------
4020 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean is
4021 Else_Expr
: constant Node_Id
:=
4022 Next
(Next
(First
(Expressions
(If_Expr
))));
4026 or else (Compile_Time_Known_Value
(Else_Expr
)
4027 and then Is_True
(Expr_Value
(Else_Expr
)));
4028 end No_Else_Or_Trivial_True
;
4032 Cond
: constant Node_Id
:= Condition
(N
);
4033 Loop_Id
: Entity_Id
;
4034 QE_Scop
: Entity_Id
;
4036 -- Start of processing for Analyze_Quantified_Expression
4039 Check_SPARK_05_Restriction
("quantified expression is not allowed", N
);
4041 -- Create a scope to emulate the loop-like behavior of the quantified
4042 -- expression. The scope is needed to provide proper visibility of the
4045 QE_Scop
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Sloc
(N
), 'L');
4046 Set_Etype
(QE_Scop
, Standard_Void_Type
);
4047 Set_Scope
(QE_Scop
, Current_Scope
);
4048 Set_Parent
(QE_Scop
, N
);
4050 Push_Scope
(QE_Scop
);
4052 -- All constituents are preanalyzed and resolved to avoid untimely
4053 -- generation of various temporaries and types. Full analysis and
4054 -- expansion is carried out when the quantified expression is
4055 -- transformed into an expression with actions.
4057 if Present
(Iterator_Specification
(N
)) then
4058 Preanalyze
(Iterator_Specification
(N
));
4060 -- Do not proceed with the analysis when the range of iteration is
4061 -- empty. The appropriate error is issued by Is_Empty_Range.
4063 if Is_Entity_Name
(Name
(Iterator_Specification
(N
)))
4064 and then Is_Empty_Range
(Etype
(Name
(Iterator_Specification
(N
))))
4069 else pragma Assert
(Present
(Loop_Parameter_Specification
(N
)));
4071 Loop_Par
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
4074 Preanalyze
(Loop_Par
);
4076 if Nkind
(Discrete_Subtype_Definition
(Loop_Par
)) = N_Function_Call
4077 and then Parent
(Loop_Par
) /= N
4079 -- The parser cannot distinguish between a loop specification
4080 -- and an iterator specification. If after pre-analysis the
4081 -- proper form has been recognized, rewrite the expression to
4082 -- reflect the right kind. This is needed for proper ASIS
4083 -- navigation. If expansion is enabled, the transformation is
4084 -- performed when the expression is rewritten as a loop.
4086 Set_Iterator_Specification
(N
,
4087 New_Copy_Tree
(Iterator_Specification
(Parent
(Loop_Par
))));
4089 Set_Defining_Identifier
(Iterator_Specification
(N
),
4090 Relocate_Node
(Defining_Identifier
(Loop_Par
)));
4091 Set_Name
(Iterator_Specification
(N
),
4092 Relocate_Node
(Discrete_Subtype_Definition
(Loop_Par
)));
4093 Set_Comes_From_Source
(Iterator_Specification
(N
),
4094 Comes_From_Source
(Loop_Parameter_Specification
(N
)));
4095 Set_Loop_Parameter_Specification
(N
, Empty
);
4100 Preanalyze_And_Resolve
(Cond
, Standard_Boolean
);
4103 Set_Etype
(N
, Standard_Boolean
);
4105 -- Verify that the loop variable is used within the condition of the
4106 -- quantified expression.
4108 if Present
(Iterator_Specification
(N
)) then
4109 Loop_Id
:= Defining_Identifier
(Iterator_Specification
(N
));
4111 Loop_Id
:= Defining_Identifier
(Loop_Parameter_Specification
(N
));
4114 if Warn_On_Suspicious_Contract
4115 and then not Referenced
(Loop_Id
, Cond
)
4117 -- Generating C, this check causes spurious warnings on inlined
4118 -- postconditions; we can safely disable it because this check
4119 -- was previously performed when analyzing the internally built
4120 -- postconditions procedure.
4122 if Modify_Tree_For_C
and then In_Inlined_Body
then
4125 Error_Msg_N
("?T?unused variable &", Loop_Id
);
4129 -- Diagnose a possible misuse of the SOME existential quantifier. When
4130 -- we have a quantified expression of the form:
4132 -- for some X => (if P then Q [else True])
4134 -- any value for X that makes P False results in the if expression being
4135 -- trivially True, and so also results in the quantified expression
4136 -- being trivially True.
4138 if Warn_On_Suspicious_Contract
4139 and then not All_Present
(N
)
4140 and then Nkind
(Cond
) = N_If_Expression
4141 and then No_Else_Or_Trivial_True
(Cond
)
4143 Error_Msg_N
("?T?suspicious expression", N
);
4144 Error_Msg_N
("\\did you mean (for all X ='> (if P then Q))", N
);
4145 Error_Msg_N
("\\or (for some X ='> P and then Q) instead'?", N
);
4147 end Analyze_Quantified_Expression
;
4153 procedure Analyze_Range
(N
: Node_Id
) is
4154 L
: constant Node_Id
:= Low_Bound
(N
);
4155 H
: constant Node_Id
:= High_Bound
(N
);
4156 I1
, I2
: Interp_Index
;
4159 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
4160 -- Verify the compatibility of two types, and choose the
4161 -- non universal one if the other is universal.
4163 procedure Check_High_Bound
(T
: Entity_Id
);
4164 -- Test one interpretation of the low bound against all those
4165 -- of the high bound.
4167 procedure Check_Universal_Expression
(N
: Node_Id
);
4168 -- In Ada 83, reject bounds of a universal range that are not literals
4171 -----------------------
4172 -- Check_Common_Type --
4173 -----------------------
4175 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
4177 if Covers
(T1
=> T1
, T2
=> T2
)
4179 Covers
(T1
=> T2
, T2
=> T1
)
4181 if T1
= Universal_Integer
4182 or else T1
= Universal_Real
4183 or else T1
= Any_Character
4185 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
4188 Add_One_Interp
(N
, T1
, T1
);
4191 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
4194 end Check_Common_Type
;
4196 ----------------------
4197 -- Check_High_Bound --
4198 ----------------------
4200 procedure Check_High_Bound
(T
: Entity_Id
) is
4202 if not Is_Overloaded
(H
) then
4203 Check_Common_Type
(T
, Etype
(H
));
4205 Get_First_Interp
(H
, I2
, It2
);
4206 while Present
(It2
.Typ
) loop
4207 Check_Common_Type
(T
, It2
.Typ
);
4208 Get_Next_Interp
(I2
, It2
);
4211 end Check_High_Bound
;
4213 -----------------------------
4214 -- Is_Universal_Expression --
4215 -----------------------------
4217 procedure Check_Universal_Expression
(N
: Node_Id
) is
4219 if Etype
(N
) = Universal_Integer
4220 and then Nkind
(N
) /= N_Integer_Literal
4221 and then not Is_Entity_Name
(N
)
4222 and then Nkind
(N
) /= N_Attribute_Reference
4224 Error_Msg_N
("illegal bound in discrete range", N
);
4226 end Check_Universal_Expression
;
4228 -- Start of processing for Analyze_Range
4231 Set_Etype
(N
, Any_Type
);
4232 Analyze_Expression
(L
);
4233 Analyze_Expression
(H
);
4235 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
4239 if not Is_Overloaded
(L
) then
4240 Check_High_Bound
(Etype
(L
));
4242 Get_First_Interp
(L
, I1
, It1
);
4243 while Present
(It1
.Typ
) loop
4244 Check_High_Bound
(It1
.Typ
);
4245 Get_Next_Interp
(I1
, It1
);
4249 -- If result is Any_Type, then we did not find a compatible pair
4251 if Etype
(N
) = Any_Type
then
4252 Error_Msg_N
("incompatible types in range ", N
);
4256 if Ada_Version
= Ada_83
4258 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
4259 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
4261 Check_Universal_Expression
(L
);
4262 Check_Universal_Expression
(H
);
4265 Check_Function_Writable_Actuals
(N
);
4268 -----------------------
4269 -- Analyze_Reference --
4270 -----------------------
4272 procedure Analyze_Reference
(N
: Node_Id
) is
4273 P
: constant Node_Id
:= Prefix
(N
);
4276 Acc_Type
: Entity_Id
;
4281 -- An interesting error check, if we take the 'Ref of an object for
4282 -- which a pragma Atomic or Volatile has been given, and the type of the
4283 -- object is not Atomic or Volatile, then we are in trouble. The problem
4284 -- is that no trace of the atomic/volatile status will remain for the
4285 -- backend to respect when it deals with the resulting pointer, since
4286 -- the pointer type will not be marked atomic (it is a pointer to the
4287 -- base type of the object).
4289 -- It is not clear if that can ever occur, but in case it does, we will
4290 -- generate an error message. Not clear if this message can ever be
4291 -- generated, and pretty clear that it represents a bug if it is, still
4292 -- seems worth checking, except in CodePeer mode where we do not really
4293 -- care and don't want to bother the user.
4297 if Is_Entity_Name
(P
)
4298 and then Is_Object_Reference
(P
)
4299 and then not CodePeer_Mode
4304 if (Has_Atomic_Components
(E
)
4305 and then not Has_Atomic_Components
(T
))
4307 (Has_Volatile_Components
(E
)
4308 and then not Has_Volatile_Components
(T
))
4309 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
4310 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
4312 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
4316 -- Carry on with normal processing
4318 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
4319 Set_Etype
(Acc_Type
, Acc_Type
);
4320 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
4321 Set_Etype
(N
, Acc_Type
);
4322 end Analyze_Reference
;
4324 --------------------------------
4325 -- Analyze_Selected_Component --
4326 --------------------------------
4328 -- Prefix is a record type or a task or protected type. In the latter case,
4329 -- the selector must denote a visible entry.
4331 procedure Analyze_Selected_Component
(N
: Node_Id
) is
4332 Name
: constant Node_Id
:= Prefix
(N
);
4333 Sel
: constant Node_Id
:= Selector_Name
(N
);
4336 Has_Candidate
: Boolean := False;
4337 Hidden_Comp
: Entity_Id
;
4339 Is_Private_Op
: Boolean;
4341 Pent
: Entity_Id
:= Empty
;
4342 Prefix_Type
: Entity_Id
;
4344 Type_To_Use
: Entity_Id
;
4345 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
4346 -- a class-wide type, we use its root type, whose components are
4347 -- present in the class-wide type.
4349 Is_Single_Concurrent_Object
: Boolean;
4350 -- Set True if the prefix is a single task or a single protected object
4352 procedure Find_Component_In_Instance
(Rec
: Entity_Id
);
4353 -- In an instance, a component of a private extension may not be visible
4354 -- while it was visible in the generic. Search candidate scope for a
4355 -- component with the proper identifier. This is only done if all other
4356 -- searches have failed. If a match is found, the Etype of both N and
4357 -- Sel are set from this component, and the entity of Sel is set to
4358 -- reference this component. If no match is found, Entity (Sel) remains
4359 -- unset. For a derived type that is an actual of the instance, the
4360 -- desired component may be found in any ancestor.
4362 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
4363 -- It is known that the parent of N denotes a subprogram call. Comp
4364 -- is an overloadable component of the concurrent type of the prefix.
4365 -- Determine whether all formals of the parent of N and Comp are mode
4366 -- conformant. If the parent node is not analyzed yet it may be an
4367 -- indexed component rather than a function call.
4369 function Has_Dereference
(Nod
: Node_Id
) return Boolean;
4370 -- Check whether prefix includes a dereference at any level.
4372 --------------------------------
4373 -- Find_Component_In_Instance --
4374 --------------------------------
4376 procedure Find_Component_In_Instance
(Rec
: Entity_Id
) is
4382 while Present
(Typ
) loop
4383 Comp
:= First_Component
(Typ
);
4384 while Present
(Comp
) loop
4385 if Chars
(Comp
) = Chars
(Sel
) then
4386 Set_Entity_With_Checks
(Sel
, Comp
);
4387 Set_Etype
(Sel
, Etype
(Comp
));
4388 Set_Etype
(N
, Etype
(Comp
));
4392 Next_Component
(Comp
);
4395 -- If not found, the component may be declared in the parent
4396 -- type or its full view, if any.
4398 if Is_Derived_Type
(Typ
) then
4401 if Is_Private_Type
(Typ
) then
4402 Typ
:= Full_View
(Typ
);
4410 -- If we fall through, no match, so no changes made
4413 end Find_Component_In_Instance
;
4415 ------------------------------
4416 -- Has_Mode_Conformant_Spec --
4417 ------------------------------
4419 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
4420 Comp_Param
: Entity_Id
;
4422 Param_Typ
: Entity_Id
;
4425 Comp_Param
:= First_Formal
(Comp
);
4427 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
4428 Param
:= First
(Expressions
(Parent
(N
)));
4430 Param
:= First
(Parameter_Associations
(Parent
(N
)));
4433 while Present
(Comp_Param
)
4434 and then Present
(Param
)
4436 Param_Typ
:= Find_Parameter_Type
(Param
);
4438 if Present
(Param_Typ
)
4440 not Conforming_Types
4441 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
4446 Next_Formal
(Comp_Param
);
4450 -- One of the specs has additional formals; there is no match, unless
4451 -- this may be an indexing of a parameterless call.
4453 -- Note that when expansion is disabled, the corresponding record
4454 -- type of synchronized types is not constructed, so that there is
4455 -- no point is attempting an interpretation as a prefixed call, as
4456 -- this is bound to fail because the primitive operations will not
4457 -- be properly located.
4459 if Present
(Comp_Param
) or else Present
(Param
) then
4460 if Needs_No_Actuals
(Comp
)
4461 and then Is_Array_Type
(Etype
(Comp
))
4462 and then not Expander_Active
4471 end Has_Mode_Conformant_Spec
;
4473 ---------------------
4474 -- Has_Dereference --
4475 ---------------------
4477 function Has_Dereference
(Nod
: Node_Id
) return Boolean is
4479 if Nkind
(Nod
) = N_Explicit_Dereference
then
4482 -- When expansion is disabled an explicit dereference may not have
4483 -- been inserted, but if this is an access type the indirection makes
4486 elsif Is_Access_Type
(Etype
(Nod
)) then
4489 elsif Nkind_In
(Nod
, N_Indexed_Component
, N_Selected_Component
) then
4490 return Has_Dereference
(Prefix
(Nod
));
4495 end Has_Dereference
;
4497 -- Start of processing for Analyze_Selected_Component
4500 Set_Etype
(N
, Any_Type
);
4502 if Is_Overloaded
(Name
) then
4503 Analyze_Overloaded_Selected_Component
(N
);
4506 elsif Etype
(Name
) = Any_Type
then
4507 Set_Entity
(Sel
, Any_Id
);
4508 Set_Etype
(Sel
, Any_Type
);
4512 Prefix_Type
:= Etype
(Name
);
4515 if Is_Access_Type
(Prefix_Type
) then
4517 -- A RACW object can never be used as prefix of a selected component
4518 -- since that means it is dereferenced without being a controlling
4519 -- operand of a dispatching operation (RM E.2.2(16/1)). Before
4520 -- reporting an error, we must check whether this is actually a
4521 -- dispatching call in prefix form.
4523 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
4524 and then Comes_From_Source
(N
)
4526 if Try_Object_Operation
(N
) then
4530 ("invalid dereference of a remote access-to-class-wide value",
4534 -- Normal case of selected component applied to access type
4537 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4539 if Is_Entity_Name
(Name
) then
4540 Pent
:= Entity
(Name
);
4541 elsif Nkind
(Name
) = N_Selected_Component
4542 and then Is_Entity_Name
(Selector_Name
(Name
))
4544 Pent
:= Entity
(Selector_Name
(Name
));
4547 Prefix_Type
:= Process_Implicit_Dereference_Prefix
(Pent
, Name
);
4550 -- If we have an explicit dereference of a remote access-to-class-wide
4551 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
4552 -- have to check for the case of a prefix that is a controlling operand
4553 -- of a prefixed dispatching call, as the dereference is legal in that
4554 -- case. Normally this condition is checked in Validate_Remote_Access_
4555 -- To_Class_Wide_Type, but we have to defer the checking for selected
4556 -- component prefixes because of the prefixed dispatching call case.
4557 -- Note that implicit dereferences are checked for this just above.
4559 elsif Nkind
(Name
) = N_Explicit_Dereference
4560 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Name
)))
4561 and then Comes_From_Source
(N
)
4563 if Try_Object_Operation
(N
) then
4567 ("invalid dereference of a remote access-to-class-wide value",
4572 -- (Ada 2005): if the prefix is the limited view of a type, and
4573 -- the context already includes the full view, use the full view
4574 -- in what follows, either to retrieve a component of to find
4575 -- a primitive operation. If the prefix is an explicit dereference,
4576 -- set the type of the prefix to reflect this transformation.
4577 -- If the non-limited view is itself an incomplete type, get the
4578 -- full view if available.
4580 if From_Limited_With
(Prefix_Type
)
4581 and then Has_Non_Limited_View
(Prefix_Type
)
4583 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
4585 if Nkind
(N
) = N_Explicit_Dereference
then
4586 Set_Etype
(Prefix
(N
), Prefix_Type
);
4590 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
4591 Prefix_Type
:= Base_Type
(Prefix_Type
);
4594 Type_To_Use
:= Prefix_Type
;
4596 -- For class-wide types, use the entity list of the root type. This
4597 -- indirection is specially important for private extensions because
4598 -- only the root type get switched (not the class-wide type).
4600 if Is_Class_Wide_Type
(Prefix_Type
) then
4601 Type_To_Use
:= Root_Type
(Prefix_Type
);
4604 -- If the prefix is a single concurrent object, use its name in error
4605 -- messages, rather than that of its anonymous type.
4607 Is_Single_Concurrent_Object
:=
4608 Is_Concurrent_Type
(Prefix_Type
)
4609 and then Is_Internal_Name
(Chars
(Prefix_Type
))
4610 and then not Is_Derived_Type
(Prefix_Type
)
4611 and then Is_Entity_Name
(Name
);
4613 Comp
:= First_Entity
(Type_To_Use
);
4615 -- If the selector has an original discriminant, the node appears in
4616 -- an instance. Replace the discriminant with the corresponding one
4617 -- in the current discriminated type. For nested generics, this must
4618 -- be done transitively, so note the new original discriminant.
4620 if Nkind
(Sel
) = N_Identifier
4621 and then In_Instance
4622 and then Present
(Original_Discriminant
(Sel
))
4624 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
4626 -- Mark entity before rewriting, for completeness and because
4627 -- subsequent semantic checks might examine the original node.
4629 Set_Entity
(Sel
, Comp
);
4630 Rewrite
(Selector_Name
(N
), New_Occurrence_Of
(Comp
, Sloc
(N
)));
4631 Set_Original_Discriminant
(Selector_Name
(N
), Comp
);
4632 Set_Etype
(N
, Etype
(Comp
));
4633 Check_Implicit_Dereference
(N
, Etype
(Comp
));
4635 if Is_Access_Type
(Etype
(Name
)) then
4636 Insert_Explicit_Dereference
(Name
);
4637 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4640 elsif Is_Record_Type
(Prefix_Type
) then
4642 -- Find component with given name. In an instance, if the node is
4643 -- known as a prefixed call, do not examine components whose
4644 -- visibility may be accidental.
4646 while Present
(Comp
) and then not Is_Prefixed_Call
(N
) loop
4647 if Chars
(Comp
) = Chars
(Sel
)
4648 and then Is_Visible_Component
(Comp
, N
)
4650 Set_Entity_With_Checks
(Sel
, Comp
);
4651 Set_Etype
(Sel
, Etype
(Comp
));
4653 if Ekind
(Comp
) = E_Discriminant
then
4654 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
4656 ("cannot reference discriminant of unchecked union",
4660 if Is_Generic_Type
(Prefix_Type
)
4662 Is_Generic_Type
(Root_Type
(Prefix_Type
))
4664 Set_Original_Discriminant
(Sel
, Comp
);
4668 -- Resolve the prefix early otherwise it is not possible to
4669 -- build the actual subtype of the component: it may need
4670 -- to duplicate this prefix and duplication is only allowed
4671 -- on fully resolved expressions.
4675 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
4676 -- subtypes in a package specification.
4679 -- limited with Pkg;
4681 -- type Acc_Inc is access Pkg.T;
4683 -- N : Natural := X.all.Comp; -- ERROR, limited view
4684 -- end Pkg; -- Comp is not visible
4686 if Nkind
(Name
) = N_Explicit_Dereference
4687 and then From_Limited_With
(Etype
(Prefix
(Name
)))
4688 and then not Is_Potentially_Use_Visible
(Etype
(Name
))
4689 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
4690 N_Package_Specification
4693 ("premature usage of incomplete}", Prefix
(Name
),
4694 Etype
(Prefix
(Name
)));
4697 -- We never need an actual subtype for the case of a selection
4698 -- for a indexed component of a non-packed array, since in
4699 -- this case gigi generates all the checks and can find the
4700 -- necessary bounds information.
4702 -- We also do not need an actual subtype for the case of a
4703 -- first, last, length, or range attribute applied to a
4704 -- non-packed array, since gigi can again get the bounds in
4705 -- these cases (gigi cannot handle the packed case, since it
4706 -- has the bounds of the packed array type, not the original
4707 -- bounds of the type). However, if the prefix is itself a
4708 -- selected component, as in a.b.c (i), gigi may regard a.b.c
4709 -- as a dynamic-sized temporary, so we do generate an actual
4710 -- subtype for this case.
4712 Parent_N
:= Parent
(N
);
4714 if not Is_Packed
(Etype
(Comp
))
4716 ((Nkind
(Parent_N
) = N_Indexed_Component
4717 and then Nkind
(Name
) /= N_Selected_Component
)
4719 (Nkind
(Parent_N
) = N_Attribute_Reference
4721 Nam_In
(Attribute_Name
(Parent_N
), Name_First
,
4726 Set_Etype
(N
, Etype
(Comp
));
4728 -- If full analysis is not enabled, we do not generate an
4729 -- actual subtype, because in the absence of expansion
4730 -- reference to a formal of a protected type, for example,
4731 -- will not be properly transformed, and will lead to
4732 -- out-of-scope references in gigi.
4734 -- In all other cases, we currently build an actual subtype.
4735 -- It seems likely that many of these cases can be avoided,
4736 -- but right now, the front end makes direct references to the
4737 -- bounds (e.g. in generating a length check), and if we do
4738 -- not make an actual subtype, we end up getting a direct
4739 -- reference to a discriminant, which will not do.
4741 elsif Full_Analysis
then
4743 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
4744 Insert_Action
(N
, Act_Decl
);
4746 if No
(Act_Decl
) then
4747 Set_Etype
(N
, Etype
(Comp
));
4750 -- Component type depends on discriminants. Enter the
4751 -- main attributes of the subtype.
4754 Subt
: constant Entity_Id
:=
4755 Defining_Identifier
(Act_Decl
);
4758 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
4759 Set_Ekind
(Subt
, Ekind
(Etype
(Comp
)));
4760 Set_Etype
(N
, Subt
);
4764 -- If Full_Analysis not enabled, just set the Etype
4767 Set_Etype
(N
, Etype
(Comp
));
4770 Check_Implicit_Dereference
(N
, Etype
(N
));
4774 -- If the prefix is a private extension, check only the visible
4775 -- components of the partial view. This must include the tag,
4776 -- which can appear in expanded code in a tag check.
4778 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
4779 and then Chars
(Selector_Name
(N
)) /= Name_uTag
4781 exit when Comp
= Last_Entity
(Type_To_Use
);
4787 -- Ada 2005 (AI-252): The selected component can be interpreted as
4788 -- a prefixed view of a subprogram. Depending on the context, this is
4789 -- either a name that can appear in a renaming declaration, or part
4790 -- of an enclosing call given in prefix form.
4792 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
4793 -- selected component should resolve to a name.
4795 if Ada_Version
>= Ada_2005
4796 and then Is_Tagged_Type
(Prefix_Type
)
4797 and then not Is_Concurrent_Type
(Prefix_Type
)
4799 if Nkind
(Parent
(N
)) = N_Generic_Association
4800 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
4801 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
4803 if Find_Primitive_Operation
(N
) then
4807 elsif Try_Object_Operation
(N
) then
4811 -- If the transformation fails, it will be necessary to redo the
4812 -- analysis with all errors enabled, to indicate candidate
4813 -- interpretations and reasons for each failure ???
4817 elsif Is_Private_Type
(Prefix_Type
) then
4819 -- Allow access only to discriminants of the type. If the type has
4820 -- no full view, gigi uses the parent type for the components, so we
4821 -- do the same here.
4823 if No
(Full_View
(Prefix_Type
)) then
4824 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
4825 Comp
:= First_Entity
(Type_To_Use
);
4828 while Present
(Comp
) loop
4829 if Chars
(Comp
) = Chars
(Sel
) then
4830 if Ekind
(Comp
) = E_Discriminant
then
4831 Set_Entity_With_Checks
(Sel
, Comp
);
4832 Generate_Reference
(Comp
, Sel
);
4834 Set_Etype
(Sel
, Etype
(Comp
));
4835 Set_Etype
(N
, Etype
(Comp
));
4836 Check_Implicit_Dereference
(N
, Etype
(N
));
4838 if Is_Generic_Type
(Prefix_Type
)
4839 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
4841 Set_Original_Discriminant
(Sel
, Comp
);
4844 -- Before declaring an error, check whether this is tagged
4845 -- private type and a call to a primitive operation.
4847 elsif Ada_Version
>= Ada_2005
4848 and then Is_Tagged_Type
(Prefix_Type
)
4849 and then Try_Object_Operation
(N
)
4854 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
4855 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
4856 Set_Entity
(Sel
, Any_Id
);
4857 Set_Etype
(N
, Any_Type
);
4866 elsif Is_Concurrent_Type
(Prefix_Type
) then
4868 -- Find visible operation with given name. For a protected type,
4869 -- the possible candidates are discriminants, entries or protected
4870 -- subprograms. For a task type, the set can only include entries or
4871 -- discriminants if the task type is not an enclosing scope. If it
4872 -- is an enclosing scope (e.g. in an inner task) then all entities
4873 -- are visible, but the prefix must denote the enclosing scope, i.e.
4874 -- can only be a direct name or an expanded name.
4876 Set_Etype
(Sel
, Any_Type
);
4877 Hidden_Comp
:= Empty
;
4878 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
4879 Is_Private_Op
:= False;
4881 while Present
(Comp
) loop
4883 -- Do not examine private operations of the type if not within
4886 if Chars
(Comp
) = Chars
(Sel
) then
4887 if Is_Overloadable
(Comp
)
4889 or else Comp
/= First_Private_Entity
(Type_To_Use
))
4891 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
4892 if Comp
= First_Private_Entity
(Type_To_Use
) then
4893 Is_Private_Op
:= True;
4896 -- If the prefix is tagged, the correct interpretation may
4897 -- lie in the primitive or class-wide operations of the
4898 -- type. Perform a simple conformance check to determine
4899 -- whether Try_Object_Operation should be invoked even if
4900 -- a visible entity is found.
4902 if Is_Tagged_Type
(Prefix_Type
)
4903 and then Nkind_In
(Parent
(N
), N_Function_Call
,
4904 N_Indexed_Component
,
4905 N_Procedure_Call_Statement
)
4906 and then Has_Mode_Conformant_Spec
(Comp
)
4908 Has_Candidate
:= True;
4911 -- Note: a selected component may not denote a component of a
4912 -- protected type (4.1.3(7)).
4914 elsif Ekind_In
(Comp
, E_Discriminant
, E_Entry_Family
)
4916 and then not Is_Protected_Type
(Prefix_Type
)
4917 and then Is_Entity_Name
(Name
))
4919 Set_Entity_With_Checks
(Sel
, Comp
);
4920 Generate_Reference
(Comp
, Sel
);
4922 -- The selector is not overloadable, so we have a candidate
4925 Has_Candidate
:= True;
4928 if Ekind
(Comp
) = E_Component
then
4929 Hidden_Comp
:= Comp
;
4935 Set_Etype
(Sel
, Etype
(Comp
));
4936 Set_Etype
(N
, Etype
(Comp
));
4938 if Ekind
(Comp
) = E_Discriminant
then
4939 Set_Original_Discriminant
(Sel
, Comp
);
4942 -- For access type case, introduce explicit dereference for
4943 -- more uniform treatment of entry calls.
4945 if Is_Access_Type
(Etype
(Name
)) then
4946 Insert_Explicit_Dereference
(Name
);
4948 (Warn_On_Dereference
, "?d?implicit dereference", N
);
4953 if Comp
= First_Private_Entity
(Type_To_Use
) then
4954 if Etype
(Sel
) /= Any_Type
then
4956 -- We have a candiate
4961 -- Indicate that subsequent operations are private,
4962 -- for better error reporting.
4964 Is_Private_Op
:= True;
4969 exit when not In_Scope
4971 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
4974 -- If the scope is a current instance, the prefix cannot be an
4975 -- expression of the same type, unless the selector designates a
4976 -- public operation (otherwise that would represent an attempt to
4977 -- reach an internal entity of another synchronized object).
4979 -- This is legal if prefix is an access to such type and there is
4980 -- a dereference, or is a component with a dereferenced prefix.
4981 -- It is also legal if the prefix is a component of a task type,
4982 -- and the selector is one of the task operations.
4985 and then not Is_Entity_Name
(Name
)
4986 and then not Has_Dereference
(Name
)
4988 if Is_Task_Type
(Prefix_Type
)
4989 and then Present
(Entity
(Sel
))
4990 and then Ekind_In
(Entity
(Sel
), E_Entry
, E_Entry_Family
)
4994 elsif Is_Protected_Type
(Prefix_Type
)
4995 and then Is_Overloadable
(Entity
(Sel
))
4996 and then not Is_Private_Op
5002 ("invalid reference to internal operation of some object of "
5003 & "type &", N
, Type_To_Use
);
5004 Set_Entity
(Sel
, Any_Id
);
5005 Set_Etype
(Sel
, Any_Type
);
5009 -- Another special case: the prefix may denote an object of the type
5010 -- (but not a type) in which case this is an external call and the
5011 -- operation must be public.
5014 and then Is_Object_Reference
(Original_Node
(Prefix
(N
)))
5015 and then Comes_From_Source
(N
)
5016 and then Is_Private_Op
5018 if Present
(Hidden_Comp
) then
5020 ("invalid reference to private component of object of type "
5021 & "&", N
, Type_To_Use
);
5025 ("invalid reference to private operation of some object of "
5026 & "type &", N
, Type_To_Use
);
5029 Set_Entity
(Sel
, Any_Id
);
5030 Set_Etype
(Sel
, Any_Type
);
5034 -- If there is no visible entity with the given name or none of the
5035 -- visible entities are plausible interpretations, check whether
5036 -- there is some other primitive operation with that name.
5038 if Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Prefix_Type
) then
5039 if (Etype
(N
) = Any_Type
5040 or else not Has_Candidate
)
5041 and then Try_Object_Operation
(N
)
5045 -- If the context is not syntactically a procedure call, it
5046 -- may be a call to a primitive function declared outside of
5047 -- the synchronized type.
5049 -- If the context is a procedure call, there might still be
5050 -- an overloading between an entry and a primitive procedure
5051 -- declared outside of the synchronized type, called in prefix
5052 -- notation. This is harder to disambiguate because in one case
5053 -- the controlling formal is implicit ???
5055 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
5056 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
5057 and then Try_Object_Operation
(N
)
5062 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
5063 -- entry or procedure of a tagged concurrent type we must check
5064 -- if there are class-wide subprograms covering the primitive. If
5065 -- true then Try_Object_Operation reports the error.
5068 and then Is_Concurrent_Type
(Prefix_Type
)
5069 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5071 -- Duplicate the call. This is required to avoid problems with
5072 -- the tree transformations performed by Try_Object_Operation.
5073 -- Set properly the parent of the copied call, because it is
5074 -- about to be reanalyzed.
5077 Par
: constant Node_Id
:= New_Copy_Tree
(Parent
(N
));
5080 Set_Parent
(Par
, Parent
(Parent
(N
)));
5082 if Try_Object_Operation
5083 (Sinfo
.Name
(Par
), CW_Test_Only
=> True)
5091 if Etype
(N
) = Any_Type
and then Is_Protected_Type
(Prefix_Type
) then
5093 -- Case of a prefix of a protected type: selector might denote
5094 -- an invisible private component.
5096 Comp
:= First_Private_Entity
(Base_Type
(Prefix_Type
));
5097 while Present
(Comp
) and then Chars
(Comp
) /= Chars
(Sel
) loop
5101 if Present
(Comp
) then
5102 if Is_Single_Concurrent_Object
then
5103 Error_Msg_Node_2
:= Entity
(Name
);
5104 Error_Msg_NE
("invisible selector& for &", N
, Sel
);
5107 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
5108 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
5114 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
5119 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
5122 -- If N still has no type, the component is not defined in the prefix
5124 if Etype
(N
) = Any_Type
then
5126 if Is_Single_Concurrent_Object
then
5127 Error_Msg_Node_2
:= Entity
(Name
);
5128 Error_Msg_NE
("no selector& for&", N
, Sel
);
5130 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
5132 -- If this is a derived formal type, the parent may have different
5133 -- visibility at this point. Try for an inherited component before
5134 -- reporting an error.
5136 elsif Is_Generic_Type
(Prefix_Type
)
5137 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
5138 and then Prefix_Type
/= Etype
(Prefix_Type
)
5139 and then Is_Record_Type
(Etype
(Prefix_Type
))
5141 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
5142 Analyze_Selected_Component
(N
);
5145 -- Similarly, if this is the actual for a formal derived type, or
5146 -- a derived type thereof, the component inherited from the generic
5147 -- parent may not be visible in the actual, but the selected
5148 -- component is legal. Climb up the derivation chain of the generic
5149 -- parent type until we find the proper ancestor type.
5151 elsif In_Instance
and then Is_Tagged_Type
(Prefix_Type
) then
5153 Par
: Entity_Id
:= Prefix_Type
;
5155 -- Climb up derivation chain to generic actual subtype
5157 while not Is_Generic_Actual_Type
(Par
) loop
5158 if Ekind
(Par
) = E_Record_Type
then
5159 Par
:= Parent_Subtype
(Par
);
5162 exit when Par
= Etype
(Par
);
5167 if Present
(Par
) and then Is_Generic_Actual_Type
(Par
) then
5169 -- Now look for component in ancestor types
5171 Par
:= Generic_Parent_Type
(Declaration_Node
(Par
));
5173 Find_Component_In_Instance
(Par
);
5174 exit when Present
(Entity
(Sel
))
5175 or else Par
= Etype
(Par
);
5179 -- Another special case: the type is an extension of a private
5180 -- type T, is an actual in an instance, and we are in the body
5181 -- of the instance, so the generic body had a full view of the
5182 -- type declaration for T or of some ancestor that defines the
5183 -- component in question.
5185 elsif Is_Derived_Type
(Type_To_Use
)
5186 and then Used_As_Generic_Actual
(Type_To_Use
)
5187 and then In_Instance_Body
5189 Find_Component_In_Instance
(Parent_Subtype
(Type_To_Use
));
5191 -- In ASIS mode the generic parent type may be absent. Examine
5192 -- the parent type directly for a component that may have been
5193 -- visible in a parent generic unit.
5195 elsif Is_Derived_Type
(Prefix_Type
) then
5196 Par
:= Etype
(Prefix_Type
);
5197 Find_Component_In_Instance
(Par
);
5201 -- The search above must have eventually succeeded, since the
5202 -- selected component was legal in the generic.
5204 if No
(Entity
(Sel
)) then
5205 raise Program_Error
;
5210 -- Component not found, specialize error message when appropriate
5213 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
5215 -- Check whether this is a component of the base type which
5216 -- is absent from a statically constrained subtype. This will
5217 -- raise constraint error at run time, but is not a compile-
5218 -- time error. When the selector is illegal for base type as
5219 -- well fall through and generate a compilation error anyway.
5221 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
5222 while Present
(Comp
) loop
5223 if Chars
(Comp
) = Chars
(Sel
)
5224 and then Is_Visible_Component
(Comp
)
5226 Set_Entity_With_Checks
(Sel
, Comp
);
5227 Generate_Reference
(Comp
, Sel
);
5228 Set_Etype
(Sel
, Etype
(Comp
));
5229 Set_Etype
(N
, Etype
(Comp
));
5231 -- Emit appropriate message. The node will be replaced
5232 -- by an appropriate raise statement.
5234 -- Note that in SPARK mode, as with all calls to apply a
5235 -- compile time constraint error, this will be made into
5236 -- an error to simplify the processing of the formal
5237 -- verification backend.
5239 Apply_Compile_Time_Constraint_Error
5240 (N
, "component not present in }??",
5241 CE_Discriminant_Check_Failed
,
5242 Ent
=> Prefix_Type
, Rep
=> False);
5244 Set_Raises_Constraint_Error
(N
);
5248 Next_Component
(Comp
);
5253 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
5254 Error_Msg_NE
("no selector& for}", N
, Sel
);
5256 -- Add information in the case of an incomplete prefix
5258 if Is_Incomplete_Type
(Type_To_Use
) then
5260 Inc
: constant Entity_Id
:= First_Subtype
(Type_To_Use
);
5263 if From_Limited_With
(Scope
(Type_To_Use
)) then
5265 ("\limited view of& has no components", N
, Inc
);
5269 ("\premature usage of incomplete type&", N
, Inc
);
5271 if Nkind
(Parent
(Inc
)) =
5272 N_Incomplete_Type_Declaration
5274 -- Record location of premature use in entity so that
5275 -- a continuation message is generated when the
5276 -- completion is seen.
5278 Set_Premature_Use
(Parent
(Inc
), N
);
5284 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
5287 Set_Entity
(Sel
, Any_Id
);
5288 Set_Etype
(Sel
, Any_Type
);
5290 end Analyze_Selected_Component
;
5292 ---------------------------
5293 -- Analyze_Short_Circuit --
5294 ---------------------------
5296 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
5297 L
: constant Node_Id
:= Left_Opnd
(N
);
5298 R
: constant Node_Id
:= Right_Opnd
(N
);
5303 Analyze_Expression
(L
);
5304 Analyze_Expression
(R
);
5305 Set_Etype
(N
, Any_Type
);
5307 if not Is_Overloaded
(L
) then
5308 if Root_Type
(Etype
(L
)) = Standard_Boolean
5309 and then Has_Compatible_Type
(R
, Etype
(L
))
5311 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
5315 Get_First_Interp
(L
, Ind
, It
);
5316 while Present
(It
.Typ
) loop
5317 if Root_Type
(It
.Typ
) = Standard_Boolean
5318 and then Has_Compatible_Type
(R
, It
.Typ
)
5320 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
5323 Get_Next_Interp
(Ind
, It
);
5327 -- Here we have failed to find an interpretation. Clearly we know that
5328 -- it is not the case that both operands can have an interpretation of
5329 -- Boolean, but this is by far the most likely intended interpretation.
5330 -- So we simply resolve both operands as Booleans, and at least one of
5331 -- these resolutions will generate an error message, and we do not need
5332 -- to give another error message on the short circuit operation itself.
5334 if Etype
(N
) = Any_Type
then
5335 Resolve
(L
, Standard_Boolean
);
5336 Resolve
(R
, Standard_Boolean
);
5337 Set_Etype
(N
, Standard_Boolean
);
5339 end Analyze_Short_Circuit
;
5345 procedure Analyze_Slice
(N
: Node_Id
) is
5346 D
: constant Node_Id
:= Discrete_Range
(N
);
5347 P
: constant Node_Id
:= Prefix
(N
);
5348 Array_Type
: Entity_Id
;
5349 Index_Type
: Entity_Id
;
5351 procedure Analyze_Overloaded_Slice
;
5352 -- If the prefix is overloaded, select those interpretations that
5353 -- yield a one-dimensional array type.
5355 ------------------------------
5356 -- Analyze_Overloaded_Slice --
5357 ------------------------------
5359 procedure Analyze_Overloaded_Slice
is
5365 Set_Etype
(N
, Any_Type
);
5367 Get_First_Interp
(P
, I
, It
);
5368 while Present
(It
.Nam
) loop
5371 if Is_Access_Type
(Typ
) then
5372 Typ
:= Designated_Type
(Typ
);
5374 (Warn_On_Dereference
, "?d?implicit dereference", N
);
5377 if Is_Array_Type
(Typ
)
5378 and then Number_Dimensions
(Typ
) = 1
5379 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
5381 Add_One_Interp
(N
, Typ
, Typ
);
5384 Get_Next_Interp
(I
, It
);
5387 if Etype
(N
) = Any_Type
then
5388 Error_Msg_N
("expect array type in prefix of slice", N
);
5390 end Analyze_Overloaded_Slice
;
5392 -- Start of processing for Analyze_Slice
5395 if Comes_From_Source
(N
) then
5396 Check_SPARK_05_Restriction
("slice is not allowed", N
);
5402 if Is_Overloaded
(P
) then
5403 Analyze_Overloaded_Slice
;
5406 Array_Type
:= Etype
(P
);
5407 Set_Etype
(N
, Any_Type
);
5409 if Is_Access_Type
(Array_Type
) then
5410 Array_Type
:= Designated_Type
(Array_Type
);
5411 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
5414 if not Is_Array_Type
(Array_Type
) then
5415 Wrong_Type
(P
, Any_Array
);
5417 elsif Number_Dimensions
(Array_Type
) > 1 then
5419 ("type is not one-dimensional array in slice prefix", N
);
5422 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
5423 Index_Type
:= Etype
(String_Literal_Low_Bound
(Array_Type
));
5425 Index_Type
:= Etype
(First_Index
(Array_Type
));
5428 if not Has_Compatible_Type
(D
, Index_Type
) then
5429 Wrong_Type
(D
, Index_Type
);
5431 Set_Etype
(N
, Array_Type
);
5437 -----------------------------
5438 -- Analyze_Type_Conversion --
5439 -----------------------------
5441 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
5442 Expr
: constant Node_Id
:= Expression
(N
);
5446 -- If Conversion_OK is set, then the Etype is already set, and the only
5447 -- processing required is to analyze the expression. This is used to
5448 -- construct certain "illegal" conversions which are not allowed by Ada
5449 -- semantics, but can be handled by Gigi, see Sinfo for further details.
5451 if Conversion_OK
(N
) then
5456 -- Otherwise full type analysis is required, as well as some semantic
5457 -- checks to make sure the argument of the conversion is appropriate.
5459 Find_Type
(Subtype_Mark
(N
));
5460 Typ
:= Entity
(Subtype_Mark
(N
));
5462 Check_Fully_Declared
(Typ
, N
);
5463 Analyze_Expression
(Expr
);
5464 Validate_Remote_Type_Type_Conversion
(N
);
5466 -- Only remaining step is validity checks on the argument. These
5467 -- are skipped if the conversion does not come from the source.
5469 if not Comes_From_Source
(N
) then
5472 -- If there was an error in a generic unit, no need to replicate the
5473 -- error message. Conversely, constant-folding in the generic may
5474 -- transform the argument of a conversion into a string literal, which
5475 -- is legal. Therefore the following tests are not performed in an
5476 -- instance. The same applies to an inlined body.
5478 elsif In_Instance
or In_Inlined_Body
then
5481 elsif Nkind
(Expr
) = N_Null
then
5482 Error_Msg_N
("argument of conversion cannot be null", N
);
5483 Error_Msg_N
("\use qualified expression instead", N
);
5484 Set_Etype
(N
, Any_Type
);
5486 elsif Nkind
(Expr
) = N_Aggregate
then
5487 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
5488 Error_Msg_N
("\use qualified expression instead", N
);
5490 elsif Nkind
(Expr
) = N_Allocator
then
5491 Error_Msg_N
("argument of conversion cannot be an allocator", N
);
5492 Error_Msg_N
("\use qualified expression instead", N
);
5494 elsif Nkind
(Expr
) = N_String_Literal
then
5495 Error_Msg_N
("argument of conversion cannot be string literal", N
);
5496 Error_Msg_N
("\use qualified expression instead", N
);
5498 elsif Nkind
(Expr
) = N_Character_Literal
then
5499 if Ada_Version
= Ada_83
then
5500 Resolve
(Expr
, Typ
);
5502 Error_Msg_N
("argument of conversion cannot be character literal",
5504 Error_Msg_N
("\use qualified expression instead", N
);
5507 elsif Nkind
(Expr
) = N_Attribute_Reference
5508 and then Nam_In
(Attribute_Name
(Expr
), Name_Access
,
5509 Name_Unchecked_Access
,
5510 Name_Unrestricted_Access
)
5512 Error_Msg_N
("argument of conversion cannot be access", N
);
5513 Error_Msg_N
("\use qualified expression instead", N
);
5516 -- A formal parameter of a specific tagged type whose related subprogram
5517 -- is subject to pragma Extensions_Visible with value "False" cannot
5518 -- appear in a class-wide conversion (SPARK RM 6.1.7(3)). Do not check
5519 -- internally generated expressions.
5521 if Is_Class_Wide_Type
(Typ
)
5522 and then Comes_From_Source
(Expr
)
5523 and then Is_EVF_Expression
(Expr
)
5526 ("formal parameter cannot be converted to class-wide type when "
5527 & "Extensions_Visible is False", Expr
);
5529 end Analyze_Type_Conversion
;
5531 ----------------------
5532 -- Analyze_Unary_Op --
5533 ----------------------
5535 procedure Analyze_Unary_Op
(N
: Node_Id
) is
5536 R
: constant Node_Id
:= Right_Opnd
(N
);
5537 Op_Id
: Entity_Id
:= Entity
(N
);
5540 Set_Etype
(N
, Any_Type
);
5541 Candidate_Type
:= Empty
;
5543 Analyze_Expression
(R
);
5545 if Present
(Op_Id
) then
5546 if Ekind
(Op_Id
) = E_Operator
then
5547 Find_Unary_Types
(R
, Op_Id
, N
);
5549 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
5553 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
5554 while Present
(Op_Id
) loop
5555 if Ekind
(Op_Id
) = E_Operator
then
5556 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
5557 Find_Unary_Types
(R
, Op_Id
, N
);
5560 elsif Is_Overloadable
(Op_Id
) then
5561 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
5564 Op_Id
:= Homonym
(Op_Id
);
5569 end Analyze_Unary_Op
;
5571 ----------------------------------
5572 -- Analyze_Unchecked_Expression --
5573 ----------------------------------
5575 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
5577 Analyze
(Expression
(N
), Suppress
=> All_Checks
);
5578 Set_Etype
(N
, Etype
(Expression
(N
)));
5579 Save_Interps
(Expression
(N
), N
);
5580 end Analyze_Unchecked_Expression
;
5582 ---------------------------------------
5583 -- Analyze_Unchecked_Type_Conversion --
5584 ---------------------------------------
5586 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
5588 Find_Type
(Subtype_Mark
(N
));
5589 Analyze_Expression
(Expression
(N
));
5590 Set_Etype
(N
, Entity
(Subtype_Mark
(N
)));
5591 end Analyze_Unchecked_Type_Conversion
;
5593 ------------------------------------
5594 -- Analyze_User_Defined_Binary_Op --
5595 ------------------------------------
5597 procedure Analyze_User_Defined_Binary_Op
5602 -- Only do analysis if the operator Comes_From_Source, since otherwise
5603 -- the operator was generated by the expander, and all such operators
5604 -- always refer to the operators in package Standard.
5606 if Comes_From_Source
(N
) then
5608 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
5609 F2
: constant Entity_Id
:= Next_Formal
(F1
);
5612 -- Verify that Op_Id is a visible binary function. Note that since
5613 -- we know Op_Id is overloaded, potentially use visible means use
5614 -- visible for sure (RM 9.4(11)).
5616 if Ekind
(Op_Id
) = E_Function
5617 and then Present
(F2
)
5618 and then (Is_Immediately_Visible
(Op_Id
)
5619 or else Is_Potentially_Use_Visible
(Op_Id
))
5620 and then Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
5621 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
5623 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
5625 -- If the left operand is overloaded, indicate that the current
5626 -- type is a viable candidate. This is redundant in most cases,
5627 -- but for equality and comparison operators where the context
5628 -- does not impose a type on the operands, setting the proper
5629 -- type is necessary to avoid subsequent ambiguities during
5630 -- resolution, when both user-defined and predefined operators
5631 -- may be candidates.
5633 if Is_Overloaded
(Left_Opnd
(N
)) then
5634 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
5637 if Debug_Flag_E
then
5638 Write_Str
("user defined operator ");
5639 Write_Name
(Chars
(Op_Id
));
5640 Write_Str
(" on node ");
5641 Write_Int
(Int
(N
));
5647 end Analyze_User_Defined_Binary_Op
;
5649 -----------------------------------
5650 -- Analyze_User_Defined_Unary_Op --
5651 -----------------------------------
5653 procedure Analyze_User_Defined_Unary_Op
5658 -- Only do analysis if the operator Comes_From_Source, since otherwise
5659 -- the operator was generated by the expander, and all such operators
5660 -- always refer to the operators in package Standard.
5662 if Comes_From_Source
(N
) then
5664 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
5667 -- Verify that Op_Id is a visible unary function. Note that since
5668 -- we know Op_Id is overloaded, potentially use visible means use
5669 -- visible for sure (RM 9.4(11)).
5671 if Ekind
(Op_Id
) = E_Function
5672 and then No
(Next_Formal
(F
))
5673 and then (Is_Immediately_Visible
(Op_Id
)
5674 or else Is_Potentially_Use_Visible
(Op_Id
))
5675 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
5677 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
5681 end Analyze_User_Defined_Unary_Op
;
5683 ---------------------------
5684 -- Check_Arithmetic_Pair --
5685 ---------------------------
5687 procedure Check_Arithmetic_Pair
5688 (T1
, T2
: Entity_Id
;
5692 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
5694 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
5695 -- Check whether the fixed-point type Typ has a user-defined operator
5696 -- (multiplication or division) that should hide the corresponding
5697 -- predefined operator. Used to implement Ada 2005 AI-264, to make
5698 -- such operators more visible and therefore useful.
5700 -- If the name of the operation is an expanded name with prefix
5701 -- Standard, the predefined universal fixed operator is available,
5702 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
5704 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
;
5705 -- Get specific type (i.e. non-universal type if there is one)
5711 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
5712 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
5718 -- If the universal_fixed operation is given explicitly the rule
5719 -- concerning primitive operations of the type do not apply.
5721 if Nkind
(N
) = N_Function_Call
5722 and then Nkind
(Name
(N
)) = N_Expanded_Name
5723 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
5728 -- The operation is treated as primitive if it is declared in the
5729 -- same scope as the type, and therefore on the same entity chain.
5731 Ent
:= Next_Entity
(Typ
);
5732 while Present
(Ent
) loop
5733 if Chars
(Ent
) = Chars
(Op
) then
5734 F1
:= First_Formal
(Ent
);
5735 F2
:= Next_Formal
(F1
);
5737 -- The operation counts as primitive if either operand or
5738 -- result are of the given base type, and both operands are
5739 -- fixed point types.
5741 if (Base_Type
(Etype
(F1
)) = Bas
5742 and then Is_Fixed_Point_Type
(Etype
(F2
)))
5745 (Base_Type
(Etype
(F2
)) = Bas
5746 and then Is_Fixed_Point_Type
(Etype
(F1
)))
5749 (Base_Type
(Etype
(Ent
)) = Bas
5750 and then Is_Fixed_Point_Type
(Etype
(F1
))
5751 and then Is_Fixed_Point_Type
(Etype
(F2
)))
5767 function Specific_Type
(T1
, T2
: Entity_Id
) return Entity_Id
is
5769 if T1
= Universal_Integer
or else T1
= Universal_Real
then
5770 return Base_Type
(T2
);
5772 return Base_Type
(T1
);
5776 -- Start of processing for Check_Arithmetic_Pair
5779 if Nam_In
(Op_Name
, Name_Op_Add
, Name_Op_Subtract
) then
5780 if Is_Numeric_Type
(T1
)
5781 and then Is_Numeric_Type
(T2
)
5782 and then (Covers
(T1
=> T1
, T2
=> T2
)
5784 Covers
(T1
=> T2
, T2
=> T1
))
5786 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5789 elsif Nam_In
(Op_Name
, Name_Op_Multiply
, Name_Op_Divide
) then
5790 if Is_Fixed_Point_Type
(T1
)
5791 and then (Is_Fixed_Point_Type
(T2
) or else T2
= Universal_Real
)
5793 -- If Treat_Fixed_As_Integer is set then the Etype is already set
5794 -- and no further processing is required (this is the case of an
5795 -- operator constructed by Exp_Fixd for a fixed point operation)
5796 -- Otherwise add one interpretation with universal fixed result
5797 -- If the operator is given in functional notation, it comes
5798 -- from source and Fixed_As_Integer cannot apply.
5800 if (Nkind
(N
) not in N_Op
5801 or else not Treat_Fixed_As_Integer
(N
))
5803 (not Has_Fixed_Op
(T1
, Op_Id
)
5804 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
5806 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
5809 elsif Is_Fixed_Point_Type
(T2
)
5810 and then (Nkind
(N
) not in N_Op
5811 or else not Treat_Fixed_As_Integer
(N
))
5812 and then T1
= Universal_Real
5814 (not Has_Fixed_Op
(T1
, Op_Id
)
5815 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
5817 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
5819 elsif Is_Numeric_Type
(T1
)
5820 and then Is_Numeric_Type
(T2
)
5821 and then (Covers
(T1
=> T1
, T2
=> T2
)
5823 Covers
(T1
=> T2
, T2
=> T1
))
5825 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5827 elsif Is_Fixed_Point_Type
(T1
)
5828 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5829 or else T2
= Universal_Integer
)
5831 Add_One_Interp
(N
, Op_Id
, T1
);
5833 elsif T2
= Universal_Real
5834 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5835 and then Op_Name
= Name_Op_Multiply
5837 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5839 elsif T1
= Universal_Real
5840 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5842 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
5844 elsif Is_Fixed_Point_Type
(T2
)
5845 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
5846 or else T1
= Universal_Integer
)
5847 and then Op_Name
= Name_Op_Multiply
5849 Add_One_Interp
(N
, Op_Id
, T2
);
5851 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
5852 Add_One_Interp
(N
, Op_Id
, T1
);
5854 elsif T2
= Universal_Real
5855 and then T1
= Universal_Integer
5856 and then Op_Name
= Name_Op_Multiply
5858 Add_One_Interp
(N
, Op_Id
, T2
);
5861 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
5863 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
5864 -- set does not require any special processing, since the Etype is
5865 -- already set (case of operation constructed by Exp_Fixed).
5867 if Is_Integer_Type
(T1
)
5868 and then (Covers
(T1
=> T1
, T2
=> T2
)
5870 Covers
(T1
=> T2
, T2
=> T1
))
5872 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
5875 elsif Op_Name
= Name_Op_Expon
then
5876 if Is_Numeric_Type
(T1
)
5877 and then not Is_Fixed_Point_Type
(T1
)
5878 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5879 or else T2
= Universal_Integer
)
5881 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5884 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
5886 -- If not one of the predefined operators, the node may be one
5887 -- of the intrinsic functions. Its kind is always specific, and
5888 -- we can use it directly, rather than the name of the operation.
5890 if Is_Integer_Type
(T1
)
5891 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
5892 or else T2
= Universal_Integer
)
5894 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
5897 end Check_Arithmetic_Pair
;
5899 -------------------------------
5900 -- Check_Misspelled_Selector --
5901 -------------------------------
5903 procedure Check_Misspelled_Selector
5904 (Prefix
: Entity_Id
;
5907 Max_Suggestions
: constant := 2;
5908 Nr_Of_Suggestions
: Natural := 0;
5910 Suggestion_1
: Entity_Id
:= Empty
;
5911 Suggestion_2
: Entity_Id
:= Empty
;
5916 -- All the components of the prefix of selector Sel are matched against
5917 -- Sel and a count is maintained of possible misspellings. When at
5918 -- the end of the analysis there are one or two (not more) possible
5919 -- misspellings, these misspellings will be suggested as possible
5922 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
5924 -- Concurrent types should be handled as well ???
5929 Comp
:= First_Entity
(Prefix
);
5930 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
5931 if Is_Visible_Component
(Comp
) then
5932 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
5933 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
5935 case Nr_Of_Suggestions
is
5936 when 1 => Suggestion_1
:= Comp
;
5937 when 2 => Suggestion_2
:= Comp
;
5938 when others => null;
5943 Comp
:= Next_Entity
(Comp
);
5946 -- Report at most two suggestions
5948 if Nr_Of_Suggestions
= 1 then
5949 Error_Msg_NE
-- CODEFIX
5950 ("\possible misspelling of&", Sel
, Suggestion_1
);
5952 elsif Nr_Of_Suggestions
= 2 then
5953 Error_Msg_Node_2
:= Suggestion_2
;
5954 Error_Msg_NE
-- CODEFIX
5955 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
5957 end Check_Misspelled_Selector
;
5959 ----------------------
5960 -- Defined_In_Scope --
5961 ----------------------
5963 function Defined_In_Scope
(T
: Entity_Id
; S
: Entity_Id
) return Boolean
5965 S1
: constant Entity_Id
:= Scope
(Base_Type
(T
));
5968 or else (S1
= System_Aux_Id
and then S
= Scope
(S1
));
5969 end Defined_In_Scope
;
5975 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
5981 Void_Interp_Seen
: Boolean := False;
5984 pragma Warnings
(Off
, Boolean);
5987 if Ada_Version
>= Ada_2005
then
5988 Actual
:= First_Actual
(N
);
5989 while Present
(Actual
) loop
5991 -- Ada 2005 (AI-50217): Post an error in case of premature
5992 -- usage of an entity from the limited view.
5994 if not Analyzed
(Etype
(Actual
))
5995 and then From_Limited_With
(Etype
(Actual
))
5997 Error_Msg_Qual_Level
:= 1;
5999 ("missing with_clause for scope of imported type&",
6000 Actual
, Etype
(Actual
));
6001 Error_Msg_Qual_Level
:= 0;
6004 Next_Actual
(Actual
);
6008 -- Before listing the possible candidates, check whether this is
6009 -- a prefix of a selected component that has been rewritten as a
6010 -- parameterless function call because there is a callable candidate
6011 -- interpretation. If there is a hidden package in the list of homonyms
6012 -- of the function name (bad programming style in any case) suggest that
6013 -- this is the intended entity.
6015 if No
(Parameter_Associations
(N
))
6016 and then Nkind
(Parent
(N
)) = N_Selected_Component
6017 and then Nkind
(Parent
(Parent
(N
))) in N_Declaration
6018 and then Is_Overloaded
(Nam
)
6024 Ent
:= Current_Entity
(Nam
);
6025 while Present
(Ent
) loop
6026 if Ekind
(Ent
) = E_Package
then
6028 ("no legal interpretations as function call,!", Nam
);
6029 Error_Msg_NE
("\package& is not visible", N
, Ent
);
6031 Rewrite
(Parent
(N
),
6032 New_Occurrence_Of
(Any_Type
, Sloc
(N
)));
6036 Ent
:= Homonym
(Ent
);
6041 -- Analyze each candidate call again, with full error reporting for
6045 ("no candidate interpretations match the actuals:!", Nam
);
6046 Err_Mode
:= All_Errors_Mode
;
6047 All_Errors_Mode
:= True;
6049 -- If this is a call to an operation of a concurrent type,
6050 -- the failed interpretations have been removed from the
6051 -- name. Recover them to provide full diagnostics.
6053 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
6054 Set_Entity
(Nam
, Empty
);
6055 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
6056 Set_Is_Overloaded
(New_Nam
, False);
6057 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
6058 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
6059 Analyze_Selected_Component
(New_Nam
);
6060 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
6062 Get_First_Interp
(Nam
, X
, It
);
6065 while Present
(It
.Nam
) loop
6066 if Etype
(It
.Nam
) = Standard_Void_Type
then
6067 Void_Interp_Seen
:= True;
6070 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
6071 Get_Next_Interp
(X
, It
);
6074 if Nkind
(N
) = N_Function_Call
then
6075 Get_First_Interp
(Nam
, X
, It
);
6076 while Present
(It
.Nam
) loop
6077 if Ekind_In
(It
.Nam
, E_Function
, E_Operator
) then
6080 Get_Next_Interp
(X
, It
);
6084 -- If all interpretations are procedures, this deserves a
6085 -- more precise message. Ditto if this appears as the prefix
6086 -- of a selected component, which may be a lexical error.
6089 ("\context requires function call, found procedure name", Nam
);
6091 if Nkind
(Parent
(N
)) = N_Selected_Component
6092 and then N
= Prefix
(Parent
(N
))
6094 Error_Msg_N
-- CODEFIX
6095 ("\period should probably be semicolon", Parent
(N
));
6098 elsif Nkind
(N
) = N_Procedure_Call_Statement
6099 and then not Void_Interp_Seen
6102 "\function name found in procedure call", Nam
);
6105 All_Errors_Mode
:= Err_Mode
;
6108 ---------------------------
6109 -- Find_Arithmetic_Types --
6110 ---------------------------
6112 procedure Find_Arithmetic_Types
6117 Index1
: Interp_Index
;
6118 Index2
: Interp_Index
;
6122 procedure Check_Right_Argument
(T
: Entity_Id
);
6123 -- Check right operand of operator
6125 --------------------------
6126 -- Check_Right_Argument --
6127 --------------------------
6129 procedure Check_Right_Argument
(T
: Entity_Id
) is
6131 if not Is_Overloaded
(R
) then
6132 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
6134 Get_First_Interp
(R
, Index2
, It2
);
6135 while Present
(It2
.Typ
) loop
6136 Check_Arithmetic_Pair
(T
, It2
.Typ
, Op_Id
, N
);
6137 Get_Next_Interp
(Index2
, It2
);
6140 end Check_Right_Argument
;
6142 -- Start of processing for Find_Arithmetic_Types
6145 if not Is_Overloaded
(L
) then
6146 Check_Right_Argument
(Etype
(L
));
6149 Get_First_Interp
(L
, Index1
, It1
);
6150 while Present
(It1
.Typ
) loop
6151 Check_Right_Argument
(It1
.Typ
);
6152 Get_Next_Interp
(Index1
, It1
);
6156 end Find_Arithmetic_Types
;
6158 ------------------------
6159 -- Find_Boolean_Types --
6160 ------------------------
6162 procedure Find_Boolean_Types
6167 Index
: Interp_Index
;
6170 procedure Check_Numeric_Argument
(T
: Entity_Id
);
6171 -- Special case for logical operations one of whose operands is an
6172 -- integer literal. If both are literal the result is any modular type.
6174 ----------------------------
6175 -- Check_Numeric_Argument --
6176 ----------------------------
6178 procedure Check_Numeric_Argument
(T
: Entity_Id
) is
6180 if T
= Universal_Integer
then
6181 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
6183 elsif Is_Modular_Integer_Type
(T
) then
6184 Add_One_Interp
(N
, Op_Id
, T
);
6186 end Check_Numeric_Argument
;
6188 -- Start of processing for Find_Boolean_Types
6191 if not Is_Overloaded
(L
) then
6192 if Etype
(L
) = Universal_Integer
6193 or else Etype
(L
) = Any_Modular
6195 if not Is_Overloaded
(R
) then
6196 Check_Numeric_Argument
(Etype
(R
));
6199 Get_First_Interp
(R
, Index
, It
);
6200 while Present
(It
.Typ
) loop
6201 Check_Numeric_Argument
(It
.Typ
);
6202 Get_Next_Interp
(Index
, It
);
6206 -- If operands are aggregates, we must assume that they may be
6207 -- boolean arrays, and leave disambiguation for the second pass.
6208 -- If only one is an aggregate, verify that the other one has an
6209 -- interpretation as a boolean array
6211 elsif Nkind
(L
) = N_Aggregate
then
6212 if Nkind
(R
) = N_Aggregate
then
6213 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
6215 elsif not Is_Overloaded
(R
) then
6216 if Valid_Boolean_Arg
(Etype
(R
)) then
6217 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
6221 Get_First_Interp
(R
, Index
, It
);
6222 while Present
(It
.Typ
) loop
6223 if Valid_Boolean_Arg
(It
.Typ
) then
6224 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
6227 Get_Next_Interp
(Index
, It
);
6231 elsif Valid_Boolean_Arg
(Etype
(L
))
6232 and then Has_Compatible_Type
(R
, Etype
(L
))
6234 Add_One_Interp
(N
, Op_Id
, Etype
(L
));
6238 Get_First_Interp
(L
, Index
, It
);
6239 while Present
(It
.Typ
) loop
6240 if Valid_Boolean_Arg
(It
.Typ
)
6241 and then Has_Compatible_Type
(R
, It
.Typ
)
6243 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
6246 Get_Next_Interp
(Index
, It
);
6249 end Find_Boolean_Types
;
6251 ---------------------------
6252 -- Find_Comparison_Types --
6253 ---------------------------
6255 procedure Find_Comparison_Types
6260 Index
: Interp_Index
;
6262 Found
: Boolean := False;
6265 Scop
: Entity_Id
:= Empty
;
6267 procedure Try_One_Interp
(T1
: Entity_Id
);
6268 -- Routine to try one proposed interpretation. Note that the context
6269 -- of the operator plays no role in resolving the arguments, so that
6270 -- if there is more than one interpretation of the operands that is
6271 -- compatible with comparison, the operation is ambiguous.
6273 --------------------
6274 -- Try_One_Interp --
6275 --------------------
6277 procedure Try_One_Interp
(T1
: Entity_Id
) is
6280 -- If the operator is an expanded name, then the type of the operand
6281 -- must be defined in the corresponding scope. If the type is
6282 -- universal, the context will impose the correct type.
6285 and then not Defined_In_Scope
(T1
, Scop
)
6286 and then T1
/= Universal_Integer
6287 and then T1
/= Universal_Real
6288 and then T1
/= Any_String
6289 and then T1
/= Any_Composite
6294 if Valid_Comparison_Arg
(T1
) and then Has_Compatible_Type
(R
, T1
) then
6295 if Found
and then Base_Type
(T1
) /= Base_Type
(T_F
) then
6296 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
6298 if It
= No_Interp
then
6299 Ambiguous_Operands
(N
);
6300 Set_Etype
(L
, Any_Type
);
6314 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
6319 -- Start of processing for Find_Comparison_Types
6322 -- If left operand is aggregate, the right operand has to
6323 -- provide a usable type for it.
6325 if Nkind
(L
) = N_Aggregate
and then Nkind
(R
) /= N_Aggregate
then
6326 Find_Comparison_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
6330 if Nkind
(N
) = N_Function_Call
6331 and then Nkind
(Name
(N
)) = N_Expanded_Name
6333 Scop
:= Entity
(Prefix
(Name
(N
)));
6335 -- The prefix may be a package renaming, and the subsequent test
6336 -- requires the original package.
6338 if Ekind
(Scop
) = E_Package
6339 and then Present
(Renamed_Entity
(Scop
))
6341 Scop
:= Renamed_Entity
(Scop
);
6342 Set_Entity
(Prefix
(Name
(N
)), Scop
);
6346 if not Is_Overloaded
(L
) then
6347 Try_One_Interp
(Etype
(L
));
6350 Get_First_Interp
(L
, Index
, It
);
6351 while Present
(It
.Typ
) loop
6352 Try_One_Interp
(It
.Typ
);
6353 Get_Next_Interp
(Index
, It
);
6356 end Find_Comparison_Types
;
6358 ----------------------------------------
6359 -- Find_Non_Universal_Interpretations --
6360 ----------------------------------------
6362 procedure Find_Non_Universal_Interpretations
6368 Index
: Interp_Index
;
6372 if T1
= Universal_Integer
or else T1
= Universal_Real
6374 -- If the left operand of an equality operator is null, the visibility
6375 -- of the operator must be determined from the interpretation of the
6376 -- right operand. This processing must be done for Any_Access, which
6377 -- is the internal representation of the type of the literal null.
6379 or else T1
= Any_Access
6381 if not Is_Overloaded
(R
) then
6382 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(Etype
(R
)));
6384 Get_First_Interp
(R
, Index
, It
);
6385 while Present
(It
.Typ
) loop
6386 if Covers
(It
.Typ
, T1
) then
6388 (N
, Op_Id
, Standard_Boolean
, Base_Type
(It
.Typ
));
6391 Get_Next_Interp
(Index
, It
);
6395 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
, Base_Type
(T1
));
6397 end Find_Non_Universal_Interpretations
;
6399 ------------------------------
6400 -- Find_Concatenation_Types --
6401 ------------------------------
6403 procedure Find_Concatenation_Types
6408 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
6411 if Is_Array_Type
(Op_Type
)
6412 and then not Is_Limited_Type
(Op_Type
)
6414 and then (Has_Compatible_Type
(L
, Op_Type
)
6416 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
6418 and then (Has_Compatible_Type
(R
, Op_Type
)
6420 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
6422 Add_One_Interp
(N
, Op_Id
, Op_Type
);
6424 end Find_Concatenation_Types
;
6426 -------------------------
6427 -- Find_Equality_Types --
6428 -------------------------
6430 procedure Find_Equality_Types
6435 Index
: Interp_Index
;
6437 Found
: Boolean := False;
6440 Scop
: Entity_Id
:= Empty
;
6442 procedure Try_One_Interp
(T1
: Entity_Id
);
6443 -- The context of the equality operator plays no role in resolving the
6444 -- arguments, so that if there is more than one interpretation of the
6445 -- operands that is compatible with equality, the construct is ambiguous
6446 -- and an error can be emitted now, after trying to disambiguate, i.e.
6447 -- applying preference rules.
6449 --------------------
6450 -- Try_One_Interp --
6451 --------------------
6453 procedure Try_One_Interp
(T1
: Entity_Id
) is
6454 Bas
: constant Entity_Id
:= Base_Type
(T1
);
6457 -- If the operator is an expanded name, then the type of the operand
6458 -- must be defined in the corresponding scope. If the type is
6459 -- universal, the context will impose the correct type. An anonymous
6460 -- type for a 'Access reference is also universal in this sense, as
6461 -- the actual type is obtained from context.
6463 -- In Ada 2005, the equality operator for anonymous access types
6464 -- is declared in Standard, and preference rules apply to it.
6466 if Present
(Scop
) then
6467 if Defined_In_Scope
(T1
, Scop
)
6468 or else T1
= Universal_Integer
6469 or else T1
= Universal_Real
6470 or else T1
= Any_Access
6471 or else T1
= Any_String
6472 or else T1
= Any_Composite
6473 or else (Ekind
(T1
) = E_Access_Subprogram_Type
6474 and then not Comes_From_Source
(T1
))
6478 elsif Ekind
(T1
) = E_Anonymous_Access_Type
6479 and then Scop
= Standard_Standard
6484 -- The scope does not contain an operator for the type
6489 -- If we have infix notation, the operator must be usable. Within
6490 -- an instance, if the type is already established we know it is
6491 -- correct. If an operand is universal it is compatible with any
6494 elsif In_Open_Scopes
(Scope
(Bas
))
6495 or else Is_Potentially_Use_Visible
(Bas
)
6496 or else In_Use
(Bas
)
6497 or else (In_Use
(Scope
(Bas
)) and then not Is_Hidden
(Bas
))
6499 -- In an instance, the type may have been immediately visible.
6500 -- Either the types are compatible, or one operand is universal
6501 -- (numeric or null).
6504 ((In_Instance
or else In_Inlined_Body
)
6506 (First_Subtype
(T1
) = First_Subtype
(Etype
(R
))
6507 or else Nkind
(R
) = N_Null
6509 (Is_Numeric_Type
(T1
)
6510 and then Is_Universal_Numeric_Type
(Etype
(R
)))))
6512 -- In Ada 2005, the equality on anonymous access types is declared
6513 -- in Standard, and is always visible.
6515 or else Ekind
(T1
) = E_Anonymous_Access_Type
6520 -- Save candidate type for subsequent error message, if any
6522 if not Is_Limited_Type
(T1
) then
6523 Candidate_Type
:= T1
;
6529 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
6530 -- Do not allow anonymous access types in equality operators.
6532 if Ada_Version
< Ada_2005
6533 and then Ekind
(T1
) = E_Anonymous_Access_Type
6538 -- If the right operand has a type compatible with T1, check for an
6539 -- acceptable interpretation, unless T1 is limited (no predefined
6540 -- equality available), or this is use of a "/=" for a tagged type.
6541 -- In the latter case, possible interpretations of equality need
6542 -- to be considered, we don't want the default inequality declared
6543 -- in Standard to be chosen, and the "/=" will be rewritten as a
6544 -- negation of "=" (see the end of Analyze_Equality_Op). This ensures
6545 -- that rewriting happens during analysis rather than being
6546 -- delayed until expansion (this is needed for ASIS, which only sees
6547 -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id
6548 -- is Name_Op_Eq then we still proceed with the interpretation,
6549 -- because that indicates the potential rewriting case where the
6550 -- interpretation to consider is actually "=" and the node may be
6551 -- about to be rewritten by Analyze_Equality_Op.
6553 if T1
/= Standard_Void_Type
6554 and then Has_Compatible_Type
(R
, T1
)
6557 ((not Is_Limited_Type
(T1
)
6558 and then not Is_Limited_Composite
(T1
))
6562 and then not Is_Limited_Type
(Component_Type
(T1
))
6563 and then Available_Full_View_Of_Component
(T1
)))
6566 (Nkind
(N
) /= N_Op_Ne
6567 or else not Is_Tagged_Type
(T1
)
6568 or else Chars
(Op_Id
) = Name_Op_Eq
)
6571 and then Base_Type
(T1
) /= Base_Type
(T_F
)
6573 It
:= Disambiguate
(L
, I_F
, Index
, Any_Type
);
6575 if It
= No_Interp
then
6576 Ambiguous_Operands
(N
);
6577 Set_Etype
(L
, Any_Type
);
6590 if not Analyzed
(L
) then
6594 Find_Non_Universal_Interpretations
(N
, R
, Op_Id
, T1
);
6596 -- Case of operator was not visible, Etype still set to Any_Type
6598 if Etype
(N
) = Any_Type
then
6602 elsif Scop
= Standard_Standard
6603 and then Ekind
(T1
) = E_Anonymous_Access_Type
6609 -- Start of processing for Find_Equality_Types
6612 -- If left operand is aggregate, the right operand has to
6613 -- provide a usable type for it.
6615 if Nkind
(L
) = N_Aggregate
6616 and then Nkind
(R
) /= N_Aggregate
6618 Find_Equality_Types
(L
=> R
, R
=> L
, Op_Id
=> Op_Id
, N
=> N
);
6622 if Nkind
(N
) = N_Function_Call
6623 and then Nkind
(Name
(N
)) = N_Expanded_Name
6625 Scop
:= Entity
(Prefix
(Name
(N
)));
6627 -- The prefix may be a package renaming, and the subsequent test
6628 -- requires the original package.
6630 if Ekind
(Scop
) = E_Package
6631 and then Present
(Renamed_Entity
(Scop
))
6633 Scop
:= Renamed_Entity
(Scop
);
6634 Set_Entity
(Prefix
(Name
(N
)), Scop
);
6638 if not Is_Overloaded
(L
) then
6639 Try_One_Interp
(Etype
(L
));
6642 Get_First_Interp
(L
, Index
, It
);
6643 while Present
(It
.Typ
) loop
6644 Try_One_Interp
(It
.Typ
);
6645 Get_Next_Interp
(Index
, It
);
6648 end Find_Equality_Types
;
6650 -------------------------
6651 -- Find_Negation_Types --
6652 -------------------------
6654 procedure Find_Negation_Types
6659 Index
: Interp_Index
;
6663 if not Is_Overloaded
(R
) then
6664 if Etype
(R
) = Universal_Integer
then
6665 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
6666 elsif Valid_Boolean_Arg
(Etype
(R
)) then
6667 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
6671 Get_First_Interp
(R
, Index
, It
);
6672 while Present
(It
.Typ
) loop
6673 if Valid_Boolean_Arg
(It
.Typ
) then
6674 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
6677 Get_Next_Interp
(Index
, It
);
6680 end Find_Negation_Types
;
6682 ------------------------------
6683 -- Find_Primitive_Operation --
6684 ------------------------------
6686 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
6687 Obj
: constant Node_Id
:= Prefix
(N
);
6688 Op
: constant Node_Id
:= Selector_Name
(N
);
6695 Set_Etype
(Op
, Any_Type
);
6697 if Is_Access_Type
(Etype
(Obj
)) then
6698 Typ
:= Designated_Type
(Etype
(Obj
));
6703 if Is_Class_Wide_Type
(Typ
) then
6704 Typ
:= Root_Type
(Typ
);
6707 Prims
:= Primitive_Operations
(Typ
);
6709 Prim
:= First_Elmt
(Prims
);
6710 while Present
(Prim
) loop
6711 if Chars
(Node
(Prim
)) = Chars
(Op
) then
6712 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
6713 Set_Etype
(N
, Etype
(Node
(Prim
)));
6719 -- Now look for class-wide operations of the type or any of its
6720 -- ancestors by iterating over the homonyms of the selector.
6723 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
6727 Hom
:= Current_Entity
(Op
);
6728 while Present
(Hom
) loop
6729 if (Ekind
(Hom
) = E_Procedure
6731 Ekind
(Hom
) = E_Function
)
6732 and then Scope
(Hom
) = Scope
(Typ
)
6733 and then Present
(First_Formal
(Hom
))
6735 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
6737 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
6739 Ekind
(Etype
(First_Formal
(Hom
))) =
6740 E_Anonymous_Access_Type
6743 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
6746 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
6747 Set_Etype
(N
, Etype
(Hom
));
6750 Hom
:= Homonym
(Hom
);
6754 return Etype
(Op
) /= Any_Type
;
6755 end Find_Primitive_Operation
;
6757 ----------------------
6758 -- Find_Unary_Types --
6759 ----------------------
6761 procedure Find_Unary_Types
6766 Index
: Interp_Index
;
6770 if not Is_Overloaded
(R
) then
6771 if Is_Numeric_Type
(Etype
(R
)) then
6773 -- In an instance a generic actual may be a numeric type even if
6774 -- the formal in the generic unit was not. In that case, the
6775 -- predefined operator was not a possible interpretation in the
6776 -- generic, and cannot be one in the instance, unless the operator
6777 -- is an actual of an instance.
6781 not Is_Numeric_Type
(Corresponding_Generic_Type
(Etype
(R
)))
6785 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
6790 Get_First_Interp
(R
, Index
, It
);
6791 while Present
(It
.Typ
) loop
6792 if Is_Numeric_Type
(It
.Typ
) then
6796 (Corresponding_Generic_Type
(Etype
(It
.Typ
)))
6801 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
6805 Get_Next_Interp
(Index
, It
);
6808 end Find_Unary_Types
;
6814 function Junk_Operand
(N
: Node_Id
) return Boolean is
6818 if Error_Posted
(N
) then
6822 -- Get entity to be tested
6824 if Is_Entity_Name
(N
)
6825 and then Present
(Entity
(N
))
6829 -- An odd case, a procedure name gets converted to a very peculiar
6830 -- function call, and here is where we detect this happening.
6832 elsif Nkind
(N
) = N_Function_Call
6833 and then Is_Entity_Name
(Name
(N
))
6834 and then Present
(Entity
(Name
(N
)))
6838 -- Another odd case, there are at least some cases of selected
6839 -- components where the selected component is not marked as having
6840 -- an entity, even though the selector does have an entity
6842 elsif Nkind
(N
) = N_Selected_Component
6843 and then Present
(Entity
(Selector_Name
(N
)))
6845 Enode
:= Selector_Name
(N
);
6851 -- Now test the entity we got to see if it is a bad case
6853 case Ekind
(Entity
(Enode
)) is
6856 ("package name cannot be used as operand", Enode
);
6858 when Generic_Unit_Kind
=>
6860 ("generic unit name cannot be used as operand", Enode
);
6864 ("subtype name cannot be used as operand", Enode
);
6868 ("entry name cannot be used as operand", Enode
);
6872 ("procedure name cannot be used as operand", Enode
);
6876 ("exception name cannot be used as operand", Enode
);
6883 ("label name cannot be used as operand", Enode
);
6892 --------------------
6893 -- Operator_Check --
6894 --------------------
6896 procedure Operator_Check
(N
: Node_Id
) is
6898 Remove_Abstract_Operations
(N
);
6900 -- Test for case of no interpretation found for operator
6902 if Etype
(N
) = Any_Type
then
6906 Op_Id
: Entity_Id
:= Empty
;
6909 R
:= Right_Opnd
(N
);
6911 if Nkind
(N
) in N_Binary_Op
then
6917 -- If either operand has no type, then don't complain further,
6918 -- since this simply means that we have a propagated error.
6921 or else Etype
(R
) = Any_Type
6922 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
6924 -- For the rather unusual case where one of the operands is
6925 -- a Raise_Expression, whose initial type is Any_Type, use
6926 -- the type of the other operand.
6928 if Nkind
(L
) = N_Raise_Expression
then
6929 Set_Etype
(L
, Etype
(R
));
6930 Set_Etype
(N
, Etype
(R
));
6932 elsif Nkind
(R
) = N_Raise_Expression
then
6933 Set_Etype
(R
, Etype
(L
));
6934 Set_Etype
(N
, Etype
(L
));
6939 -- We explicitly check for the case of concatenation of component
6940 -- with component to avoid reporting spurious matching array types
6941 -- that might happen to be lurking in distant packages (such as
6942 -- run-time packages). This also prevents inconsistencies in the
6943 -- messages for certain ACVC B tests, which can vary depending on
6944 -- types declared in run-time interfaces. Another improvement when
6945 -- aggregates are present is to look for a well-typed operand.
6947 elsif Present
(Candidate_Type
)
6948 and then (Nkind
(N
) /= N_Op_Concat
6949 or else Is_Array_Type
(Etype
(L
))
6950 or else Is_Array_Type
(Etype
(R
)))
6952 if Nkind
(N
) = N_Op_Concat
then
6953 if Etype
(L
) /= Any_Composite
6954 and then Is_Array_Type
(Etype
(L
))
6956 Candidate_Type
:= Etype
(L
);
6958 elsif Etype
(R
) /= Any_Composite
6959 and then Is_Array_Type
(Etype
(R
))
6961 Candidate_Type
:= Etype
(R
);
6965 Error_Msg_NE
-- CODEFIX
6966 ("operator for} is not directly visible!",
6967 N
, First_Subtype
(Candidate_Type
));
6970 U
: constant Node_Id
:=
6971 Cunit
(Get_Source_Unit
(Candidate_Type
));
6973 if Unit_Is_Visible
(U
) then
6974 Error_Msg_N
-- CODEFIX
6975 ("use clause would make operation legal!", N
);
6977 Error_Msg_NE
-- CODEFIX
6978 ("add with_clause and use_clause for&!",
6979 N
, Defining_Entity
(Unit
(U
)));
6984 -- If either operand is a junk operand (e.g. package name), then
6985 -- post appropriate error messages, but do not complain further.
6987 -- Note that the use of OR in this test instead of OR ELSE is
6988 -- quite deliberate, we may as well check both operands in the
6989 -- binary operator case.
6991 elsif Junk_Operand
(R
)
6992 or -- really mean OR here and not OR ELSE, see above
6993 (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
6997 -- If we have a logical operator, one of whose operands is
6998 -- Boolean, then we know that the other operand cannot resolve to
6999 -- Boolean (since we got no interpretations), but in that case we
7000 -- pretty much know that the other operand should be Boolean, so
7001 -- resolve it that way (generating an error).
7003 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
) then
7004 if Etype
(L
) = Standard_Boolean
then
7005 Resolve
(R
, Standard_Boolean
);
7007 elsif Etype
(R
) = Standard_Boolean
then
7008 Resolve
(L
, Standard_Boolean
);
7012 -- For an arithmetic operator or comparison operator, if one
7013 -- of the operands is numeric, then we know the other operand
7014 -- is not the same numeric type. If it is a non-numeric type,
7015 -- then probably it is intended to match the other operand.
7017 elsif Nkind_In
(N
, N_Op_Add
,
7023 Nkind_In
(N
, N_Op_Lt
,
7029 -- If Allow_Integer_Address is active, check whether the
7030 -- operation becomes legal after converting an operand.
7032 if Is_Numeric_Type
(Etype
(L
))
7033 and then not Is_Numeric_Type
(Etype
(R
))
7035 if Address_Integer_Convert_OK
(Etype
(R
), Etype
(L
)) then
7037 Unchecked_Convert_To
(Etype
(L
), Relocate_Node
(R
)));
7039 if Nkind_In
(N
, N_Op_Ge
, N_Op_Gt
, N_Op_Le
, N_Op_Lt
) then
7040 Analyze_Comparison_Op
(N
);
7042 Analyze_Arithmetic_Op
(N
);
7045 Resolve
(R
, Etype
(L
));
7050 elsif Is_Numeric_Type
(Etype
(R
))
7051 and then not Is_Numeric_Type
(Etype
(L
))
7053 if Address_Integer_Convert_OK
(Etype
(L
), Etype
(R
)) then
7055 Unchecked_Convert_To
(Etype
(R
), Relocate_Node
(L
)));
7057 if Nkind_In
(N
, N_Op_Ge
, N_Op_Gt
, N_Op_Le
, N_Op_Lt
) then
7058 Analyze_Comparison_Op
(N
);
7060 Analyze_Arithmetic_Op
(N
);
7066 Resolve
(L
, Etype
(R
));
7071 elsif Allow_Integer_Address
7072 and then Is_Descendant_Of_Address
(Etype
(L
))
7073 and then Is_Descendant_Of_Address
(Etype
(R
))
7074 and then not Error_Posted
(N
)
7077 Addr_Type
: constant Entity_Id
:= Etype
(L
);
7081 Unchecked_Convert_To
(
7082 Standard_Integer
, Relocate_Node
(L
)));
7084 Unchecked_Convert_To
(
7085 Standard_Integer
, Relocate_Node
(R
)));
7087 if Nkind_In
(N
, N_Op_Ge
, N_Op_Gt
, N_Op_Le
, N_Op_Lt
) then
7088 Analyze_Comparison_Op
(N
);
7090 Analyze_Arithmetic_Op
(N
);
7093 -- If this is an operand in an enclosing arithmetic
7094 -- operation, Convert the result as an address so that
7095 -- arithmetic folding of address can continue.
7097 if Nkind
(Parent
(N
)) in N_Op
then
7099 Unchecked_Convert_To
(Addr_Type
, Relocate_Node
(N
)));
7105 -- Under relaxed RM semantics silently replace occurrences of
7106 -- null by System.Address_Null.
7108 elsif Null_To_Null_Address_Convert_OK
(N
) then
7109 Replace_Null_By_Null_Address
(N
);
7111 if Nkind_In
(N
, N_Op_Ge
, N_Op_Gt
, N_Op_Le
, N_Op_Lt
) then
7112 Analyze_Comparison_Op
(N
);
7114 Analyze_Arithmetic_Op
(N
);
7120 -- Comparisons on A'Access are common enough to deserve a
7123 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
7124 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
7125 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
7128 ("two access attributes cannot be compared directly", N
);
7130 ("\use qualified expression for one of the operands",
7134 -- Another one for C programmers
7136 elsif Nkind
(N
) = N_Op_Concat
7137 and then Valid_Boolean_Arg
(Etype
(L
))
7138 and then Valid_Boolean_Arg
(Etype
(R
))
7140 Error_Msg_N
("invalid operands for concatenation", N
);
7141 Error_Msg_N
-- CODEFIX
7142 ("\maybe AND was meant", N
);
7145 -- A special case for comparison of access parameter with null
7147 elsif Nkind
(N
) = N_Op_Eq
7148 and then Is_Entity_Name
(L
)
7149 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
7150 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
7152 and then Nkind
(R
) = N_Null
7154 Error_Msg_N
("access parameter is not allowed to be null", L
);
7155 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
7158 -- Another special case for exponentiation, where the right
7159 -- operand must be Natural, independently of the base.
7161 elsif Nkind
(N
) = N_Op_Expon
7162 and then Is_Numeric_Type
(Etype
(L
))
7163 and then not Is_Overloaded
(R
)
7165 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
7166 and then Base_Type
(Etype
(R
)) /= Universal_Integer
7168 if Ada_Version
>= Ada_2012
7169 and then Has_Dimension_System
(Etype
(L
))
7172 ("exponent for dimensioned type must be a rational" &
7173 ", found}", R
, Etype
(R
));
7176 ("exponent must be of type Natural, found}", R
, Etype
(R
));
7181 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
) then
7182 if Address_Integer_Convert_OK
(Etype
(R
), Etype
(L
)) then
7184 Unchecked_Convert_To
(Etype
(L
), Relocate_Node
(R
)));
7185 Analyze_Equality_Op
(N
);
7188 -- Under relaxed RM semantics silently replace occurrences of
7189 -- null by System.Address_Null.
7191 elsif Null_To_Null_Address_Convert_OK
(N
) then
7192 Replace_Null_By_Null_Address
(N
);
7193 Analyze_Equality_Op
(N
);
7198 -- If we fall through then just give general message. Note that in
7199 -- the following messages, if the operand is overloaded we choose
7200 -- an arbitrary type to complain about, but that is probably more
7201 -- useful than not giving a type at all.
7203 if Nkind
(N
) in N_Unary_Op
then
7204 Error_Msg_Node_2
:= Etype
(R
);
7205 Error_Msg_N
("operator& not defined for}", N
);
7209 if Nkind
(N
) in N_Binary_Op
then
7210 if not Is_Overloaded
(L
)
7211 and then not Is_Overloaded
(R
)
7212 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
7214 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
7215 Error_Msg_N
("there is no applicable operator& for}", N
);
7218 -- Another attempt to find a fix: one of the candidate
7219 -- interpretations may not be use-visible. This has
7220 -- already been checked for predefined operators, so
7221 -- we examine only user-defined functions.
7223 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
7225 while Present
(Op_Id
) loop
7226 if Ekind
(Op_Id
) /= E_Operator
7227 and then Is_Overloadable
(Op_Id
)
7229 if not Is_Immediately_Visible
(Op_Id
)
7230 and then not In_Use
(Scope
(Op_Id
))
7231 and then not Is_Abstract_Subprogram
(Op_Id
)
7232 and then not Is_Hidden
(Op_Id
)
7233 and then Ekind
(Scope
(Op_Id
)) = E_Package
7236 (L
, Etype
(First_Formal
(Op_Id
)))
7238 (Next_Formal
(First_Formal
(Op_Id
)))
7242 Etype
(Next_Formal
(First_Formal
(Op_Id
))))
7245 ("No legal interpretation for operator&", N
);
7247 ("\use clause on& would make operation legal",
7253 Op_Id
:= Homonym
(Op_Id
);
7257 Error_Msg_N
("invalid operand types for operator&", N
);
7259 if Nkind
(N
) /= N_Op_Concat
then
7260 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
7261 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
7263 -- For concatenation operators it is more difficult to
7264 -- determine which is the wrong operand. It is worth
7265 -- flagging explicitly an access type, for those who
7266 -- might think that a dereference happens here.
7268 elsif Is_Access_Type
(Etype
(L
)) then
7269 Error_Msg_N
("\left operand is access type", N
);
7271 elsif Is_Access_Type
(Etype
(R
)) then
7272 Error_Msg_N
("\right operand is access type", N
);
7282 -----------------------------------------
7283 -- Process_Implicit_Dereference_Prefix --
7284 -----------------------------------------
7286 function Process_Implicit_Dereference_Prefix
7288 P
: Entity_Id
) return Entity_Id
7291 Typ
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
7295 and then (Operating_Mode
= Check_Semantics
or else not Expander_Active
)
7297 -- We create a dummy reference to E to ensure that the reference is
7298 -- not considered as part of an assignment (an implicit dereference
7299 -- can never assign to its prefix). The Comes_From_Source attribute
7300 -- needs to be propagated for accurate warnings.
7302 Ref
:= New_Occurrence_Of
(E
, Sloc
(P
));
7303 Set_Comes_From_Source
(Ref
, Comes_From_Source
(P
));
7304 Generate_Reference
(E
, Ref
);
7307 -- An implicit dereference is a legal occurrence of an incomplete type
7308 -- imported through a limited_with clause, if the full view is visible.
7310 if From_Limited_With
(Typ
)
7311 and then not From_Limited_With
(Scope
(Typ
))
7313 (Is_Immediately_Visible
(Scope
(Typ
))
7315 (Is_Child_Unit
(Scope
(Typ
))
7316 and then Is_Visible_Lib_Unit
(Scope
(Typ
))))
7318 return Available_View
(Typ
);
7322 end Process_Implicit_Dereference_Prefix
;
7324 --------------------------------
7325 -- Remove_Abstract_Operations --
7326 --------------------------------
7328 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
7329 Abstract_Op
: Entity_Id
:= Empty
;
7330 Address_Descendant
: Boolean := False;
7334 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
7335 -- activate this if either extensions are enabled, or if the abstract
7336 -- operation in question comes from a predefined file. This latter test
7337 -- allows us to use abstract to make operations invisible to users. In
7338 -- particular, if type Address is non-private and abstract subprograms
7339 -- are used to hide its operators, they will be truly hidden.
7341 type Operand_Position
is (First_Op
, Second_Op
);
7342 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
7344 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
7345 -- Ambiguities may arise when the operands are literal and the address
7346 -- operations in s-auxdec are visible. In that case, remove the
7347 -- interpretation of a literal as Address, to retain the semantics
7348 -- of Address as a private type.
7350 ------------------------------------
7351 -- Remove_Address_Interpretations --
7352 ------------------------------------
7354 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
7358 if Is_Overloaded
(N
) then
7359 Get_First_Interp
(N
, I
, It
);
7360 while Present
(It
.Nam
) loop
7361 Formal
:= First_Entity
(It
.Nam
);
7363 if Op
= Second_Op
then
7364 Formal
:= Next_Entity
(Formal
);
7367 if Is_Descendant_Of_Address
(Etype
(Formal
)) then
7368 Address_Descendant
:= True;
7372 Get_Next_Interp
(I
, It
);
7375 end Remove_Address_Interpretations
;
7377 -- Start of processing for Remove_Abstract_Operations
7380 if Is_Overloaded
(N
) then
7381 if Debug_Flag_V
then
7382 Write_Str
("Remove_Abstract_Operations: ");
7383 Write_Overloads
(N
);
7386 Get_First_Interp
(N
, I
, It
);
7388 while Present
(It
.Nam
) loop
7389 if Is_Overloadable
(It
.Nam
)
7390 and then Is_Abstract_Subprogram
(It
.Nam
)
7391 and then not Is_Dispatching_Operation
(It
.Nam
)
7393 Abstract_Op
:= It
.Nam
;
7395 if Is_Descendant_Of_Address
(It
.Typ
) then
7396 Address_Descendant
:= True;
7400 -- In Ada 2005, this operation does not participate in overload
7401 -- resolution. If the operation is defined in a predefined
7402 -- unit, it is one of the operations declared abstract in some
7403 -- variants of System, and it must be removed as well.
7405 elsif Ada_Version
>= Ada_2005
7406 or else In_Predefined_Unit
(It
.Nam
)
7413 Get_Next_Interp
(I
, It
);
7416 if No
(Abstract_Op
) then
7418 -- If some interpretation yields an integer type, it is still
7419 -- possible that there are address interpretations. Remove them
7420 -- if one operand is a literal, to avoid spurious ambiguities
7421 -- on systems where Address is a visible integer type.
7423 if Is_Overloaded
(N
)
7424 and then Nkind
(N
) in N_Op
7425 and then Is_Integer_Type
(Etype
(N
))
7427 if Nkind
(N
) in N_Binary_Op
then
7428 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
7429 Remove_Address_Interpretations
(Second_Op
);
7431 elsif Nkind
(Left_Opnd
(N
)) = N_Integer_Literal
then
7432 Remove_Address_Interpretations
(First_Op
);
7437 elsif Nkind
(N
) in N_Op
then
7439 -- Remove interpretations that treat literals as addresses. This
7440 -- is never appropriate, even when Address is defined as a visible
7441 -- Integer type. The reason is that we would really prefer Address
7442 -- to behave as a private type, even in this case. If Address is a
7443 -- visible integer type, we get lots of overload ambiguities.
7445 if Nkind
(N
) in N_Binary_Op
then
7447 U1
: constant Boolean :=
7448 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
7449 U2
: constant Boolean :=
7450 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
7454 Remove_Address_Interpretations
(Second_Op
);
7458 Remove_Address_Interpretations
(First_Op
);
7461 if not (U1
and U2
) then
7463 -- Remove corresponding predefined operator, which is
7464 -- always added to the overload set.
7466 Get_First_Interp
(N
, I
, It
);
7467 while Present
(It
.Nam
) loop
7468 if Scope
(It
.Nam
) = Standard_Standard
7469 and then Base_Type
(It
.Typ
) =
7470 Base_Type
(Etype
(Abstract_Op
))
7475 Get_Next_Interp
(I
, It
);
7478 elsif Is_Overloaded
(N
)
7479 and then Present
(Univ_Type
)
7481 -- If both operands have a universal interpretation,
7482 -- it is still necessary to remove interpretations that
7483 -- yield Address. Any remaining ambiguities will be
7484 -- removed in Disambiguate.
7486 Get_First_Interp
(N
, I
, It
);
7487 while Present
(It
.Nam
) loop
7488 if Is_Descendant_Of_Address
(It
.Typ
) then
7491 elsif not Is_Type
(It
.Nam
) then
7492 Set_Entity
(N
, It
.Nam
);
7495 Get_Next_Interp
(I
, It
);
7501 elsif Nkind
(N
) = N_Function_Call
7503 (Nkind
(Name
(N
)) = N_Operator_Symbol
7505 (Nkind
(Name
(N
)) = N_Expanded_Name
7507 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
7511 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
7512 U1
: constant Boolean :=
7513 Present
(Universal_Interpretation
(Arg1
));
7514 U2
: constant Boolean :=
7515 Present
(Next
(Arg1
)) and then
7516 Present
(Universal_Interpretation
(Next
(Arg1
)));
7520 Remove_Address_Interpretations
(First_Op
);
7524 Remove_Address_Interpretations
(Second_Op
);
7527 if not (U1
and U2
) then
7528 Get_First_Interp
(N
, I
, It
);
7529 while Present
(It
.Nam
) loop
7530 if Scope
(It
.Nam
) = Standard_Standard
7531 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
7536 Get_Next_Interp
(I
, It
);
7542 -- If the removal has left no valid interpretations, emit an error
7543 -- message now and label node as illegal.
7545 if Present
(Abstract_Op
) then
7546 Get_First_Interp
(N
, I
, It
);
7550 -- Removal of abstract operation left no viable candidate
7552 Set_Etype
(N
, Any_Type
);
7553 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
7555 ("cannot call abstract operation& declared#", N
, Abstract_Op
);
7557 -- In Ada 2005, an abstract operation may disable predefined
7558 -- operators. Since the context is not yet known, we mark the
7559 -- predefined operators as potentially hidden. Do not include
7560 -- predefined operators when addresses are involved since this
7561 -- case is handled separately.
7563 elsif Ada_Version
>= Ada_2005
and then not Address_Descendant
then
7564 while Present
(It
.Nam
) loop
7565 if Is_Numeric_Type
(It
.Typ
)
7566 and then Scope
(It
.Typ
) = Standard_Standard
7568 Set_Abstract_Op
(I
, Abstract_Op
);
7571 Get_Next_Interp
(I
, It
);
7576 if Debug_Flag_V
then
7577 Write_Str
("Remove_Abstract_Operations done: ");
7578 Write_Overloads
(N
);
7581 end Remove_Abstract_Operations
;
7583 ----------------------------
7584 -- Try_Container_Indexing --
7585 ----------------------------
7587 function Try_Container_Indexing
7590 Exprs
: List_Id
) return Boolean
7592 Pref_Typ
: constant Entity_Id
:= Etype
(Prefix
);
7594 function Constant_Indexing_OK
return Boolean;
7595 -- Constant_Indexing is legal if there is no Variable_Indexing defined
7596 -- for the type, or else node not a target of assignment, or an actual
7597 -- for an IN OUT or OUT formal (RM 4.1.6 (11)).
7599 function Expr_Matches_In_Formal
7601 Par
: Node_Id
) return Boolean;
7602 -- Find formal corresponding to given indexed component that is an
7603 -- actual in a call. Note that the enclosing subprogram call has not
7604 -- been analyzed yet, and the parameter list is not normalized, so
7605 -- that if the argument is a parameter association we must match it
7606 -- by name and not by position.
7608 function Find_Indexing_Operations
7611 Is_Constant
: Boolean) return Node_Id
;
7612 -- Return a reference to the primitive operation of type T denoted by
7613 -- name Nam. If the operation is overloaded, the reference carries all
7614 -- interpretations. Flag Is_Constant should be set when the context is
7615 -- constant indexing.
7617 --------------------------
7618 -- Constant_Indexing_OK --
7619 --------------------------
7621 function Constant_Indexing_OK
return Boolean is
7625 if No
(Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Variable_Indexing
)) then
7628 elsif not Is_Variable
(Prefix
) then
7633 while Present
(Par
) loop
7634 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
7635 and then Par
= Name
(Parent
(Par
))
7639 -- The call may be overloaded, in which case we assume that its
7640 -- resolution does not depend on the type of the parameter that
7641 -- includes the indexing operation.
7643 elsif Nkind_In
(Parent
(Par
), N_Function_Call
,
7644 N_Procedure_Call_Statement
)
7645 and then Is_Entity_Name
(Name
(Parent
(Par
)))
7651 -- We should look for an interpretation with the proper
7652 -- number of formals, and determine whether it is an
7653 -- In_Parameter, but for now we examine the formal that
7654 -- corresponds to the indexing, and assume that variable
7655 -- indexing is required if some interpretation has an
7656 -- assignable formal at that position. Still does not
7657 -- cover the most complex cases ???
7659 if Is_Overloaded
(Name
(Parent
(Par
))) then
7661 Proc
: constant Node_Id
:= Name
(Parent
(Par
));
7666 Get_First_Interp
(Proc
, I
, It
);
7667 while Present
(It
.Nam
) loop
7668 if not Expr_Matches_In_Formal
(It
.Nam
, Par
) then
7672 Get_Next_Interp
(I
, It
);
7676 -- All interpretations have a matching in-mode formal
7681 Proc
:= Entity
(Name
(Parent
(Par
)));
7683 -- If this is an indirect call, get formals from
7686 if Is_Access_Subprogram_Type
(Etype
(Proc
)) then
7687 Proc
:= Designated_Type
(Etype
(Proc
));
7691 return Expr_Matches_In_Formal
(Proc
, Par
);
7694 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
7697 -- If the indexed component is a prefix it may be the first actual
7698 -- of a prefixed call. Retrieve the called entity, if any, and
7699 -- check its first formal. Determine if the context is a procedure
7700 -- or function call.
7702 elsif Nkind
(Parent
(Par
)) = N_Selected_Component
then
7704 Sel
: constant Node_Id
:= Selector_Name
(Parent
(Par
));
7705 Nam
: constant Entity_Id
:= Current_Entity
(Sel
);
7708 if Present
(Nam
) and then Is_Overloadable
(Nam
) then
7709 if Nkind
(Parent
(Parent
(Par
))) =
7710 N_Procedure_Call_Statement
7714 elsif Ekind
(Nam
) = E_Function
7715 and then Present
(First_Formal
(Nam
))
7717 return Ekind
(First_Formal
(Nam
)) = E_In_Parameter
;
7722 elsif Nkind
(Par
) in N_Op
then
7726 Par
:= Parent
(Par
);
7729 -- In all other cases, constant indexing is legal
7732 end Constant_Indexing_OK
;
7734 ----------------------------
7735 -- Expr_Matches_In_Formal --
7736 ----------------------------
7738 function Expr_Matches_In_Formal
7740 Par
: Node_Id
) return Boolean
7746 Formal
:= First_Formal
(Subp
);
7747 Actual
:= First
(Parameter_Associations
((Parent
(Par
))));
7749 if Nkind
(Par
) /= N_Parameter_Association
then
7751 -- Match by position
7753 while Present
(Actual
) and then Present
(Formal
) loop
7754 exit when Actual
= Par
;
7757 if Present
(Formal
) then
7758 Next_Formal
(Formal
);
7760 -- Otherwise this is a parameter mismatch, the error is
7761 -- reported elsewhere, or else variable indexing is implied.
7771 while Present
(Formal
) loop
7772 exit when Chars
(Formal
) = Chars
(Selector_Name
(Par
));
7773 Next_Formal
(Formal
);
7781 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Parameter
;
7782 end Expr_Matches_In_Formal
;
7784 ------------------------------
7785 -- Find_Indexing_Operations --
7786 ------------------------------
7788 function Find_Indexing_Operations
7791 Is_Constant
: Boolean) return Node_Id
7793 procedure Inspect_Declarations
7795 Ref
: in out Node_Id
);
7796 -- Traverse the declarative list where type Typ resides and collect
7797 -- all suitable interpretations in node Ref.
7799 procedure Inspect_Primitives
7801 Ref
: in out Node_Id
);
7802 -- Traverse the list of primitive operations of type Typ and collect
7803 -- all suitable interpretations in node Ref.
7805 function Is_OK_Candidate
7806 (Subp_Id
: Entity_Id
;
7807 Typ
: Entity_Id
) return Boolean;
7808 -- Determine whether subprogram Subp_Id is a suitable indexing
7809 -- operation for type Typ. To qualify as such, the subprogram must
7810 -- be a function, have at least two parameters, and the type of the
7811 -- first parameter must be either Typ, or Typ'Class, or access [to
7812 -- constant] with designated type Typ or Typ'Class.
7814 procedure Record_Interp
(Subp_Id
: Entity_Id
; Ref
: in out Node_Id
);
7815 -- Store subprogram Subp_Id as an interpretation in node Ref
7817 --------------------------
7818 -- Inspect_Declarations --
7819 --------------------------
7821 procedure Inspect_Declarations
7823 Ref
: in out Node_Id
)
7825 Typ_Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
7827 Subp_Id
: Entity_Id
;
7830 -- Ensure that the routine is not called with itypes, which lack a
7831 -- declarative node.
7833 pragma Assert
(Present
(Typ_Decl
));
7834 pragma Assert
(Is_List_Member
(Typ_Decl
));
7836 Decl
:= First
(List_Containing
(Typ_Decl
));
7837 while Present
(Decl
) loop
7838 if Nkind
(Decl
) = N_Subprogram_Declaration
then
7839 Subp_Id
:= Defining_Entity
(Decl
);
7841 if Is_OK_Candidate
(Subp_Id
, Typ
) then
7842 Record_Interp
(Subp_Id
, Ref
);
7848 end Inspect_Declarations
;
7850 ------------------------
7851 -- Inspect_Primitives --
7852 ------------------------
7854 procedure Inspect_Primitives
7856 Ref
: in out Node_Id
)
7858 Prim_Elmt
: Elmt_Id
;
7859 Prim_Id
: Entity_Id
;
7862 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7863 while Present
(Prim_Elmt
) loop
7864 Prim_Id
:= Node
(Prim_Elmt
);
7866 if Is_OK_Candidate
(Prim_Id
, Typ
) then
7867 Record_Interp
(Prim_Id
, Ref
);
7870 Next_Elmt
(Prim_Elmt
);
7872 end Inspect_Primitives
;
7874 ---------------------
7875 -- Is_OK_Candidate --
7876 ---------------------
7878 function Is_OK_Candidate
7879 (Subp_Id
: Entity_Id
;
7880 Typ
: Entity_Id
) return Boolean
7883 Formal_Typ
: Entity_Id
;
7884 Param_Typ
: Node_Id
;
7887 -- To classify as a suitable candidate, the subprogram must be a
7888 -- function whose name matches the argument of aspect Constant or
7889 -- Variable_Indexing.
7891 if Ekind
(Subp_Id
) = E_Function
and then Chars
(Subp_Id
) = Nam
then
7892 Formal
:= First_Formal
(Subp_Id
);
7894 -- The candidate requires at least two parameters
7896 if Present
(Formal
) and then Present
(Next_Formal
(Formal
)) then
7897 Formal_Typ
:= Empty
;
7898 Param_Typ
:= Parameter_Type
(Parent
(Formal
));
7900 -- Use the designated type when the first parameter is of an
7903 if Nkind
(Param_Typ
) = N_Access_Definition
7904 and then Present
(Subtype_Mark
(Param_Typ
))
7906 -- When the context is a constant indexing, the access
7907 -- definition must be access-to-constant. This does not
7908 -- apply to variable indexing.
7911 or else Constant_Present
(Param_Typ
)
7913 Formal_Typ
:= Etype
(Subtype_Mark
(Param_Typ
));
7916 -- Otherwise use the parameter type
7919 Formal_Typ
:= Etype
(Param_Typ
);
7922 if Present
(Formal_Typ
) then
7924 -- Use the specific type when the parameter type is
7927 if Is_Class_Wide_Type
(Formal_Typ
) then
7928 Formal_Typ
:= Etype
(Base_Type
(Formal_Typ
));
7931 -- Use the full view when the parameter type is private
7934 if Is_Incomplete_Or_Private_Type
(Formal_Typ
)
7935 and then Present
(Full_View
(Formal_Typ
))
7937 Formal_Typ
:= Full_View
(Formal_Typ
);
7940 -- The type of the first parameter must denote the type
7941 -- of the container or acts as its ancestor type.
7945 or else Is_Ancestor
(Formal_Typ
, Typ
);
7951 end Is_OK_Candidate
;
7957 procedure Record_Interp
(Subp_Id
: Entity_Id
; Ref
: in out Node_Id
) is
7959 if Present
(Ref
) then
7960 Add_One_Interp
(Ref
, Subp_Id
, Etype
(Subp_Id
));
7962 -- Otherwise this is the first interpretation. Create a reference
7963 -- where all remaining interpretations will be collected.
7966 Ref
:= New_Occurrence_Of
(Subp_Id
, Sloc
(T
));
7975 -- Start of processing for Find_Indexing_Operations
7980 -- Use the specific type when the parameter type is class-wide
7982 if Is_Class_Wide_Type
(Typ
) then
7983 Typ
:= Root_Type
(Typ
);
7987 Typ
:= Underlying_Type
(Base_Type
(Typ
));
7989 Inspect_Primitives
(Typ
, Ref
);
7991 -- Now look for explicit declarations of an indexing operation.
7992 -- If the type is private the operation may be declared in the
7993 -- visible part that contains the partial view.
7995 if Is_Private_Type
(T
) then
7996 Inspect_Declarations
(T
, Ref
);
7999 Inspect_Declarations
(Typ
, Ref
);
8002 end Find_Indexing_Operations
;
8006 Loc
: constant Source_Ptr
:= Sloc
(N
);
8010 Func_Name
: Node_Id
;
8013 Is_Constant_Indexing
: Boolean := False;
8014 -- This flag reflects the nature of the container indexing. Note that
8015 -- the context may be suited for constant indexing, but the type may
8016 -- lack a Constant_Indexing annotation.
8018 -- Start of processing for Try_Container_Indexing
8021 -- Node may have been analyzed already when testing for a prefixed
8022 -- call, in which case do not redo analysis.
8024 if Present
(Generalized_Indexing
(N
)) then
8030 -- If indexing a class-wide container, obtain indexing primitive from
8033 if Is_Class_Wide_Type
(C_Type
) then
8034 C_Type
:= Etype
(Base_Type
(C_Type
));
8037 -- Check whether the type has a specified indexing aspect
8041 -- The context is suitable for constant indexing, so obtain the name of
8042 -- the indexing function from aspect Constant_Indexing.
8044 if Constant_Indexing_OK
then
8046 Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Constant_Indexing
);
8049 if Present
(Func_Name
) then
8050 Is_Constant_Indexing
:= True;
8052 -- Otherwise attempt variable indexing
8056 Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Variable_Indexing
);
8059 -- The type is not subject to either form of indexing, therefore the
8060 -- indexed component does not denote container indexing. If this is a
8061 -- true error, it is diagnosed by the caller.
8063 if No
(Func_Name
) then
8065 -- The prefix itself may be an indexing of a container. Rewrite it
8066 -- as such and retry.
8068 if Has_Implicit_Dereference
(Pref_Typ
) then
8069 Build_Explicit_Dereference
(Prefix
, First_Discriminant
(Pref_Typ
));
8070 return Try_Container_Indexing
(N
, Prefix
, Exprs
);
8072 -- Otherwise this is definitely not container indexing
8078 -- If the container type is derived from another container type, the
8079 -- value of the inherited aspect is the Reference operation declared
8080 -- for the parent type.
8082 -- However, Reference is also a primitive operation of the type, and the
8083 -- inherited operation has a different signature. We retrieve the right
8084 -- ones (the function may be overloaded) from the list of primitive
8085 -- operations of the derived type.
8087 -- Note that predefined containers are typically all derived from one of
8088 -- the Controlled types. The code below is motivated by containers that
8089 -- are derived from other types with a Reference aspect.
8091 elsif Is_Derived_Type
(C_Type
)
8092 and then Etype
(First_Formal
(Entity
(Func_Name
))) /= Pref_Typ
8095 Find_Indexing_Operations
8097 Nam
=> Chars
(Func_Name
),
8098 Is_Constant
=> Is_Constant_Indexing
);
8101 Assoc
:= New_List
(Relocate_Node
(Prefix
));
8103 -- A generalized indexing may have nore than one index expression, so
8104 -- transfer all of them to the argument list to be used in the call.
8105 -- Note that there may be named associations, in which case the node
8106 -- was rewritten earlier as a call, and has been transformed back into
8107 -- an indexed expression to share the following processing.
8109 -- The generalized indexing node is the one on which analysis and
8110 -- resolution take place. Before expansion the original node is replaced
8111 -- with the generalized indexing node, which is a call, possibly with a
8112 -- dereference operation.
8114 if Comes_From_Source
(N
) then
8115 Check_Compiler_Unit
("generalized indexing", N
);
8118 -- Create argument list for function call that represents generalized
8119 -- indexing. Note that indices (i.e. actuals) may themselves be
8127 Arg
:= First
(Exprs
);
8128 while Present
(Arg
) loop
8129 New_Arg
:= Relocate_Node
(Arg
);
8131 -- The arguments can be parameter associations, in which case the
8132 -- explicit actual parameter carries the overloadings.
8134 if Nkind
(New_Arg
) /= N_Parameter_Association
then
8135 Save_Interps
(Arg
, New_Arg
);
8138 Append
(New_Arg
, Assoc
);
8143 if not Is_Overloaded
(Func_Name
) then
8144 Func
:= Entity
(Func_Name
);
8147 Make_Function_Call
(Loc
,
8148 Name
=> New_Occurrence_Of
(Func
, Loc
),
8149 Parameter_Associations
=> Assoc
);
8151 Set_Parent
(Indexing
, Parent
(N
));
8152 Set_Generalized_Indexing
(N
, Indexing
);
8154 Set_Etype
(N
, Etype
(Indexing
));
8156 -- If the return type of the indexing function is a reference type,
8157 -- add the dereference as a possible interpretation. Note that the
8158 -- indexing aspect may be a function that returns the element type
8159 -- with no intervening implicit dereference, and that the reference
8160 -- discriminant is not the first discriminant.
8162 if Has_Discriminants
(Etype
(Func
)) then
8163 Check_Implicit_Dereference
(N
, Etype
(Func
));
8167 -- If there are multiple indexing functions, build a function call
8168 -- and analyze it for each of the possible interpretations.
8171 Make_Function_Call
(Loc
,
8173 Make_Identifier
(Loc
, Chars
(Func_Name
)),
8174 Parameter_Associations
=> Assoc
);
8175 Set_Parent
(Indexing
, Parent
(N
));
8176 Set_Generalized_Indexing
(N
, Indexing
);
8177 Set_Etype
(N
, Any_Type
);
8178 Set_Etype
(Name
(Indexing
), Any_Type
);
8186 Get_First_Interp
(Func_Name
, I
, It
);
8187 Set_Etype
(Indexing
, Any_Type
);
8189 -- Analyze each candidate function with the given actuals
8191 while Present
(It
.Nam
) loop
8192 Analyze_One_Call
(Indexing
, It
.Nam
, False, Success
);
8193 Get_Next_Interp
(I
, It
);
8196 -- If there are several successful candidates, resolution will
8197 -- be by result. Mark the interpretations of the function name
8200 if Is_Overloaded
(Indexing
) then
8201 Get_First_Interp
(Indexing
, I
, It
);
8203 while Present
(It
.Nam
) loop
8204 Add_One_Interp
(Name
(Indexing
), It
.Nam
, It
.Typ
);
8205 Get_Next_Interp
(I
, It
);
8209 Set_Etype
(Name
(Indexing
), Etype
(Indexing
));
8212 -- Now add the candidate interpretations to the indexing node
8213 -- itself, to be replaced later by the function call.
8215 if Is_Overloaded
(Name
(Indexing
)) then
8216 Get_First_Interp
(Name
(Indexing
), I
, It
);
8218 while Present
(It
.Nam
) loop
8219 Add_One_Interp
(N
, It
.Nam
, It
.Typ
);
8221 -- Add dereference interpretation if the result type has
8222 -- implicit reference discriminants.
8224 if Has_Discriminants
(Etype
(It
.Nam
)) then
8225 Check_Implicit_Dereference
(N
, Etype
(It
.Nam
));
8228 Get_Next_Interp
(I
, It
);
8232 Set_Etype
(N
, Etype
(Name
(Indexing
)));
8233 if Has_Discriminants
(Etype
(N
)) then
8234 Check_Implicit_Dereference
(N
, Etype
(N
));
8240 if Etype
(Indexing
) = Any_Type
then
8242 ("container cannot be indexed with&", N
, Etype
(First
(Exprs
)));
8243 Rewrite
(N
, New_Occurrence_Of
(Any_Id
, Loc
));
8247 end Try_Container_Indexing
;
8249 -----------------------
8250 -- Try_Indirect_Call --
8251 -----------------------
8253 function Try_Indirect_Call
8256 Typ
: Entity_Id
) return Boolean
8262 pragma Warnings
(Off
, Call_OK
);
8265 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
8267 Actual
:= First_Actual
(N
);
8268 Formal
:= First_Formal
(Designated_Type
(Typ
));
8269 while Present
(Actual
) and then Present
(Formal
) loop
8270 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
8275 Next_Formal
(Formal
);
8278 if No
(Actual
) and then No
(Formal
) then
8279 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
8281 -- Nam is a candidate interpretation for the name in the call,
8282 -- if it is not an indirect call.
8284 if not Is_Type
(Nam
)
8285 and then Is_Entity_Name
(Name
(N
))
8287 Set_Entity
(Name
(N
), Nam
);
8295 end Try_Indirect_Call
;
8297 ----------------------
8298 -- Try_Indexed_Call --
8299 ----------------------
8301 function Try_Indexed_Call
8305 Skip_First
: Boolean) return Boolean
8307 Loc
: constant Source_Ptr
:= Sloc
(N
);
8308 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
8313 Actual
:= First
(Actuals
);
8315 -- If the call was originally written in prefix form, skip the first
8316 -- actual, which is obviously not defaulted.
8322 Index
:= First_Index
(Typ
);
8323 while Present
(Actual
) and then Present
(Index
) loop
8325 -- If the parameter list has a named association, the expression
8326 -- is definitely a call and not an indexed component.
8328 if Nkind
(Actual
) = N_Parameter_Association
then
8332 if Is_Entity_Name
(Actual
)
8333 and then Is_Type
(Entity
(Actual
))
8334 and then No
(Next
(Actual
))
8336 -- A single actual that is a type name indicates a slice if the
8337 -- type is discrete, and an error otherwise.
8339 if Is_Discrete_Type
(Entity
(Actual
)) then
8343 Make_Function_Call
(Loc
,
8344 Name
=> Relocate_Node
(Name
(N
))),
8346 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
8351 Error_Msg_N
("invalid use of type in expression", Actual
);
8352 Set_Etype
(N
, Any_Type
);
8357 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
8365 if No
(Actual
) and then No
(Index
) then
8366 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
8368 -- Nam is a candidate interpretation for the name in the call,
8369 -- if it is not an indirect call.
8371 if not Is_Type
(Nam
)
8372 and then Is_Entity_Name
(Name
(N
))
8374 Set_Entity
(Name
(N
), Nam
);
8381 end Try_Indexed_Call
;
8383 --------------------------
8384 -- Try_Object_Operation --
8385 --------------------------
8387 function Try_Object_Operation
8388 (N
: Node_Id
; CW_Test_Only
: Boolean := False) return Boolean
8390 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
8391 Is_Subprg_Call
: constant Boolean := K
in N_Subprogram_Call
;
8392 Loc
: constant Source_Ptr
:= Sloc
(N
);
8393 Obj
: constant Node_Id
:= Prefix
(N
);
8395 Subprog
: constant Node_Id
:=
8396 Make_Identifier
(Sloc
(Selector_Name
(N
)),
8397 Chars
=> Chars
(Selector_Name
(N
)));
8398 -- Identifier on which possible interpretations will be collected
8400 Report_Error
: Boolean := False;
8401 -- If no candidate interpretation matches the context, redo analysis
8402 -- with Report_Error True to provide additional information.
8405 Candidate
: Entity_Id
:= Empty
;
8406 New_Call_Node
: Node_Id
:= Empty
;
8407 Node_To_Replace
: Node_Id
;
8408 Obj_Type
: Entity_Id
:= Etype
(Obj
);
8409 Success
: Boolean := False;
8411 procedure Complete_Object_Operation
8412 (Call_Node
: Node_Id
;
8413 Node_To_Replace
: Node_Id
);
8414 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
8415 -- Call_Node, insert the object (or its dereference) as the first actual
8416 -- in the call, and complete the analysis of the call.
8418 procedure Report_Ambiguity
(Op
: Entity_Id
);
8419 -- If a prefixed procedure call is ambiguous, indicate whether the call
8420 -- includes an implicit dereference or an implicit 'Access.
8422 procedure Transform_Object_Operation
8423 (Call_Node
: out Node_Id
;
8424 Node_To_Replace
: out Node_Id
);
8425 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
8426 -- Call_Node is the resulting subprogram call, Node_To_Replace is
8427 -- either N or the parent of N, and Subprog is a reference to the
8428 -- subprogram we are trying to match.
8430 function Try_Class_Wide_Operation
8431 (Call_Node
: Node_Id
;
8432 Node_To_Replace
: Node_Id
) return Boolean;
8433 -- Traverse all ancestor types looking for a class-wide subprogram for
8434 -- which the current operation is a valid non-dispatching call.
8436 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
8437 -- If prefix is overloaded, its interpretation may include different
8438 -- tagged types, and we must examine the primitive operations and the
8439 -- class-wide operations of each in order to find candidate
8440 -- interpretations for the call as a whole.
8442 function Try_Primitive_Operation
8443 (Call_Node
: Node_Id
;
8444 Node_To_Replace
: Node_Id
) return Boolean;
8445 -- Traverse the list of primitive subprograms looking for a dispatching
8446 -- operation for which the current node is a valid call.
8448 function Valid_Candidate
8451 Subp
: Entity_Id
) return Entity_Id
;
8452 -- If the subprogram is a valid interpretation, record it, and add to
8453 -- the list of interpretations of Subprog. Otherwise return Empty.
8455 -------------------------------
8456 -- Complete_Object_Operation --
8457 -------------------------------
8459 procedure Complete_Object_Operation
8460 (Call_Node
: Node_Id
;
8461 Node_To_Replace
: Node_Id
)
8463 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
8464 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
8465 First_Actual
: Node_Id
;
8468 -- Place the name of the operation, with its interpretations,
8469 -- on the rewritten call.
8471 Set_Name
(Call_Node
, Subprog
);
8473 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
8475 -- For cross-reference purposes, treat the new node as being in the
8476 -- source if the original one is. Set entity and type, even though
8477 -- they may be overwritten during resolution if overloaded.
8479 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
8480 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
8482 if Nkind
(N
) = N_Selected_Component
8483 and then not Inside_A_Generic
8485 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
8486 Set_Etype
(Selector_Name
(N
), Etype
(Entity
(Subprog
)));
8489 -- If need be, rewrite first actual as an explicit dereference. If
8490 -- the call is overloaded, the rewriting can only be done once the
8491 -- primitive operation is identified.
8493 if Is_Overloaded
(Subprog
) then
8495 -- The prefix itself may be overloaded, and its interpretations
8496 -- must be propagated to the new actual in the call.
8498 if Is_Overloaded
(Obj
) then
8499 Save_Interps
(Obj
, First_Actual
);
8502 Rewrite
(First_Actual
, Obj
);
8504 elsif not Is_Access_Type
(Formal_Type
)
8505 and then Is_Access_Type
(Etype
(Obj
))
8507 Rewrite
(First_Actual
,
8508 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
8509 Analyze
(First_Actual
);
8511 -- If we need to introduce an explicit dereference, verify that
8512 -- the resulting actual is compatible with the mode of the formal.
8514 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
8515 and then Is_Access_Constant
(Etype
(Obj
))
8518 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
8521 -- Conversely, if the formal is an access parameter and the object
8522 -- is not, replace the actual with a 'Access reference. Its analysis
8523 -- will check that the object is aliased.
8525 elsif Is_Access_Type
(Formal_Type
)
8526 and then not Is_Access_Type
(Etype
(Obj
))
8528 -- A special case: A.all'access is illegal if A is an access to a
8529 -- constant and the context requires an access to a variable.
8531 if not Is_Access_Constant
(Formal_Type
) then
8532 if (Nkind
(Obj
) = N_Explicit_Dereference
8533 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
8534 or else not Is_Variable
(Obj
)
8537 ("actual for & must be a variable", Obj
, Control
);
8541 Rewrite
(First_Actual
,
8542 Make_Attribute_Reference
(Loc
,
8543 Attribute_Name
=> Name_Access
,
8544 Prefix
=> Relocate_Node
(Obj
)));
8546 -- If the object is not overloaded verify that taking access of
8547 -- it is legal. Otherwise check is made during resolution.
8549 if not Is_Overloaded
(Obj
)
8550 and then not Is_Aliased_View
(Obj
)
8553 ("object in prefixed call to & must be aliased "
8554 & "(RM 4.1.3 (13 1/2))", Prefix
(First_Actual
), Subprog
);
8557 Analyze
(First_Actual
);
8560 if Is_Overloaded
(Obj
) then
8561 Save_Interps
(Obj
, First_Actual
);
8564 Rewrite
(First_Actual
, Obj
);
8567 -- The operation is obtained from the dispatch table and not by
8568 -- visibility, and may be declared in a unit that is not explicitly
8569 -- referenced in the source, but is nevertheless required in the
8570 -- context of the current unit. Indicate that operation and its scope
8571 -- are referenced, to prevent spurious and misleading warnings. If
8572 -- the operation is overloaded, all primitives are in the same scope
8573 -- and we can use any of them.
8575 Set_Referenced
(Entity
(Subprog
), True);
8576 Set_Referenced
(Scope
(Entity
(Subprog
)), True);
8578 Rewrite
(Node_To_Replace
, Call_Node
);
8580 -- Propagate the interpretations collected in subprog to the new
8581 -- function call node, to be resolved from context.
8583 if Is_Overloaded
(Subprog
) then
8584 Save_Interps
(Subprog
, Node_To_Replace
);
8587 -- The type of the subprogram may be a limited view obtained
8588 -- transitively from another unit. If full view is available,
8589 -- use it to analyze call.
8592 T
: constant Entity_Id
:= Etype
(Subprog
);
8594 if From_Limited_With
(T
) then
8595 Set_Etype
(Entity
(Subprog
), Available_View
(T
));
8599 Analyze
(Node_To_Replace
);
8601 -- If the operation has been rewritten into a call, which may get
8602 -- subsequently an explicit dereference, preserve the type on the
8603 -- original node (selected component or indexed component) for
8604 -- subsequent legality tests, e.g. Is_Variable. which examines
8605 -- the original node.
8607 if Nkind
(Node_To_Replace
) = N_Function_Call
then
8609 (Original_Node
(Node_To_Replace
), Etype
(Node_To_Replace
));
8612 end Complete_Object_Operation
;
8614 ----------------------
8615 -- Report_Ambiguity --
8616 ----------------------
8618 procedure Report_Ambiguity
(Op
: Entity_Id
) is
8619 Access_Actual
: constant Boolean :=
8620 Is_Access_Type
(Etype
(Prefix
(N
)));
8621 Access_Formal
: Boolean := False;
8624 Error_Msg_Sloc
:= Sloc
(Op
);
8626 if Present
(First_Formal
(Op
)) then
8627 Access_Formal
:= Is_Access_Type
(Etype
(First_Formal
(Op
)));
8630 if Access_Formal
and then not Access_Actual
then
8631 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
8633 ("\possible interpretation "
8634 & "(inherited, with implicit 'Access) #", N
);
8637 ("\possible interpretation (with implicit 'Access) #", N
);
8640 elsif not Access_Formal
and then Access_Actual
then
8641 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
8643 ("\possible interpretation "
8644 & "(inherited, with implicit dereference) #", N
);
8647 ("\possible interpretation (with implicit dereference) #", N
);
8651 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
8652 Error_Msg_N
("\possible interpretation (inherited)#", N
);
8654 Error_Msg_N
-- CODEFIX
8655 ("\possible interpretation#", N
);
8658 end Report_Ambiguity
;
8660 --------------------------------
8661 -- Transform_Object_Operation --
8662 --------------------------------
8664 procedure Transform_Object_Operation
8665 (Call_Node
: out Node_Id
;
8666 Node_To_Replace
: out Node_Id
)
8668 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
8669 -- Placeholder used as a first parameter in the call, replaced
8670 -- eventually by the proper object.
8672 Parent_Node
: constant Node_Id
:= Parent
(N
);
8678 -- Obj may already have been rewritten if it involves an implicit
8679 -- dereference (e.g. if it is an access to a limited view). Preserve
8680 -- a link to the original node for ASIS use.
8682 if not Comes_From_Source
(Obj
) then
8683 Set_Original_Node
(Dummy
, Original_Node
(Obj
));
8686 -- Common case covering 1) Call to a procedure and 2) Call to a
8687 -- function that has some additional actuals.
8689 if Nkind
(Parent_Node
) in N_Subprogram_Call
8691 -- N is a selected component node containing the name of the
8692 -- subprogram. If N is not the name of the parent node we must
8693 -- not replace the parent node by the new construct. This case
8694 -- occurs when N is a parameterless call to a subprogram that
8695 -- is an actual parameter of a call to another subprogram. For
8697 -- Some_Subprogram (..., Obj.Operation, ...)
8699 and then Name
(Parent_Node
) = N
8701 Node_To_Replace
:= Parent_Node
;
8703 Actuals
:= Parameter_Associations
(Parent_Node
);
8705 if Present
(Actuals
) then
8706 Prepend
(Dummy
, Actuals
);
8708 Actuals
:= New_List
(Dummy
);
8711 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
8713 Make_Procedure_Call_Statement
(Loc
,
8714 Name
=> New_Copy
(Subprog
),
8715 Parameter_Associations
=> Actuals
);
8719 Make_Function_Call
(Loc
,
8720 Name
=> New_Copy
(Subprog
),
8721 Parameter_Associations
=> Actuals
);
8724 -- Before analysis, a function call appears as an indexed component
8725 -- if there are no named associations.
8727 elsif Nkind
(Parent_Node
) = N_Indexed_Component
8728 and then N
= Prefix
(Parent_Node
)
8730 Node_To_Replace
:= Parent_Node
;
8731 Actuals
:= Expressions
(Parent_Node
);
8733 Actual
:= First
(Actuals
);
8734 while Present
(Actual
) loop
8739 Prepend
(Dummy
, Actuals
);
8742 Make_Function_Call
(Loc
,
8743 Name
=> New_Copy
(Subprog
),
8744 Parameter_Associations
=> Actuals
);
8746 -- Parameterless call: Obj.F is rewritten as F (Obj)
8749 Node_To_Replace
:= N
;
8752 Make_Function_Call
(Loc
,
8753 Name
=> New_Copy
(Subprog
),
8754 Parameter_Associations
=> New_List
(Dummy
));
8756 end Transform_Object_Operation
;
8758 ------------------------------
8759 -- Try_Class_Wide_Operation --
8760 ------------------------------
8762 function Try_Class_Wide_Operation
8763 (Call_Node
: Node_Id
;
8764 Node_To_Replace
: Node_Id
) return Boolean
8766 Anc_Type
: Entity_Id
;
8767 Matching_Op
: Entity_Id
:= Empty
;
8770 procedure Traverse_Homonyms
8771 (Anc_Type
: Entity_Id
;
8772 Error
: out Boolean);
8773 -- Traverse the homonym chain of the subprogram searching for those
8774 -- homonyms whose first formal has the Anc_Type's class-wide type,
8775 -- or an anonymous access type designating the class-wide type. If
8776 -- an ambiguity is detected, then Error is set to True.
8778 procedure Traverse_Interfaces
8779 (Anc_Type
: Entity_Id
;
8780 Error
: out Boolean);
8781 -- Traverse the list of interfaces, if any, associated with Anc_Type
8782 -- and search for acceptable class-wide homonyms associated with each
8783 -- interface. If an ambiguity is detected, then Error is set to True.
8785 -----------------------
8786 -- Traverse_Homonyms --
8787 -----------------------
8789 procedure Traverse_Homonyms
8790 (Anc_Type
: Entity_Id
;
8791 Error
: out Boolean)
8793 Cls_Type
: Entity_Id
;
8801 Cls_Type
:= Class_Wide_Type
(Anc_Type
);
8803 Hom
:= Current_Entity
(Subprog
);
8805 -- Find a non-hidden operation whose first parameter is of the
8806 -- class-wide type, a subtype thereof, or an anonymous access
8807 -- to same. If in an instance, the operation can be considered
8808 -- even if hidden (it may be hidden because the instantiation
8809 -- is expanded after the containing package has been analyzed).
8811 while Present
(Hom
) loop
8812 if Ekind_In
(Hom
, E_Procedure
, E_Function
)
8813 and then (not Is_Hidden
(Hom
) or else In_Instance
)
8814 and then Scope
(Hom
) = Scope
(Anc_Type
)
8815 and then Present
(First_Formal
(Hom
))
8817 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
8819 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
8821 Ekind
(Etype
(First_Formal
(Hom
))) =
8822 E_Anonymous_Access_Type
8825 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
8828 -- If the context is a procedure call, ignore functions
8829 -- in the name of the call.
8831 if Ekind
(Hom
) = E_Function
8832 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
8833 and then N
= Name
(Parent
(N
))
8837 -- If the context is a function call, ignore procedures
8838 -- in the name of the call.
8840 elsif Ekind
(Hom
) = E_Procedure
8841 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
8846 Set_Etype
(Call_Node
, Any_Type
);
8847 Set_Is_Overloaded
(Call_Node
, False);
8850 if No
(Matching_Op
) then
8851 Hom_Ref
:= New_Occurrence_Of
(Hom
, Sloc
(Subprog
));
8852 Set_Etype
(Call_Node
, Any_Type
);
8853 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
8855 Set_Name
(Call_Node
, Hom_Ref
);
8860 Report
=> Report_Error
,
8862 Skip_First
=> True);
8865 Valid_Candidate
(Success
, Call_Node
, Hom
);
8871 Report
=> Report_Error
,
8873 Skip_First
=> True);
8875 if Present
(Valid_Candidate
(Success
, Call_Node
, Hom
))
8876 and then Nkind
(Call_Node
) /= N_Function_Call
8878 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
8879 Report_Ambiguity
(Matching_Op
);
8880 Report_Ambiguity
(Hom
);
8888 Hom
:= Homonym
(Hom
);
8890 end Traverse_Homonyms
;
8892 -------------------------
8893 -- Traverse_Interfaces --
8894 -------------------------
8896 procedure Traverse_Interfaces
8897 (Anc_Type
: Entity_Id
;
8898 Error
: out Boolean)
8900 Intface_List
: constant List_Id
:=
8901 Abstract_Interface_List
(Anc_Type
);
8907 if Is_Non_Empty_List
(Intface_List
) then
8908 Intface
:= First
(Intface_List
);
8909 while Present
(Intface
) loop
8911 -- Look for acceptable class-wide homonyms associated with
8914 Traverse_Homonyms
(Etype
(Intface
), Error
);
8920 -- Continue the search by looking at each of the interface's
8921 -- associated interface ancestors.
8923 Traverse_Interfaces
(Etype
(Intface
), Error
);
8932 end Traverse_Interfaces
;
8934 -- Start of processing for Try_Class_Wide_Operation
8937 -- If we are searching only for conflicting class-wide subprograms
8938 -- then initialize directly Matching_Op with the target entity.
8940 if CW_Test_Only
then
8941 Matching_Op
:= Entity
(Selector_Name
(N
));
8944 -- Loop through ancestor types (including interfaces), traversing
8945 -- the homonym chain of the subprogram, trying out those homonyms
8946 -- whose first formal has the class-wide type of the ancestor, or
8947 -- an anonymous access type designating the class-wide type.
8949 Anc_Type
:= Obj_Type
;
8951 -- Look for a match among homonyms associated with the ancestor
8953 Traverse_Homonyms
(Anc_Type
, Error
);
8959 -- Continue the search for matches among homonyms associated with
8960 -- any interfaces implemented by the ancestor.
8962 Traverse_Interfaces
(Anc_Type
, Error
);
8968 exit when Etype
(Anc_Type
) = Anc_Type
;
8969 Anc_Type
:= Etype
(Anc_Type
);
8972 if Present
(Matching_Op
) then
8973 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
8976 return Present
(Matching_Op
);
8977 end Try_Class_Wide_Operation
;
8979 -----------------------------------
8980 -- Try_One_Prefix_Interpretation --
8981 -----------------------------------
8983 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
8984 Prev_Obj_Type
: constant Entity_Id
:= Obj_Type
;
8985 -- If the interpretation does not have a valid candidate type,
8986 -- preserve current value of Obj_Type for subsequent errors.
8991 if Is_Access_Type
(Obj_Type
) then
8992 Obj_Type
:= Designated_Type
(Obj_Type
);
8995 if Ekind_In
(Obj_Type
, E_Private_Subtype
,
8996 E_Record_Subtype_With_Private
)
8998 Obj_Type
:= Base_Type
(Obj_Type
);
9001 if Is_Class_Wide_Type
(Obj_Type
) then
9002 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
9005 -- The type may have be obtained through a limited_with clause,
9006 -- in which case the primitive operations are available on its
9007 -- non-limited view. If still incomplete, retrieve full view.
9009 if Ekind
(Obj_Type
) = E_Incomplete_Type
9010 and then From_Limited_With
(Obj_Type
)
9011 and then Has_Non_Limited_View
(Obj_Type
)
9013 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
9016 -- If the object is not tagged, or the type is still an incomplete
9017 -- type, this is not a prefixed call. Restore the previous type as
9018 -- the current one is not a legal candidate.
9020 if not Is_Tagged_Type
(Obj_Type
)
9021 or else Is_Incomplete_Type
(Obj_Type
)
9023 Obj_Type
:= Prev_Obj_Type
;
9028 Dup_Call_Node
: constant Node_Id
:= New_Copy
(New_Call_Node
);
9029 CW_Result
: Boolean;
9030 Prim_Result
: Boolean;
9031 pragma Unreferenced
(CW_Result
);
9034 if not CW_Test_Only
then
9036 Try_Primitive_Operation
9037 (Call_Node
=> New_Call_Node
,
9038 Node_To_Replace
=> Node_To_Replace
);
9041 -- Check if there is a class-wide subprogram covering the
9042 -- primitive. This check must be done even if a candidate
9043 -- was found in order to report ambiguous calls.
9045 if not Prim_Result
then
9047 Try_Class_Wide_Operation
9048 (Call_Node
=> New_Call_Node
,
9049 Node_To_Replace
=> Node_To_Replace
);
9051 -- If we found a primitive we search for class-wide subprograms
9052 -- using a duplicate of the call node (done to avoid missing its
9053 -- decoration if there is no ambiguity).
9057 Try_Class_Wide_Operation
9058 (Call_Node
=> Dup_Call_Node
,
9059 Node_To_Replace
=> Node_To_Replace
);
9062 end Try_One_Prefix_Interpretation
;
9064 -----------------------------
9065 -- Try_Primitive_Operation --
9066 -----------------------------
9068 function Try_Primitive_Operation
9069 (Call_Node
: Node_Id
;
9070 Node_To_Replace
: Node_Id
) return Boolean
9073 Prim_Op
: Entity_Id
;
9074 Matching_Op
: Entity_Id
:= Empty
;
9075 Prim_Op_Ref
: Node_Id
:= Empty
;
9077 Corr_Type
: Entity_Id
:= Empty
;
9078 -- If the prefix is a synchronized type, the controlling type of
9079 -- the primitive operation is the corresponding record type, else
9080 -- this is the object type itself.
9082 Success
: Boolean := False;
9084 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
9085 -- For tagged types the candidate interpretations are found in
9086 -- the list of primitive operations of the type and its ancestors.
9087 -- For formal tagged types we have to find the operations declared
9088 -- in the same scope as the type (including in the generic formal
9089 -- part) because the type itself carries no primitive operations,
9090 -- except for formal derived types that inherit the operations of
9091 -- the parent and progenitors.
9093 -- If the context is a generic subprogram body, the generic formals
9094 -- are visible by name, but are not in the entity list of the
9095 -- subprogram because that list starts with the subprogram formals.
9096 -- We retrieve the candidate operations from the generic declaration.
9098 function Extended_Primitive_Ops
(T
: Entity_Id
) return Elist_Id
;
9099 -- Prefix notation can also be used on operations that are not
9100 -- primitives of the type, but are declared in the same immediate
9101 -- declarative part, which can only mean the corresponding package
9102 -- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the
9103 -- list of primitives with body operations with the same name that
9104 -- may be candidates, so that Try_Primitive_Operations can examine
9105 -- them if no real primitive is found.
9107 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
9108 -- An operation that overrides an inherited operation in the private
9109 -- part of its package may be hidden, but if the inherited operation
9110 -- is visible a direct call to it will dispatch to the private one,
9111 -- which is therefore a valid candidate.
9113 function Names_Match
9114 (Obj_Type
: Entity_Id
;
9115 Prim_Op
: Entity_Id
;
9116 Subprog
: Entity_Id
) return Boolean;
9117 -- Return True if the names of Prim_Op and Subprog match. If Obj_Type
9118 -- is a protected type then compare also the original name of Prim_Op
9119 -- with the name of Subprog (since the expander may have added a
9120 -- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
9122 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
9123 -- Verify that the prefix, dereferenced if need be, is a valid
9124 -- controlling argument in a call to Op. The remaining actuals
9125 -- are checked in the subsequent call to Analyze_One_Call.
9127 ------------------------------
9128 -- Collect_Generic_Type_Ops --
9129 ------------------------------
9131 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
9132 Bas
: constant Entity_Id
:= Base_Type
(T
);
9133 Candidates
: constant Elist_Id
:= New_Elmt_List
;
9137 procedure Check_Candidate
;
9138 -- The operation is a candidate if its first parameter is a
9139 -- controlling operand of the desired type.
9141 -----------------------
9142 -- Check_Candidate; --
9143 -----------------------
9145 procedure Check_Candidate
is
9147 Formal
:= First_Formal
(Subp
);
9150 and then Is_Controlling_Formal
(Formal
)
9152 (Base_Type
(Etype
(Formal
)) = Bas
9154 (Is_Access_Type
(Etype
(Formal
))
9155 and then Designated_Type
(Etype
(Formal
)) = Bas
))
9157 Append_Elmt
(Subp
, Candidates
);
9159 end Check_Candidate
;
9161 -- Start of processing for Collect_Generic_Type_Ops
9164 if Is_Derived_Type
(T
) then
9165 return Primitive_Operations
(T
);
9167 elsif Ekind_In
(Scope
(T
), E_Procedure
, E_Function
) then
9169 -- Scan the list of generic formals to find subprograms
9170 -- that may have a first controlling formal of the type.
9172 if Nkind
(Unit_Declaration_Node
(Scope
(T
))) =
9173 N_Generic_Subprogram_Declaration
9180 First
(Generic_Formal_Declarations
9181 (Unit_Declaration_Node
(Scope
(T
))));
9182 while Present
(Decl
) loop
9183 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
9184 Subp
:= Defining_Entity
(Decl
);
9195 -- Scan the list of entities declared in the same scope as
9196 -- the type. In general this will be an open scope, given that
9197 -- the call we are analyzing can only appear within a generic
9198 -- declaration or body (either the one that declares T, or a
9201 -- For a subtype representing a generic actual type, go to the
9204 if Is_Generic_Actual_Type
(T
) then
9205 Subp
:= First_Entity
(Scope
(Base_Type
(T
)));
9207 Subp
:= First_Entity
(Scope
(T
));
9210 while Present
(Subp
) loop
9211 if Is_Overloadable
(Subp
) then
9220 end Collect_Generic_Type_Ops
;
9222 ----------------------------
9223 -- Extended_Primitive_Ops --
9224 ----------------------------
9226 function Extended_Primitive_Ops
(T
: Entity_Id
) return Elist_Id
is
9227 Type_Scope
: constant Entity_Id
:= Scope
(T
);
9229 Body_Decls
: List_Id
;
9235 Op_List
:= Primitive_Operations
(T
);
9237 if Ekind
(Type_Scope
) = E_Package
9238 and then In_Package_Body
(Type_Scope
)
9239 and then In_Open_Scopes
(Type_Scope
)
9241 -- Retrieve list of declarations of package body.
9245 (Unit_Declaration_Node
9247 (Unit_Declaration_Node
(Type_Scope
))));
9249 Op
:= Current_Entity
(Subprog
);
9251 while Present
(Op
) loop
9252 if Comes_From_Source
(Op
)
9253 and then Is_Overloadable
(Op
)
9255 -- Exclude overriding primitive operations of a type
9256 -- extension declared in the package body, to prevent
9257 -- duplicates in extended list.
9259 and then not Is_Primitive
(Op
)
9260 and then Is_List_Member
(Unit_Declaration_Node
(Op
))
9261 and then List_Containing
(Unit_Declaration_Node
(Op
)) =
9264 if not Op_Found
then
9266 -- Copy list of primitives so it is not affected for
9269 Op_List
:= New_Copy_Elist
(Op_List
);
9273 Append_Elmt
(Op
, Op_List
);
9281 end Extended_Primitive_Ops
;
9283 ---------------------------
9284 -- Is_Private_Overriding --
9285 ---------------------------
9287 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
9288 Visible_Op
: constant Entity_Id
:= Homonym
(Op
);
9291 return Present
(Visible_Op
)
9292 and then Scope
(Op
) = Scope
(Visible_Op
)
9293 and then not Comes_From_Source
(Visible_Op
)
9294 and then Alias
(Visible_Op
) = Op
9295 and then not Is_Hidden
(Visible_Op
);
9296 end Is_Private_Overriding
;
9302 function Names_Match
9303 (Obj_Type
: Entity_Id
;
9304 Prim_Op
: Entity_Id
;
9305 Subprog
: Entity_Id
) return Boolean is
9307 -- Common case: exact match
9309 if Chars
(Prim_Op
) = Chars
(Subprog
) then
9312 -- For protected type primitives the expander may have built the
9313 -- name of the dispatching primitive prepending the type name to
9314 -- avoid conflicts with the name of the protected subprogram (see
9315 -- Exp_Ch9.Build_Selected_Name).
9317 elsif Is_Protected_Type
(Obj_Type
) then
9319 Present
(Original_Protected_Subprogram
(Prim_Op
))
9320 and then Chars
(Original_Protected_Subprogram
(Prim_Op
)) =
9327 -----------------------------
9328 -- Valid_First_Argument_Of --
9329 -----------------------------
9331 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
9332 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
9335 if Is_Concurrent_Type
(Typ
)
9336 and then Present
(Corresponding_Record_Type
(Typ
))
9338 Typ
:= Corresponding_Record_Type
(Typ
);
9341 -- Simple case. Object may be a subtype of the tagged type or may
9342 -- be the corresponding record of a synchronized type.
9344 return Obj_Type
= Typ
9345 or else Base_Type
(Obj_Type
) = Typ
9346 or else Corr_Type
= Typ
9348 -- Object may be of a derived type whose parent has unknown
9349 -- discriminants, in which case the type matches the underlying
9350 -- record view of its base.
9353 (Has_Unknown_Discriminants
(Typ
)
9354 and then Typ
= Underlying_Record_View
(Base_Type
(Obj_Type
)))
9356 -- Prefix can be dereferenced
9359 (Is_Access_Type
(Corr_Type
)
9360 and then Designated_Type
(Corr_Type
) = Typ
)
9362 -- Formal is an access parameter, for which the object can
9363 -- provide an access.
9366 (Ekind
(Typ
) = E_Anonymous_Access_Type
9368 Base_Type
(Designated_Type
(Typ
)) = Base_Type
(Corr_Type
));
9369 end Valid_First_Argument_Of
;
9371 -- Start of processing for Try_Primitive_Operation
9374 -- Look for subprograms in the list of primitive operations. The name
9375 -- must be identical, and the kind of call indicates the expected
9376 -- kind of operation (function or procedure). If the type is a
9377 -- (tagged) synchronized type, the primitive ops are attached to the
9378 -- corresponding record (base) type.
9380 if Is_Concurrent_Type
(Obj_Type
) then
9381 if Present
(Corresponding_Record_Type
(Obj_Type
)) then
9382 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
9383 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
9385 Corr_Type
:= Obj_Type
;
9386 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
9389 elsif not Is_Generic_Type
(Obj_Type
) then
9390 Corr_Type
:= Obj_Type
;
9391 Elmt
:= First_Elmt
(Extended_Primitive_Ops
(Obj_Type
));
9394 Corr_Type
:= Obj_Type
;
9395 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
9398 while Present
(Elmt
) loop
9399 Prim_Op
:= Node
(Elmt
);
9401 if Names_Match
(Obj_Type
, Prim_Op
, Subprog
)
9402 and then Present
(First_Formal
(Prim_Op
))
9403 and then Valid_First_Argument_Of
(Prim_Op
)
9405 (Nkind
(Call_Node
) = N_Function_Call
)
9407 (Ekind
(Prim_Op
) = E_Function
)
9409 -- Ada 2005 (AI-251): If this primitive operation corresponds
9410 -- to an immediate ancestor interface there is no need to add
9411 -- it to the list of interpretations; the corresponding aliased
9412 -- primitive is also in this list of primitive operations and
9413 -- will be used instead.
9415 if (Present
(Interface_Alias
(Prim_Op
))
9416 and then Is_Ancestor
(Find_Dispatching_Type
9417 (Alias
(Prim_Op
)), Corr_Type
))
9419 -- Do not consider hidden primitives unless the type is in an
9420 -- open scope or we are within an instance, where visibility
9421 -- is known to be correct, or else if this is an overriding
9422 -- operation in the private part for an inherited operation.
9424 or else (Is_Hidden
(Prim_Op
)
9425 and then not Is_Immediately_Visible
(Obj_Type
)
9426 and then not In_Instance
9427 and then not Is_Private_Overriding
(Prim_Op
))
9432 Set_Etype
(Call_Node
, Any_Type
);
9433 Set_Is_Overloaded
(Call_Node
, False);
9435 if No
(Matching_Op
) then
9436 Prim_Op_Ref
:= New_Occurrence_Of
(Prim_Op
, Sloc
(Subprog
));
9437 Candidate
:= Prim_Op
;
9439 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
9441 Set_Name
(Call_Node
, Prim_Op_Ref
);
9447 Report
=> Report_Error
,
9449 Skip_First
=> True);
9451 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
9453 -- More than one interpretation, collect for subsequent
9454 -- disambiguation. If this is a procedure call and there
9455 -- is another match, report ambiguity now.
9461 Report
=> Report_Error
,
9463 Skip_First
=> True);
9465 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
9466 and then Nkind
(Call_Node
) /= N_Function_Call
9468 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
9469 Report_Ambiguity
(Matching_Op
);
9470 Report_Ambiguity
(Prim_Op
);
9480 if Present
(Matching_Op
) then
9481 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
9484 return Present
(Matching_Op
);
9485 end Try_Primitive_Operation
;
9487 ---------------------
9488 -- Valid_Candidate --
9489 ---------------------
9491 function Valid_Candidate
9494 Subp
: Entity_Id
) return Entity_Id
9496 Arr_Type
: Entity_Id
;
9497 Comp_Type
: Entity_Id
;
9500 -- If the subprogram is a valid interpretation, record it in global
9501 -- variable Subprog, to collect all possible overloadings.
9504 if Subp
/= Entity
(Subprog
) then
9505 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
9509 -- If the call may be an indexed call, retrieve component type of
9510 -- resulting expression, and add possible interpretation.
9515 if Nkind
(Call
) = N_Function_Call
9516 and then Nkind
(Parent
(N
)) = N_Indexed_Component
9517 and then Needs_One_Actual
(Subp
)
9519 if Is_Array_Type
(Etype
(Subp
)) then
9520 Arr_Type
:= Etype
(Subp
);
9522 elsif Is_Access_Type
(Etype
(Subp
))
9523 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
9525 Arr_Type
:= Designated_Type
(Etype
(Subp
));
9529 if Present
(Arr_Type
) then
9531 -- Verify that the actuals (excluding the object) match the types
9539 Actual
:= Next
(First_Actual
(Call
));
9540 Index
:= First_Index
(Arr_Type
);
9541 while Present
(Actual
) and then Present
(Index
) loop
9542 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
9547 Next_Actual
(Actual
);
9553 and then Present
(Arr_Type
)
9555 Comp_Type
:= Component_Type
(Arr_Type
);
9559 if Present
(Comp_Type
)
9560 and then Etype
(Subprog
) /= Comp_Type
9562 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
9566 if Etype
(Call
) /= Any_Type
then
9571 end Valid_Candidate
;
9573 -- Start of processing for Try_Object_Operation
9576 Analyze_Expression
(Obj
);
9578 -- Analyze the actuals if node is known to be a subprogram call
9580 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
9581 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
9582 while Present
(Actual
) loop
9583 Analyze_Expression
(Actual
);
9588 -- Build a subprogram call node, using a copy of Obj as its first
9589 -- actual. This is a placeholder, to be replaced by an explicit
9590 -- dereference when needed.
9592 Transform_Object_Operation
9593 (Call_Node
=> New_Call_Node
,
9594 Node_To_Replace
=> Node_To_Replace
);
9596 Set_Etype
(New_Call_Node
, Any_Type
);
9597 Set_Etype
(Subprog
, Any_Type
);
9598 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
9600 if not Is_Overloaded
(Obj
) then
9601 Try_One_Prefix_Interpretation
(Obj_Type
);
9608 Get_First_Interp
(Obj
, I
, It
);
9609 while Present
(It
.Nam
) loop
9610 Try_One_Prefix_Interpretation
(It
.Typ
);
9611 Get_Next_Interp
(I
, It
);
9616 if Etype
(New_Call_Node
) /= Any_Type
then
9618 -- No need to complete the tree transformations if we are only
9619 -- searching for conflicting class-wide subprograms
9621 if CW_Test_Only
then
9624 Complete_Object_Operation
9625 (Call_Node
=> New_Call_Node
,
9626 Node_To_Replace
=> Node_To_Replace
);
9630 elsif Present
(Candidate
) then
9632 -- The argument list is not type correct. Re-analyze with error
9633 -- reporting enabled, and use one of the possible candidates.
9634 -- In All_Errors_Mode, re-analyze all failed interpretations.
9636 if All_Errors_Mode
then
9637 Report_Error
:= True;
9638 if Try_Primitive_Operation
9639 (Call_Node
=> New_Call_Node
,
9640 Node_To_Replace
=> Node_To_Replace
)
9643 Try_Class_Wide_Operation
9644 (Call_Node
=> New_Call_Node
,
9645 Node_To_Replace
=> Node_To_Replace
)
9652 (N
=> New_Call_Node
,
9656 Skip_First
=> True);
9659 -- No need for further errors
9664 -- There was no candidate operation, so report it as an error
9665 -- in the caller: Analyze_Selected_Component.
9669 end Try_Object_Operation
;
9675 procedure wpo
(T
: Entity_Id
) is
9680 if not Is_Tagged_Type
(T
) then
9684 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
9685 while Present
(E
) loop
9687 Write_Int
(Int
(Op
));
9688 Write_Str
(" === ");
9689 Write_Name
(Chars
(Op
));
9691 Write_Name
(Chars
(Scope
(Op
)));