1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Util
; use Exp_Util
;
36 with Itypes
; use Itypes
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Mutably_Tagged
; use Mutably_Tagged
;
40 with Namet
; use Namet
;
41 with Namet
.Sp
; use Namet
.Sp
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Case
; use Sem_Case
;
52 with Sem_Cat
; use Sem_Cat
;
53 with Sem_Ch3
; use Sem_Ch3
;
54 with Sem_Ch6
; use Sem_Ch6
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Dim
; use Sem_Dim
;
57 with Sem_Disp
; use Sem_Disp
;
58 with Sem_Dist
; use Sem_Dist
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Type
; use Sem_Type
;
62 with Sem_Util
; use Sem_Util
;
63 with Sem_Warn
; use Sem_Warn
;
64 with Stand
; use Stand
;
65 with Sinfo
; use Sinfo
;
66 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
67 with Sinfo
.Utils
; use Sinfo
.Utils
;
68 with Snames
; use Snames
;
69 with Style
; use Style
;
70 with Tbuild
; use Tbuild
;
71 with Uintp
; use Uintp
;
72 with Warnsw
; use Warnsw
;
74 package body Sem_Ch4
is
76 -- Tables which speed up the identification of dangerous calls to Ada 2012
77 -- functions with writable actuals (AI05-0144).
79 -- The following table enumerates the Ada constructs which may evaluate in
80 -- arbitrary order. It does not cover all the language constructs which can
81 -- be evaluated in arbitrary order but the subset needed for AI05-0144.
83 Has_Arbitrary_Evaluation_Order
: constant array (Node_Kind
) of Boolean :=
85 N_Assignment_Statement
=> True,
86 N_Entry_Call_Statement
=> True,
87 N_Extension_Aggregate
=> True,
88 N_Full_Type_Declaration
=> True,
89 N_Indexed_Component
=> True,
90 N_Object_Declaration
=> True,
94 N_Array_Type_Definition
=> True,
95 N_Membership_Test
=> True,
97 N_Subprogram_Call
=> True,
100 -- The following table enumerates the nodes on which we stop climbing when
101 -- locating the outermost Ada construct that can be evaluated in arbitrary
104 Stop_Subtree_Climbing
: constant array (Node_Kind
) of Boolean :=
105 (N_Aggregate
=> True,
106 N_Assignment_Statement
=> True,
107 N_Entry_Call_Statement
=> True,
108 N_Extended_Return_Statement
=> True,
109 N_Extension_Aggregate
=> True,
110 N_Full_Type_Declaration
=> True,
111 N_Object_Declaration
=> True,
112 N_Object_Renaming_Declaration
=> True,
113 N_Package_Specification
=> True,
115 N_Procedure_Call_Statement
=> True,
116 N_Simple_Return_Statement
=> True,
117 N_Has_Condition
=> True,
120 -----------------------
121 -- Local Subprograms --
122 -----------------------
124 procedure Analyze_Concatenation_Rest
(N
: Node_Id
);
125 -- Does the "rest" of the work of Analyze_Concatenation, after the left
126 -- operand has been analyzed. See Analyze_Concatenation for details.
128 procedure Analyze_Expression
(N
: Node_Id
);
129 -- For expressions that are not names, this is just a call to analyze. If
130 -- the expression is a name, it may be a call to a parameterless function,
131 -- and if so must be converted into an explicit call node and analyzed as
132 -- such. This deproceduring must be done during the first pass of overload
133 -- resolution, because otherwise a procedure call with overloaded actuals
134 -- may fail to resolve.
136 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
);
137 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call is an
138 -- operator name or an expanded name whose selector is an operator name,
139 -- and one possible interpretation is as a predefined operator.
141 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
);
142 -- If the prefix of a selected_component is overloaded, the proper
143 -- interpretation that yields a record type with the proper selector
144 -- name must be selected.
146 procedure Analyze_User_Defined_Binary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
147 -- Procedure to analyze a user defined binary operator, which is resolved
148 -- like a function, but instead of a list of actuals it is presented
149 -- with the left and right operands of an operator node.
151 procedure Analyze_User_Defined_Unary_Op
(N
: Node_Id
; Op_Id
: Entity_Id
);
152 -- Procedure to analyze a user defined unary operator, which is resolved
153 -- like a function, but instead of a list of actuals, it is presented with
154 -- the operand of the operator node.
156 procedure Analyze_One_Call
160 Success
: out Boolean;
161 Skip_First
: Boolean := False);
162 -- Check one interpretation of an overloaded subprogram name for
163 -- compatibility with the types of the actuals in a call. If there is a
164 -- single interpretation which does not match, post error if Report is
167 -- Nam is the entity that provides the formals against which the actuals
168 -- are checked. Nam is either the name of a subprogram, or the internal
169 -- subprogram type constructed for an access_to_subprogram. If the actuals
170 -- are compatible with Nam, then Nam is added to the list of candidate
171 -- interpretations for N, and Success is set to True.
173 -- The flag Skip_First is used when analyzing a call that was rewritten
174 -- from object notation. In this case the first actual may have to receive
175 -- an explicit dereference, depending on the first formal of the operation
176 -- being called. The caller will have verified that the object is legal
177 -- for the call. If the remaining parameters match, the first parameter
178 -- will rewritten as a dereference if needed, prior to completing analysis.
180 procedure Check_Misspelled_Selector
183 -- Give possible misspelling message if Sel seems likely to be a mis-
184 -- spelling of one of the selectors of the Prefix. This is called by
185 -- Analyze_Selected_Component after producing an invalid selector error
188 procedure Find_Arithmetic_Types
192 -- L and R are the operands of an arithmetic operator. Find consistent
193 -- pairs of interpretations for L and R that have a numeric type consistent
194 -- with the semantics of the operator.
196 procedure Find_Comparison_Equality_Types
200 -- L and R are operands of a comparison or equality operator. Find valid
201 -- pairs of interpretations for L and R.
203 procedure Find_Concatenation_Types
207 -- For the four varieties of concatenation
209 procedure Find_Boolean_Types
213 -- Ditto for binary logical operations
215 procedure Find_Negation_Types
219 -- Find consistent interpretation for operand of negation operator
221 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean;
222 -- Find candidate interpretations for the name Obj.Proc when it appears in
223 -- a subprogram renaming declaration.
225 procedure Find_Unary_Types
229 -- Unary arithmetic types: plus, minus, abs
231 procedure Check_Arithmetic_Pair
235 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types
236 -- for left and right operand. Determine whether they constitute a valid
237 -- pair for the given operator, and record the corresponding interpretation
238 -- of the operator node. The node N may be an operator node (the usual
239 -- case) or a function call whose prefix is an operator designator. In
240 -- both cases Op_Id is the operator name itself.
242 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
);
243 -- Give detailed information on overloaded call where none of the
244 -- interpretations match. N is the call node, Nam the designator for
245 -- the overloaded entity being called.
247 function Junk_Operand
(N
: Node_Id
) return Boolean;
248 -- Test for an operand that is an inappropriate entity (e.g. a package
249 -- name or a label). If so, issue an error message and return True. If
250 -- the operand is not an inappropriate entity kind, return False.
252 procedure Operator_Check
(N
: Node_Id
);
253 -- Verify that an operator has received some valid interpretation. If none
254 -- was found, determine whether a use clause would make the operation
255 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
256 -- every type compatible with the operator, even if the operator for the
257 -- type is not directly visible. The routine uses this type to emit a more
258 -- informative message.
260 function Has_Possible_User_Defined_Literal
(N
: Node_Id
) return Boolean;
261 -- Ada 2022: if an operand is a literal, it may be subject to an
262 -- implicit conversion to a type for which a user-defined literal
263 -- function exists. During the first pass of type resolution we do
264 -- not know the context imposed on the literal, so we assume that
265 -- the literal type is a valid candidate and rely on the second pass
266 -- of resolution to find the type with the proper aspect. We only
267 -- add this interpretation if no other one was found, which may be
268 -- too restrictive but seems sufficient to handle most proper uses
269 -- of the new aspect. It is unclear whether a full implementation of
270 -- these aspects can be achieved without larger modifications to the
271 -- two-pass resolution algorithm.
273 function Is_Effectively_Visible_Operator
274 (N
: Node_Id
; Typ
: Entity_Id
) return Boolean
275 is (Is_Visible_Operator
(N
=> N
, Typ
=> Typ
)
277 -- test for a rewritten Foo."+" call
278 (N
/= Original_Node
(N
)
279 and then Is_Effectively_Visible_Operator
280 (N
=> Original_Node
(N
), Typ
=> Typ
))
281 or else Checking_Potentially_Static_Expression
282 or else not Comes_From_Source
(N
));
283 -- Return True iff either Is_Visible_Operator returns True or if
284 -- there is a reason it is ok for Is_Visible_Operator to return False.
286 function Possible_Type_For_Conditional_Expression
287 (T1
, T2
: Entity_Id
) return Entity_Id
;
288 -- Given two types T1 and T2 that are _not_ compatible, return a type that
289 -- may still be used as the possible type of a conditional expression whose
290 -- dependent expressions, or part thereof, have type T1 and T2 respectively
291 -- during the first phase of type resolution, or Empty if such a type does
294 -- The typical example is an if_expression whose then_expression is of a
295 -- tagged type and whose else_expresssion is of an extension of this type:
296 -- the types are not compatible but such an if_expression can be legal if
297 -- its expected type is the 'Class of the tagged type, so the function will
298 -- return the tagged type in this case. If the expected type turns out to
299 -- be something else, including the tagged type itself, then an error will
300 -- be given during the second phase of type resolution.
302 procedure Remove_Abstract_Operations
(N
: Node_Id
);
303 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
304 -- operation is not a candidate interpretation.
306 function Try_Container_Indexing
309 Exprs
: List_Id
) return Boolean;
310 -- AI05-0139: Generalized indexing to support iterators over containers
311 -- ??? Need to provide a more detailed spec of what this function does
313 function Try_Indexed_Call
317 Skip_First
: Boolean) return Boolean;
318 -- If a function has defaults for all its actuals, a call to it may in fact
319 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
320 -- interpretation as an indexing, prior to analysis as a call. If both are
321 -- possible, the node is overloaded with both interpretations (same symbol
322 -- but two different types). If the call is written in prefix form, the
323 -- prefix becomes the first parameter in the call, and only the remaining
324 -- actuals must be checked for the presence of defaults.
326 function Try_Indirect_Call
329 Typ
: Entity_Id
) return Boolean;
330 -- Similarly, a function F that needs no actuals can return an access to a
331 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
332 -- the call may be overloaded with both interpretations.
334 procedure wpo
(T
: Entity_Id
);
335 pragma Warnings
(Off
, wpo
);
336 -- Used for debugging: obtain list of primitive operations even if
337 -- type is not frozen and dispatch table is not built yet.
339 ------------------------
340 -- Ambiguous_Operands --
341 ------------------------
343 procedure Ambiguous_Operands
(N
: Node_Id
) is
344 procedure List_Operand_Interps
(Opnd
: Node_Id
);
346 --------------------------
347 -- List_Operand_Interps --
348 --------------------------
350 procedure List_Operand_Interps
(Opnd
: Node_Id
) is
351 Nam
: Node_Id
:= Empty
;
355 if Is_Overloaded
(Opnd
) then
356 if Nkind
(Opnd
) in N_Op
then
359 elsif Nkind
(Opnd
) = N_Function_Call
then
362 elsif Ada_Version
>= Ada_2012
then
368 Get_First_Interp
(Opnd
, I
, It
);
369 while Present
(It
.Nam
) loop
370 if Has_Implicit_Dereference
(It
.Typ
) then
372 ("can be interpreted as implicit dereference", Opnd
);
376 Get_Next_Interp
(I
, It
);
387 if Opnd
= Left_Opnd
(N
) then
389 ("\left operand has the following interpretations", N
);
392 ("\right operand has the following interpretations", N
);
396 List_Interps
(Nam
, Err
);
397 end List_Operand_Interps
;
399 -- Start of processing for Ambiguous_Operands
402 if Nkind
(N
) in N_Membership_Test
then
403 Error_Msg_N
("ambiguous operands for membership", N
);
405 elsif Nkind
(N
) in N_Op_Eq | N_Op_Ne
then
406 Error_Msg_N
("ambiguous operands for equality", N
);
409 Error_Msg_N
("ambiguous operands for comparison", N
);
412 if All_Errors_Mode
then
413 List_Operand_Interps
(Left_Opnd
(N
));
414 List_Operand_Interps
(Right_Opnd
(N
));
416 Error_Msg_N
("\use -gnatf switch for details", N
);
418 end Ambiguous_Operands
;
420 -----------------------
421 -- Analyze_Aggregate --
422 -----------------------
424 -- Most of the analysis of Aggregates requires that the type be known, and
425 -- is therefore put off until resolution of the context. Delta aggregates
426 -- have a base component that determines the enclosing aggregate type so
427 -- its type can be ascertained earlier. This also allows delta aggregates
428 -- to appear in the context of a record type with a private extension, as
429 -- per the latest update of AI12-0127.
431 procedure Analyze_Aggregate
(N
: Node_Id
) is
433 if No
(Etype
(N
)) then
434 if Nkind
(N
) = N_Delta_Aggregate
then
436 Base
: constant Node_Id
:= Expression
(N
);
444 -- If the base is overloaded, propagate interpretations to the
445 -- enclosing aggregate.
447 if Is_Overloaded
(Base
) then
448 Get_First_Interp
(Base
, I
, It
);
449 Set_Etype
(N
, Any_Type
);
451 while Present
(It
.Nam
) loop
452 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
453 Get_Next_Interp
(I
, It
);
457 Set_Etype
(N
, Etype
(Base
));
462 Set_Etype
(N
, Any_Composite
);
465 end Analyze_Aggregate
;
467 -----------------------
468 -- Analyze_Allocator --
469 -----------------------
471 procedure Analyze_Allocator
(N
: Node_Id
) is
472 Loc
: constant Source_Ptr
:= Sloc
(N
);
473 Sav_Errs
: constant Nat
:= Serious_Errors_Detected
;
474 E
: Node_Id
:= Expression
(N
);
475 Acc_Type
: Entity_Id
;
482 -- Deal with allocator restrictions
484 -- In accordance with H.4(7), the No_Allocators restriction only applies
485 -- to user-written allocators. The same consideration applies to the
486 -- No_Standard_Allocators_Before_Elaboration restriction.
488 if Comes_From_Source
(N
) then
489 Check_Restriction
(No_Allocators
, N
);
491 -- Processing for No_Standard_Allocators_After_Elaboration, loop to
492 -- look at enclosing context, checking task/main subprogram case.
496 while Present
(P
) loop
498 -- For the task case we need a handled sequence of statements,
499 -- where the occurrence of the allocator is within the statements
500 -- and the parent is a task body
502 if Nkind
(P
) = N_Handled_Sequence_Of_Statements
503 and then Is_List_Member
(C
)
504 and then List_Containing
(C
) = Statements
(P
)
506 Onode
:= Original_Node
(Parent
(P
));
508 -- Check for allocator within task body, this is a definite
509 -- violation of No_Allocators_After_Elaboration we can detect
512 if Nkind
(Onode
) = N_Task_Body
then
514 (No_Standard_Allocators_After_Elaboration
, N
);
519 -- The other case is appearance in a subprogram body. This is
520 -- a violation if this is a library level subprogram with no
521 -- parameters. Note that this is now a static error even if the
522 -- subprogram is not the main program (this is a change, in an
523 -- earlier version only the main program was affected, and the
524 -- check had to be done in the binder).
526 if Nkind
(P
) = N_Subprogram_Body
527 and then Nkind
(Parent
(P
)) = N_Compilation_Unit
528 and then No
(Parameter_Specifications
(Specification
(P
)))
531 (No_Standard_Allocators_After_Elaboration
, N
);
539 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
540 -- any. The expected type for the name is any type. A non-overloading
541 -- rule then requires it to be of a type descended from
542 -- System.Storage_Pools.Subpools.Subpool_Handle.
544 -- This isn't exactly what the AI says, but it seems to be the right
545 -- rule. The AI should be fixed.???
548 Subpool
: constant Node_Id
:= Subpool_Handle_Name
(N
);
551 if Present
(Subpool
) then
554 if Is_Overloaded
(Subpool
) then
555 Error_Msg_N
("ambiguous subpool handle", Subpool
);
558 -- Check that Etype (Subpool) is descended from Subpool_Handle
564 -- Analyze the qualified expression or subtype indication
566 if Nkind
(E
) = N_Qualified_Expression
then
567 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
568 Set_Etype
(Acc_Type
, Acc_Type
);
569 Find_Type
(Subtype_Mark
(E
));
571 -- Analyze the qualified expression, and apply the name resolution
572 -- rule given in 4.7(3).
575 Type_Id
:= Etype
(E
);
576 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
578 -- A qualified expression requires an exact match of the type,
579 -- class-wide matching is not allowed.
581 -- if Is_Class_Wide_Type (Type_Id)
582 -- and then Base_Type
583 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
585 -- Wrong_Type (Expression (E), Type_Id);
588 -- We don't analyze the qualified expression itself because it's
589 -- part of the allocator. It is fully analyzed and resolved when
590 -- the allocator is resolved with the context type.
592 Set_Etype
(E
, Type_Id
);
594 -- Case where allocator has a subtype indication
597 -- If the allocator includes a N_Subtype_Indication then a
598 -- constraint is present, otherwise the node is a subtype mark.
599 -- Introduce an explicit subtype declaration into the tree
600 -- defining some anonymous subtype and rewrite the allocator to
601 -- use this subtype rather than the subtype indication.
603 -- It is important to introduce the explicit subtype declaration
604 -- so that the bounds of the subtype indication are attached to
605 -- the tree in case the allocator is inside a generic unit.
607 -- Finally, if there is no subtype indication and the type is
608 -- a tagged unconstrained type with discriminants, the designated
609 -- object is constrained by their default values, and it is
610 -- simplest to introduce an explicit constraint now. In some cases
611 -- this is done during expansion, but freeze actions are certain
612 -- to be emitted in the proper order if constraint is explicit.
614 if Is_Entity_Name
(E
) and then Expander_Active
then
616 Type_Id
:= Entity
(E
);
618 if Is_Tagged_Type
(Type_Id
)
619 and then Has_Defaulted_Discriminants
(Type_Id
)
620 and then not Is_Constrained
(Type_Id
)
623 Constr
: constant List_Id
:= New_List
;
624 Loc
: constant Source_Ptr
:= Sloc
(E
);
625 Discr
: Entity_Id
:= First_Discriminant
(Type_Id
);
628 while Present
(Discr
) loop
629 Append
(Discriminant_Default_Value
(Discr
), Constr
);
630 Next_Discriminant
(Discr
);
634 Make_Subtype_Indication
(Loc
,
635 Subtype_Mark
=> New_Occurrence_Of
(Type_Id
, Loc
),
637 Make_Index_Or_Discriminant_Constraint
(Loc
,
638 Constraints
=> Constr
)));
641 -- Rewrite the mutably tagged type to a non-class-wide type for
642 -- proper initialization.
644 elsif Is_Mutably_Tagged_Type
(Type_Id
) then
645 Rewrite
(E
, New_Occurrence_Of
(Etype
(Type_Id
), Loc
));
649 if Nkind
(E
) = N_Subtype_Indication
then
652 Base_Typ
: Entity_Id
;
655 -- A constraint is only allowed for a composite type in Ada
656 -- 95. In Ada 83, a constraint is also allowed for an
657 -- access-to-composite type, but the constraint is ignored.
659 Find_Type
(Subtype_Mark
(E
));
660 Base_Typ
:= Entity
(Subtype_Mark
(E
));
662 if Is_Elementary_Type
(Base_Typ
) then
663 if not (Ada_Version
= Ada_83
664 and then Is_Access_Type
(Base_Typ
))
666 Error_Msg_N
("constraint not allowed here", E
);
668 if Nkind
(Constraint
(E
)) =
669 N_Index_Or_Discriminant_Constraint
671 Error_Msg_N
-- CODEFIX
672 ("\if qualified expression was meant, " &
673 "use apostrophe", Constraint
(E
));
677 -- Get rid of the bogus constraint:
679 Rewrite
(E
, New_Copy_Tree
(Subtype_Mark
(E
)));
680 Analyze_Allocator
(N
);
684 -- In GNATprove mode we need to preserve the link between
685 -- the original subtype indication and the anonymous subtype,
686 -- to extend proofs to constrained access types. We only do
687 -- that outside of spec expressions, otherwise the declaration
688 -- cannot be inserted and analyzed. In such a case, GNATprove
689 -- later rejects the allocator as it is not used here in
690 -- a non-interfering context (SPARK 4.8(2) and 7.1.3(10)).
693 or else (GNATprove_Mode
and then not In_Spec_Expression
)
695 Def_Id
:= Make_Temporary
(Loc
, 'S');
698 Subtype_Decl
: constant Node_Id
:=
699 Make_Subtype_Declaration
(Loc
,
700 Defining_Identifier
=> Def_Id
,
701 Subtype_Indication
=> Relocate_Node
(E
));
703 Insert_Action
(E
, Subtype_Decl
);
705 -- Handle unusual case where Insert_Action does not
706 -- analyze the declaration. Subtype_Decl must be
707 -- preanalyzed before call to Process_Subtype below.
708 Preanalyze
(Subtype_Decl
);
711 if Sav_Errs
/= Serious_Errors_Detected
712 and then Nkind
(Constraint
(E
)) =
713 N_Index_Or_Discriminant_Constraint
715 Error_Msg_N
-- CODEFIX
716 ("if qualified expression was meant, use apostrophe!",
720 E
:= New_Occurrence_Of
(Def_Id
, Loc
);
721 Rewrite
(Expression
(N
), E
);
726 Type_Id
:= Process_Subtype
(E
, N
);
727 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
728 Set_Etype
(Acc_Type
, Acc_Type
);
729 Set_Directly_Designated_Type
(Acc_Type
, Type_Id
);
730 Check_Fully_Declared
(Type_Id
, N
);
732 -- Ada 2005 (AI-231): If the designated type is itself an access
733 -- type that excludes null, its default initialization will
734 -- be a null object, and we can insert an unconditional raise
735 -- before the allocator.
737 -- Ada 2012 (AI-104): A not null indication here is altogether
740 if Can_Never_Be_Null
(Type_Id
) then
741 if Expander_Active
then
742 Apply_Compile_Time_Constraint_Error
743 (N
, "null value not allowed here??", CE_Null_Not_Allowed
);
745 elsif Warn_On_Ada_2012_Compatibility
then
747 ("null value not allowed here in Ada 2012?y?", E
);
751 -- Check for missing initialization. Skip this check if the allocator
752 -- is made for a special return object or if we already had errors on
753 -- analyzing the allocator since, in that case, these are very likely
756 if not Is_Definite_Subtype
(Type_Id
)
757 and then not For_Special_Return_Object
(N
)
758 and then Serious_Errors_Detected
= Sav_Errs
760 if Is_Class_Wide_Type
(Type_Id
) then
762 ("initialization required in class-wide allocation", N
);
765 if Ada_Version
< Ada_2005
766 and then Is_Limited_Type
(Type_Id
)
768 Error_Msg_N
("unconstrained allocation not allowed", N
);
770 if Is_Array_Type
(Type_Id
) then
772 ("\constraint with array bounds required", N
);
774 elsif Has_Unknown_Discriminants
(Type_Id
) then
777 else pragma Assert
(Has_Discriminants
(Type_Id
));
779 ("\constraint with discriminant values required", N
);
782 -- Limited Ada 2005 and general nonlimited case.
783 -- This is an error, except in the case of an
784 -- uninitialized allocator that is generated
785 -- for a build-in-place function return of a
786 -- discriminated but compile-time-known-size
790 if Is_Rewrite_Substitution
(N
)
791 and then Nkind
(Original_Node
(N
)) = N_Allocator
794 Qual
: constant Node_Id
:=
795 Expression
(Original_Node
(N
));
797 (Nkind
(Qual
) = N_Qualified_Expression
);
798 Call
: constant Node_Id
:= Expression
(Qual
);
800 (Is_Expanded_Build_In_Place_Call
(Call
));
807 ("uninitialized unconstrained allocation not "
810 if Is_Array_Type
(Type_Id
) then
812 ("\qualified expression or constraint with "
813 & "array bounds required", N
);
815 elsif Has_Unknown_Discriminants
(Type_Id
) then
816 Error_Msg_N
("\qualified expression required", N
);
818 else pragma Assert
(Has_Discriminants
(Type_Id
));
820 ("\qualified expression or constraint with "
821 & "discriminant values required", N
);
829 if Is_Abstract_Type
(Type_Id
) then
830 Error_Msg_N
("cannot allocate abstract object", E
);
833 Set_Etype
(N
, Acc_Type
);
835 -- If this is an allocator for the return stack, then no restriction may
836 -- be violated since it's just a low-level access to the primary stack.
838 if Nkind
(Parent
(N
)) = N_Object_Declaration
839 and then Is_Entity_Name
(Object_Definition
(Parent
(N
)))
840 and then Is_Access_Type
(Entity
(Object_Definition
(Parent
(N
))))
843 Pool
: constant Entity_Id
:=
844 Associated_Storage_Pool
845 (Root_Type
(Entity
(Object_Definition
(Parent
(N
)))));
848 if Present
(Pool
) and then Is_RTE
(Pool
, RE_RS_Pool
) then
854 if Has_Task
(Designated_Type
(Acc_Type
)) then
855 Check_Restriction
(No_Tasking
, N
);
856 Check_Restriction
(Max_Tasks
, N
);
857 Check_Restriction
(No_Task_Allocators
, N
);
860 -- Check restriction against dynamically allocated protected objects
862 if Has_Protected
(Designated_Type
(Acc_Type
)) then
863 Check_Restriction
(No_Protected_Type_Allocators
, N
);
866 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
867 -- type is nested, and the designated type needs finalization. The rule
868 -- is conservative in that class-wide types need finalization.
870 if Needs_Finalization
(Designated_Type
(Acc_Type
))
871 and then not Is_Library_Level_Entity
(Acc_Type
)
873 Check_Restriction
(No_Nested_Finalization
, N
);
876 -- Check that an allocator of a nested access type doesn't create a
877 -- protected object when restriction No_Local_Protected_Objects applies.
879 if Has_Protected
(Designated_Type
(Acc_Type
))
880 and then not Is_Library_Level_Entity
(Acc_Type
)
882 Check_Restriction
(No_Local_Protected_Objects
, N
);
885 -- Likewise for No_Local_Timing_Events
887 if Has_Timing_Event
(Designated_Type
(Acc_Type
))
888 and then not Is_Library_Level_Entity
(Acc_Type
)
890 Check_Restriction
(No_Local_Timing_Events
, N
);
893 -- If the No_Streams restriction is set, check that the type of the
894 -- object is not, and does not contain, any subtype derived from
895 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
896 -- Has_Stream just for efficiency reasons. There is no point in
897 -- spending time on a Has_Stream check if the restriction is not set.
899 if Restriction_Check_Required
(No_Streams
) then
900 if Has_Stream
(Designated_Type
(Acc_Type
)) then
901 Check_Restriction
(No_Streams
, N
);
905 if not Is_Library_Level_Entity
(Acc_Type
) then
906 Check_Restriction
(No_Local_Allocators
, N
);
910 if Serious_Errors_Detected
> Sav_Errs
then
911 Set_Error_Posted
(N
);
912 Set_Etype
(N
, Any_Type
);
914 end Analyze_Allocator
;
916 ---------------------------
917 -- Analyze_Arithmetic_Op --
918 ---------------------------
920 procedure Analyze_Arithmetic_Op
(N
: Node_Id
) is
921 L
: constant Node_Id
:= Left_Opnd
(N
);
922 R
: constant Node_Id
:= Right_Opnd
(N
);
927 Set_Etype
(N
, Any_Type
);
928 Candidate_Type
:= Empty
;
930 Analyze_Expression
(L
);
931 Analyze_Expression
(R
);
933 -- If the entity is already set, the node is the instantiation of a
934 -- generic node with a non-local reference, or was manufactured by a
935 -- call to Make_Op_xxx. In either case the entity is known to be valid,
936 -- and we do not need to collect interpretations, instead we just get
937 -- the single possible interpretation.
939 if Present
(Entity
(N
)) then
942 if Ekind
(Op_Id
) = E_Operator
then
943 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
945 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
948 -- Entity is not already set, so we do need to collect interpretations
951 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
952 while Present
(Op_Id
) loop
953 if Ekind
(Op_Id
) = E_Operator
954 and then Present
(Next_Entity
(First_Entity
(Op_Id
)))
956 Find_Arithmetic_Types
(L
, R
, Op_Id
, N
);
958 -- The following may seem superfluous, because an operator cannot
959 -- be generic, but this ignores the cleverness of the author of
962 elsif Is_Overloadable
(Op_Id
) then
963 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
966 Op_Id
:= Homonym
(Op_Id
);
971 Check_Function_Writable_Actuals
(N
);
972 end Analyze_Arithmetic_Op
;
978 -- Function, procedure, and entry calls are checked here. The Name in
979 -- the call may be overloaded. The actuals have been analyzed and may
980 -- themselves be overloaded. On exit from this procedure, the node N
981 -- may have zero, one or more interpretations. In the first case an
982 -- error message is produced. In the last case, the node is flagged
983 -- as overloaded and the interpretations are collected in All_Interp.
985 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
986 -- the type-checking is similar to that of other calls.
988 procedure Analyze_Call
(N
: Node_Id
) is
989 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
990 Loc
: constant Source_Ptr
:= Sloc
(N
);
994 Nam_Ent
: Entity_Id
:= Empty
;
995 Success
: Boolean := False;
997 Deref
: Boolean := False;
998 -- Flag indicates whether an interpretation of the prefix is a
999 -- parameterless call that returns an access_to_subprogram.
1001 procedure Check_Writable_Actuals
(N
: Node_Id
);
1002 -- If the call has out or in-out parameters then mark its outermost
1003 -- enclosing construct as a node on which the writable actuals check
1004 -- must be performed.
1006 function Name_Denotes_Function
return Boolean;
1007 -- If the type of the name is an access to subprogram, this may be the
1008 -- type of a name, or the return type of the function being called. If
1009 -- the name is not an entity then it can denote a protected function.
1010 -- Until we distinguish Etype from Return_Type, we must use this routine
1011 -- to resolve the meaning of the name in the call.
1013 procedure No_Interpretation
;
1014 -- Output error message when no valid interpretation exists
1016 ----------------------------
1017 -- Check_Writable_Actuals --
1018 ----------------------------
1020 -- The identification of conflicts in calls to functions with writable
1021 -- actuals is performed in the analysis phase of the front end to ensure
1022 -- that it reports exactly the same errors compiling with and without
1023 -- expansion enabled. It is performed in two stages:
1025 -- 1) When a call to a function with out-mode parameters is found,
1026 -- we climb to the outermost enclosing construct that can be
1027 -- evaluated in arbitrary order and we mark it with the flag
1030 -- 2) When the analysis of the marked node is complete, we traverse
1031 -- its decorated subtree searching for conflicts (see function
1032 -- Sem_Util.Check_Function_Writable_Actuals).
1034 -- The unique exception to this general rule is for aggregates, since
1035 -- their analysis is performed by the front end in the resolution
1036 -- phase. For aggregates we do not climb to their enclosing construct:
1037 -- we restrict the analysis to the subexpressions initializing the
1038 -- aggregate components.
1040 -- This implies that the analysis of expressions containing aggregates
1041 -- is not complete, since there may be conflicts on writable actuals
1042 -- involving subexpressions of the enclosing logical or arithmetic
1043 -- expressions. However, we cannot wait and perform the analysis when
1044 -- the whole subtree is resolved, since the subtrees may be transformed,
1045 -- thus adding extra complexity and computation cost to identify and
1046 -- report exactly the same errors compiling with and without expansion
1049 procedure Check_Writable_Actuals
(N
: Node_Id
) is
1051 if Comes_From_Source
(N
)
1052 and then Present
(Get_Subprogram_Entity
(N
))
1053 and then Has_Out_Or_In_Out_Parameter
(Get_Subprogram_Entity
(N
))
1055 -- For procedures and entries there is no need to climb since
1056 -- we only need to check if the actuals of this call invoke
1057 -- functions whose out-mode parameters overlap.
1059 if Nkind
(N
) /= N_Function_Call
then
1060 Set_Check_Actuals
(N
);
1062 -- For calls to functions we climb to the outermost enclosing
1063 -- construct where the out-mode actuals of this function may
1064 -- introduce conflicts.
1068 Outermost
: Node_Id
:= Empty
; -- init to avoid warning
1072 while Present
(P
) loop
1073 -- For object declarations we can climb to the node from
1074 -- its object definition branch or from its initializing
1075 -- expression. We prefer to mark the child node as the
1076 -- outermost construct to avoid adding further complexity
1077 -- to the routine that will later take care of
1078 -- performing the writable actuals check.
1080 if Has_Arbitrary_Evaluation_Order
(Nkind
(P
))
1081 and then Nkind
(P
) not in
1082 N_Assignment_Statement | N_Object_Declaration
1087 -- Avoid climbing more than needed
1089 exit when Stop_Subtree_Climbing
(Nkind
(P
))
1090 or else (Nkind
(P
) = N_Range
1092 Nkind
(Parent
(P
)) not in N_In | N_Not_In
);
1097 Set_Check_Actuals
(Outermost
);
1101 end Check_Writable_Actuals
;
1103 ---------------------------
1104 -- Name_Denotes_Function --
1105 ---------------------------
1107 function Name_Denotes_Function
return Boolean is
1109 if Is_Entity_Name
(Nam
) then
1110 return Ekind
(Entity
(Nam
)) = E_Function
;
1111 elsif Nkind
(Nam
) = N_Selected_Component
then
1112 return Ekind
(Entity
(Selector_Name
(Nam
))) = E_Function
;
1116 end Name_Denotes_Function
;
1118 -----------------------
1119 -- No_Interpretation --
1120 -----------------------
1122 procedure No_Interpretation
is
1123 L
: constant Boolean := Is_List_Member
(N
);
1124 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
1127 -- If the node is in a list whose parent is not an expression then it
1128 -- must be an attempted procedure call.
1130 if L
and then K
not in N_Subexpr
then
1131 if Ekind
(Entity
(Nam
)) = E_Generic_Procedure
then
1133 ("must instantiate generic procedure& before call",
1136 Error_Msg_N
("procedure or entry name expected", Nam
);
1139 -- Check for tasking cases where only an entry call will do
1142 and then K
in N_Entry_Call_Alternative | N_Triggering_Alternative
1144 Error_Msg_N
("entry name expected", Nam
);
1146 -- Otherwise give general error message
1149 Error_Msg_N
("invalid prefix in call", Nam
);
1151 end No_Interpretation
;
1153 -- Start of processing for Analyze_Call
1156 -- Initialize the type of the result of the call to the error type,
1157 -- which will be reset if the type is successfully resolved.
1159 Set_Etype
(N
, Any_Type
);
1163 if not Is_Overloaded
(Nam
) then
1165 -- Only one interpretation to check
1167 if Ekind
(Etype
(Nam
)) = E_Subprogram_Type
then
1168 Nam_Ent
:= Etype
(Nam
);
1170 -- If the prefix is an access_to_subprogram, this may be an indirect
1171 -- call. This is the case if the name in the call is not an entity
1172 -- name, or if it is a function name in the context of a procedure
1173 -- call. In this latter case, we have a call to a parameterless
1174 -- function that returns a pointer_to_procedure which is the entity
1175 -- being called. Finally, F (X) may be a call to a parameterless
1176 -- function that returns a pointer to a function with parameters.
1177 -- Note that if F returns an access-to-subprogram whose designated
1178 -- type is an array, F (X) cannot be interpreted as an indirect call
1179 -- through the result of the call to F.
1181 elsif Is_Access_Subprogram_Type
(Base_Type
(Etype
(Nam
)))
1183 (not Name_Denotes_Function
1184 or else Nkind
(N
) = N_Procedure_Call_Statement
1186 (Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1187 and then Is_Entity_Name
(Nam
)
1188 and then No
(First_Formal
(Entity
(Nam
)))
1190 Is_Array_Type
(Etype
(Designated_Type
(Etype
(Nam
))))
1191 and then Present
(Actuals
)))
1193 Nam_Ent
:= Designated_Type
(Etype
(Nam
));
1194 Insert_Explicit_Dereference
(Nam
);
1196 -- Selected component case. Simple entry or protected operation,
1197 -- where the entry name is given by the selector name.
1199 elsif Nkind
(Nam
) = N_Selected_Component
then
1200 Nam_Ent
:= Entity
(Selector_Name
(Nam
));
1202 if Ekind
(Nam_Ent
) not in E_Entry
1207 Error_Msg_N
("name in call is not a callable entity", Nam
);
1208 Set_Etype
(N
, Any_Type
);
1212 -- If the name is an Indexed component, it can be a call to a member
1213 -- of an entry family. The prefix must be a selected component whose
1214 -- selector is the entry. Analyze_Procedure_Call normalizes several
1215 -- kinds of call into this form.
1217 elsif Nkind
(Nam
) = N_Indexed_Component
then
1218 if Nkind
(Prefix
(Nam
)) = N_Selected_Component
then
1219 Nam_Ent
:= Entity
(Selector_Name
(Prefix
(Nam
)));
1221 Error_Msg_N
("name in call is not a callable entity", Nam
);
1222 Set_Etype
(N
, Any_Type
);
1226 elsif not Is_Entity_Name
(Nam
) then
1227 Error_Msg_N
("name in call is not a callable entity", Nam
);
1228 Set_Etype
(N
, Any_Type
);
1232 Nam_Ent
:= Entity
(Nam
);
1234 -- If not overloadable, this may be a generalized indexing
1235 -- operation with named associations. Rewrite again as an
1236 -- indexed component and analyze as container indexing.
1238 if not Is_Overloadable
(Nam_Ent
) then
1240 (Find_Value_Of_Aspect
1241 (Etype
(Nam_Ent
), Aspect_Constant_Indexing
))
1244 Make_Indexed_Component
(Sloc
(N
),
1246 Expressions
=> Parameter_Associations
(N
)));
1248 if Try_Container_Indexing
(N
, Nam
, Expressions
(N
)) then
1262 -- Operations generated for RACW stub types are called only through
1263 -- dispatching, and can never be the static interpretation of a call.
1265 if Is_RACW_Stub_Type_Operation
(Nam_Ent
) then
1270 Analyze_One_Call
(N
, Nam_Ent
, True, Success
);
1272 -- If the nonoverloaded interpretation is a call to an abstract
1273 -- nondispatching operation, then flag an error and return.
1275 if Is_Overloadable
(Nam_Ent
)
1276 and then Is_Abstract_Subprogram
(Nam_Ent
)
1277 and then not Is_Dispatching_Operation
(Nam_Ent
)
1279 Nondispatching_Call_To_Abstract_Operation
(N
, Nam_Ent
);
1283 -- If this is an indirect call, the return type of the access_to
1284 -- subprogram may be an incomplete type. At the point of the call,
1285 -- use the full type if available, and at the same time update the
1286 -- return type of the access_to_subprogram.
1289 and then Nkind
(Nam
) = N_Explicit_Dereference
1290 and then Ekind
(Etype
(N
)) = E_Incomplete_Type
1291 and then Present
(Full_View
(Etype
(N
)))
1293 Set_Etype
(N
, Full_View
(Etype
(N
)));
1294 Set_Etype
(Nam_Ent
, Etype
(N
));
1300 -- An overloaded selected component must denote overloaded operations
1301 -- of a concurrent type. The interpretations are attached to the
1302 -- simple name of those operations.
1304 if Nkind
(Nam
) = N_Selected_Component
then
1305 Nam
:= Selector_Name
(Nam
);
1308 Get_First_Interp
(Nam
, X
, It
);
1309 while Present
(It
.Nam
) loop
1313 -- Name may be call that returns an access to subprogram, or more
1314 -- generally an overloaded expression one of whose interpretations
1315 -- yields an access to subprogram. If the name is an entity, we do
1316 -- not dereference, because the node is a call that returns the
1317 -- access type: note difference between f(x), where the call may
1318 -- return an access subprogram type, and f(x)(y), where the type
1319 -- returned by the call to f is implicitly dereferenced to analyze
1322 if Is_Access_Type
(Nam_Ent
) then
1323 Nam_Ent
:= Designated_Type
(Nam_Ent
);
1325 elsif Is_Access_Type
(Etype
(Nam_Ent
))
1327 (not Is_Entity_Name
(Nam
)
1328 or else Nkind
(N
) = N_Procedure_Call_Statement
)
1329 and then Ekind
(Designated_Type
(Etype
(Nam_Ent
)))
1332 Nam_Ent
:= Designated_Type
(Etype
(Nam_Ent
));
1334 if Is_Entity_Name
(Nam
) then
1339 -- If the call has been rewritten from a prefixed call, the first
1340 -- parameter has been analyzed, but may need a subsequent
1341 -- dereference, so skip its analysis now.
1343 if Is_Rewrite_Substitution
(N
)
1344 and then Nkind
(Original_Node
(N
)) = Nkind
(N
)
1345 and then Nkind
(Name
(N
)) /= Nkind
(Name
(Original_Node
(N
)))
1346 and then Present
(Parameter_Associations
(N
))
1347 and then Present
(Etype
(First
(Parameter_Associations
(N
))))
1350 (N
, Nam_Ent
, False, Success
, Skip_First
=> True);
1352 Analyze_One_Call
(N
, Nam_Ent
, False, Success
);
1355 -- If the interpretation succeeds, mark the proper type of the
1356 -- prefix (any valid candidate will do). If not, remove the
1357 -- candidate interpretation. If this is a parameterless call
1358 -- on an anonymous access to subprogram, X is a variable with
1359 -- an access discriminant D, the entity in the interpretation is
1360 -- D, so rewrite X as X.D.all.
1364 and then Nkind
(Parent
(N
)) /= N_Explicit_Dereference
1366 if Ekind
(It
.Nam
) = E_Discriminant
1367 and then Has_Implicit_Dereference
(It
.Nam
)
1370 Make_Explicit_Dereference
(Loc
,
1372 Make_Selected_Component
(Loc
,
1374 New_Occurrence_Of
(Entity
(Nam
), Loc
),
1376 New_Occurrence_Of
(It
.Nam
, Loc
))));
1382 Set_Entity
(Nam
, It
.Nam
);
1383 Insert_Explicit_Dereference
(Nam
);
1384 Set_Etype
(Nam
, Nam_Ent
);
1388 Set_Etype
(Nam
, It
.Typ
);
1391 elsif Nkind
(Name
(N
)) in N_Function_Call | N_Selected_Component
1396 Get_Next_Interp
(X
, It
);
1399 -- If the name is the result of a function call, it can only be a
1400 -- call to a function returning an access to subprogram. Insert
1401 -- explicit dereference.
1403 if Nkind
(Nam
) = N_Function_Call
then
1404 Insert_Explicit_Dereference
(Nam
);
1407 if Etype
(N
) = Any_Type
then
1409 -- None of the interpretations is compatible with the actuals
1411 Diagnose_Call
(N
, Nam
);
1413 -- Special checks for uninstantiated put routines
1415 if Nkind
(N
) = N_Procedure_Call_Statement
1416 and then Is_Entity_Name
(Nam
)
1417 and then Chars
(Nam
) = Name_Put
1418 and then List_Length
(Actuals
) = 1
1421 Arg
: constant Node_Id
:= First
(Actuals
);
1425 if Nkind
(Arg
) = N_Parameter_Association
then
1426 Typ
:= Etype
(Explicit_Actual_Parameter
(Arg
));
1431 if Is_Signed_Integer_Type
(Typ
) then
1433 ("possible missing instantiation of "
1434 & "'Text_'I'O.'Integer_'I'O!", Nam
);
1436 elsif Is_Modular_Integer_Type
(Typ
) then
1438 ("possible missing instantiation of "
1439 & "'Text_'I'O.'Modular_'I'O!", Nam
);
1441 elsif Is_Floating_Point_Type
(Typ
) then
1443 ("possible missing instantiation of "
1444 & "'Text_'I'O.'Float_'I'O!", Nam
);
1446 elsif Is_Ordinary_Fixed_Point_Type
(Typ
) then
1448 ("possible missing instantiation of "
1449 & "'Text_'I'O.'Fixed_'I'O!", Nam
);
1451 elsif Is_Decimal_Fixed_Point_Type
(Typ
) then
1453 ("possible missing instantiation of "
1454 & "'Text_'I'O.'Decimal_'I'O!", Nam
);
1456 elsif Is_Enumeration_Type
(Typ
) then
1458 ("possible missing instantiation of "
1459 & "'Text_'I'O.'Enumeration_'I'O!", Nam
);
1464 elsif not Is_Overloaded
(N
)
1465 and then Is_Entity_Name
(Nam
)
1467 -- Resolution yields a single interpretation. Verify that the
1468 -- reference has capitalization consistent with the declaration.
1470 Set_Entity_With_Checks
(Nam
, Entity
(Nam
));
1471 Generate_Reference
(Entity
(Nam
), Nam
);
1473 Set_Etype
(Nam
, Etype
(Entity
(Nam
)));
1475 Remove_Abstract_Operations
(N
);
1479 -- Check the accessibility level for actuals for explicitly aliased
1480 -- formals when a function call appears within a return statement.
1481 -- This is only checked if the enclosing subprogram Comes_From_Source,
1482 -- to avoid issuing errors on calls occurring in wrapper subprograms
1483 -- (for example, where the call is part of an expression of an aspect
1484 -- associated with a wrapper, such as Pre'Class).
1486 if Nkind
(N
) = N_Function_Call
1487 and then Comes_From_Source
(N
)
1488 and then Present
(Nam_Ent
)
1489 and then In_Return_Value
(N
)
1490 and then Comes_From_Source
(Current_Subprogram
)
1496 Act
:= First_Actual
(N
);
1497 Form
:= First_Formal
(Nam_Ent
);
1499 while Present
(Form
) and then Present
(Act
) loop
1500 -- Check whether the formal is aliased and if the accessibility
1501 -- level of the actual is deeper than the accessibility level
1502 -- of the enclosing subprogram to which the current return
1503 -- statement applies.
1505 -- Should we be checking Is_Entity_Name on Act? Won't this miss
1508 if Is_Explicitly_Aliased
(Form
)
1509 and then Is_Entity_Name
(Act
)
1510 and then Static_Accessibility_Level
1511 (Act
, Zero_On_Dynamic_Level
)
1512 > Subprogram_Access_Level
(Current_Subprogram
)
1514 Error_Msg_N
("actual for explicitly aliased formal is too"
1515 & " short lived", Act
);
1524 if Ada_Version
>= Ada_2012
then
1526 -- Check if the call contains a function with writable actuals
1528 Check_Writable_Actuals
(N
);
1530 -- If found and the outermost construct that can be evaluated in
1531 -- an arbitrary order is precisely this call, then check all its
1534 Check_Function_Writable_Actuals
(N
);
1536 -- The return type of the function may be incomplete. This can be
1537 -- the case if the type is a generic formal, or a limited view. It
1538 -- can also happen when the function declaration appears before the
1539 -- full view of the type (which is legal in Ada 2012) and the call
1540 -- appears in a different unit, in which case the incomplete view
1541 -- must be replaced with the full view (or the nonlimited view)
1542 -- to prevent subsequent type errors. Note that the usual install/
1543 -- removal of limited_with clauses is not sufficient to handle this
1544 -- case, because the limited view may have been captured in another
1545 -- compilation unit that defines the current function.
1547 if Is_Incomplete_Type
(Etype
(N
)) then
1548 if Present
(Full_View
(Etype
(N
))) then
1549 if Is_Entity_Name
(Nam
) then
1550 Set_Etype
(Nam
, Full_View
(Etype
(N
)));
1551 Set_Etype
(Entity
(Nam
), Full_View
(Etype
(N
)));
1554 Set_Etype
(N
, Full_View
(Etype
(N
)));
1556 -- If the call is within a thunk, the nonlimited view should be
1557 -- analyzed eventually (see also Analyze_Return_Type).
1559 elsif From_Limited_With
(Etype
(N
))
1560 and then Present
(Non_Limited_View
(Etype
(N
)))
1562 (Ekind
(Non_Limited_View
(Etype
(N
))) /= E_Incomplete_Type
1563 or else Is_Thunk
(Current_Scope
))
1565 Set_Etype
(N
, Non_Limited_View
(Etype
(N
)));
1567 -- If there is no completion for the type, this may be because
1568 -- there is only a limited view of it and there is nothing in
1569 -- the context of the current unit that has required a regular
1570 -- compilation of the unit containing the type. We recognize
1571 -- this unusual case by the fact that unit is not analyzed.
1572 -- Note that the call being analyzed is in a different unit from
1573 -- the function declaration, and nothing indicates that the type
1574 -- is a limited view.
1576 elsif Ekind
(Scope
(Etype
(N
))) = E_Package
1577 and then Present
(Limited_View
(Scope
(Etype
(N
))))
1578 and then not Analyzed
(Unit_Declaration_Node
(Scope
(Etype
(N
))))
1581 ("cannot call function that returns limited view of}",
1585 ("\there must be a regular with_clause for package & in the "
1586 & "current unit, or in some unit in its context",
1587 N
, Scope
(Etype
(N
)));
1589 Set_Etype
(N
, Any_Type
);
1595 -----------------------------
1596 -- Analyze_Case_Expression --
1597 -----------------------------
1599 procedure Analyze_Case_Expression
(N
: Node_Id
) is
1600 Expr
: constant Node_Id
:= Expression
(N
);
1601 First_Alt
: constant Node_Id
:= First
(Alternatives
(N
));
1603 First_Expr
: Node_Id
:= Empty
;
1604 -- First expression in the case where there is some type information
1605 -- available, i.e. there is not Any_Type everywhere, which can happen
1606 -- because of some error.
1608 Second_Expr
: Node_Id
:= Empty
;
1609 -- Second expression as above
1611 Wrong_Alt
: Node_Id
:= Empty
;
1612 -- For error reporting
1614 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
1615 -- Error routine invoked by the generic instantiation below when
1616 -- the case expression has a non static choice.
1618 procedure Check_Next_Expression
(T
: Entity_Id
; Alt
: Node_Id
);
1619 -- Check one interpretation of the next expression with type T
1621 procedure Check_Expression_Pair
(T1
, T2
: Entity_Id
; Alt
: Node_Id
);
1622 -- Check first expression with type T1 and next expression with type T2
1624 package Case_Choices_Analysis
is new
1625 Generic_Analyze_Choices
1626 (Process_Associated_Node
=> No_OP
);
1627 use Case_Choices_Analysis
;
1629 package Case_Choices_Checking
is new
1630 Generic_Check_Choices
1631 (Process_Empty_Choice
=> No_OP
,
1632 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
1633 Process_Associated_Node
=> No_OP
);
1634 use Case_Choices_Checking
;
1636 -----------------------------
1637 -- Non_Static_Choice_Error --
1638 -----------------------------
1640 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
1642 Flag_Non_Static_Expr
1643 ("choice given in case expression is not static!", Choice
);
1644 end Non_Static_Choice_Error
;
1646 ---------------------------
1647 -- Check_Next_Expression --
1648 ---------------------------
1650 procedure Check_Next_Expression
(T
: Entity_Id
; Alt
: Node_Id
) is
1651 Next_Expr
: constant Node_Id
:= Expression
(Alt
);
1657 if Next_Expr
= First_Expr
then
1658 Check_Next_Expression
(T
, Next
(Alt
));
1662 -- Loop through the interpretations of the next expression
1664 if not Is_Overloaded
(Next_Expr
) then
1665 Check_Expression_Pair
(T
, Etype
(Next_Expr
), Alt
);
1668 Get_First_Interp
(Next_Expr
, I
, It
);
1669 while Present
(It
.Typ
) loop
1670 Check_Expression_Pair
(T
, It
.Typ
, Alt
);
1671 Get_Next_Interp
(I
, It
);
1674 end Check_Next_Expression
;
1676 ---------------------------
1677 -- Check_Expression_Pair --
1678 ---------------------------
1680 procedure Check_Expression_Pair
(T1
, T2
: Entity_Id
; Alt
: Node_Id
) is
1681 Next_Expr
: constant Node_Id
:= Expression
(Alt
);
1686 if Covers
(T1
=> T1
, T2
=> T2
)
1687 or else Covers
(T1
=> T2
, T2
=> T1
)
1689 T
:= Specific_Type
(T1
, T2
);
1691 elsif Is_User_Defined_Literal
(First_Expr
, T2
) then
1694 elsif Is_User_Defined_Literal
(Next_Expr
, T1
) then
1698 T
:= Possible_Type_For_Conditional_Expression
(T1
, T2
);
1706 if Present
(Next
(Alt
)) then
1707 Check_Next_Expression
(T
, Next
(Alt
));
1709 Add_One_Interp
(N
, T
, T
);
1711 end Check_Expression_Pair
;
1716 Exp_Type
: Entity_Id
;
1717 Exp_Btype
: Entity_Id
;
1720 Others_Present
: Boolean;
1722 -- Start of processing for Analyze_Case_Expression
1725 Analyze_And_Resolve
(Expr
, Any_Discrete
);
1726 Check_Unset_Reference
(Expr
);
1727 Exp_Type
:= Etype
(Expr
);
1728 Exp_Btype
:= Base_Type
(Exp_Type
);
1730 Set_Etype
(N
, Any_Type
);
1733 while Present
(Alt
) loop
1734 if Error_Posted
(Expression
(Alt
)) then
1738 Analyze_Expression
(Expression
(Alt
));
1740 if Etype
(Expression
(Alt
)) /= Any_Type
then
1741 if No
(First_Expr
) then
1742 First_Expr
:= Expression
(Alt
);
1744 elsif No
(Second_Expr
) then
1745 Second_Expr
:= Expression
(Alt
);
1752 -- Get our initial type from the first expression for which we got some
1753 -- useful type information from the expression.
1755 if No
(First_Expr
) then
1759 -- The expression must be of a discrete type which must be determinable
1760 -- independently of the context in which the expression occurs, but
1761 -- using the fact that the expression must be of a discrete type.
1762 -- Moreover, the type this expression must not be a character literal
1763 -- (which is always ambiguous).
1765 -- If error already reported by Resolve, nothing more to do
1767 if Exp_Btype
= Any_Discrete
or else Exp_Btype
= Any_Type
then
1770 -- Special case message for character literal
1772 elsif Exp_Btype
= Any_Character
then
1774 ("character literal as case expression is ambiguous", Expr
);
1778 -- If the case expression is a formal object of mode in out, then
1779 -- treat it as having a nonstatic subtype by forcing use of the base
1780 -- type (which has to get passed to Check_Case_Choices below). Also
1781 -- use base type when the case expression is parenthesized.
1783 if Paren_Count
(Expr
) > 0
1784 or else (Is_Entity_Name
(Expr
)
1785 and then Ekind
(Entity
(Expr
)) = E_Generic_In_Out_Parameter
)
1787 Exp_Type
:= Exp_Btype
;
1790 -- The case expression alternatives cover the range of a static subtype
1791 -- subject to aspect Static_Predicate. Do not check the choices when the
1792 -- case expression has not been fully analyzed yet because this may lead
1795 if Is_OK_Static_Subtype
(Exp_Type
)
1796 and then Has_Static_Predicate_Aspect
(Exp_Type
)
1797 and then In_Spec_Expression
1801 -- Call Analyze_Choices and Check_Choices to do the rest of the work
1804 Analyze_Choices
(Alternatives
(N
), Exp_Type
);
1805 Check_Choices
(N
, Alternatives
(N
), Exp_Type
, Others_Present
);
1807 if Exp_Type
= Universal_Integer
and then not Others_Present
then
1809 ("case on universal integer requires OTHERS choice", Expr
);
1814 -- RM 4.5.7(10/3): If the case_expression is the operand of a type
1815 -- conversion, the type of the case_expression is the target type
1816 -- of the conversion.
1818 if Nkind
(Parent
(N
)) = N_Type_Conversion
then
1819 Set_Etype
(N
, Etype
(Parent
(N
)));
1823 -- Loop through the interpretations of the first expression and check
1824 -- the other expressions if present.
1826 if not Is_Overloaded
(First_Expr
) then
1827 if Present
(Second_Expr
) then
1828 Check_Next_Expression
(Etype
(First_Expr
), First_Alt
);
1830 Set_Etype
(N
, Etype
(First_Expr
));
1834 Get_First_Interp
(First_Expr
, I
, It
);
1835 while Present
(It
.Typ
) loop
1836 if Present
(Second_Expr
) then
1837 Check_Next_Expression
(It
.Typ
, First_Alt
);
1839 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
1842 Get_Next_Interp
(I
, It
);
1846 -- If no possible interpretation has been found, the type of the wrong
1847 -- alternative doesn't match any interpretation of the FIRST expression.
1849 if Etype
(N
) = Any_Type
and then Present
(Wrong_Alt
) then
1850 Second_Expr
:= Expression
(Wrong_Alt
);
1852 if Is_Overloaded
(First_Expr
) then
1853 if Is_Overloaded
(Second_Expr
) then
1855 ("no interpretation compatible with those of previous "
1860 ("type incompatible with interpretations of previous "
1864 ("\this alternative has}!",
1866 Etype
(Second_Expr
));
1870 if Is_Overloaded
(Second_Expr
) then
1872 ("no interpretation compatible with type of previous "
1876 ("\previous alternative has}!",
1878 Etype
(First_Expr
));
1881 ("type incompatible with that of previous alternative",
1884 ("\previous alternative has}!",
1886 Etype
(First_Expr
));
1888 ("\this alternative has}!",
1890 Etype
(Second_Expr
));
1894 end Analyze_Case_Expression
;
1896 ---------------------------
1897 -- Analyze_Concatenation --
1898 ---------------------------
1900 procedure Analyze_Concatenation
(N
: Node_Id
) is
1902 -- We wish to avoid deep recursion, because concatenations are often
1903 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1904 -- operands nonrecursively until we find something that is not a
1905 -- concatenation (A in this case), or has already been analyzed. We
1906 -- analyze that, and then walk back up the tree following Parent
1907 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1908 -- work at each level. The Parent pointers allow us to avoid recursion,
1909 -- and thus avoid running out of memory.
1915 Candidate_Type
:= Empty
;
1917 -- The following code is equivalent to:
1919 -- Set_Etype (N, Any_Type);
1920 -- Analyze_Expression (Left_Opnd (N));
1921 -- Analyze_Concatenation_Rest (N);
1923 -- where the Analyze_Expression call recurses back here if the left
1924 -- operand is a concatenation.
1926 -- Walk down left operands
1929 Set_Etype
(NN
, Any_Type
);
1930 L
:= Left_Opnd
(NN
);
1931 exit when Nkind
(L
) /= N_Op_Concat
or else Analyzed
(L
);
1935 -- Now (given the above example) NN is A&B and L is A
1937 -- First analyze L ...
1939 Analyze_Expression
(L
);
1941 -- ... then walk NN back up until we reach N (where we started), calling
1942 -- Analyze_Concatenation_Rest along the way.
1945 Analyze_Concatenation_Rest
(NN
);
1949 end Analyze_Concatenation
;
1951 --------------------------------
1952 -- Analyze_Concatenation_Rest --
1953 --------------------------------
1955 -- If the only one-dimensional array type in scope is String,
1956 -- this is the resulting type of the operation. Otherwise there
1957 -- will be a concatenation operation defined for each user-defined
1958 -- one-dimensional array.
1960 procedure Analyze_Concatenation_Rest
(N
: Node_Id
) is
1961 L
: constant Node_Id
:= Left_Opnd
(N
);
1962 R
: constant Node_Id
:= Right_Opnd
(N
);
1963 Op_Id
: Entity_Id
:= Entity
(N
);
1968 Analyze_Expression
(R
);
1970 -- If the entity is present, the node appears in an instance, and
1971 -- denotes a predefined concatenation operation. The resulting type is
1972 -- obtained from the arguments when possible. If the arguments are
1973 -- aggregates, the array type and the concatenation type must be
1976 if Present
(Op_Id
) then
1977 if Ekind
(Op_Id
) = E_Operator
then
1978 LT
:= Base_Type
(Etype
(L
));
1979 RT
:= Base_Type
(Etype
(R
));
1981 if Is_Array_Type
(LT
)
1982 and then (RT
= LT
or else RT
= Base_Type
(Component_Type
(LT
)))
1984 Add_One_Interp
(N
, Op_Id
, LT
);
1986 elsif Is_Array_Type
(RT
)
1987 and then LT
= Base_Type
(Component_Type
(RT
))
1989 Add_One_Interp
(N
, Op_Id
, RT
);
1991 -- If one operand is a string type or a user-defined array type,
1992 -- and the other is a literal, result is of the specific type.
1995 (Root_Type
(LT
) = Standard_String
1996 or else Scope
(LT
) /= Standard_Standard
)
1997 and then Etype
(R
) = Any_String
1998 and then not Is_Component_Left_Opnd
(N
)
2000 Add_One_Interp
(N
, Op_Id
, LT
);
2003 (Root_Type
(RT
) = Standard_String
2004 or else Scope
(RT
) /= Standard_Standard
)
2005 and then Etype
(L
) = Any_String
2006 and then not Is_Component_Right_Opnd
(N
)
2008 Add_One_Interp
(N
, Op_Id
, RT
);
2010 elsif not Is_Generic_Type
(Etype
(Op_Id
)) then
2011 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2014 -- Type and its operations must be visible
2016 Set_Entity
(N
, Empty
);
2017 Analyze_Concatenation
(N
);
2021 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2025 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Concat
);
2026 while Present
(Op_Id
) loop
2027 if Ekind
(Op_Id
) = E_Operator
then
2029 -- Do not consider operators declared in dead code, they
2030 -- cannot be part of the resolution.
2032 if Is_Eliminated
(Op_Id
) then
2035 Find_Concatenation_Types
(L
, R
, Op_Id
, N
);
2039 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2042 Op_Id
:= Homonym
(Op_Id
);
2047 end Analyze_Concatenation_Rest
;
2049 ------------------------------------
2050 -- Analyze_Comparison_Equality_Op --
2051 ------------------------------------
2053 procedure Analyze_Comparison_Equality_Op
(N
: Node_Id
) is
2054 Loc
: constant Source_Ptr
:= Sloc
(N
);
2055 L
: constant Node_Id
:= Left_Opnd
(N
);
2056 R
: constant Node_Id
:= Right_Opnd
(N
);
2061 Set_Etype
(N
, Any_Type
);
2062 Candidate_Type
:= Empty
;
2064 Analyze_Expression
(L
);
2065 Analyze_Expression
(R
);
2067 -- If the entity is set, the node is a generic instance with a non-local
2068 -- reference to the predefined operator or to a user-defined function.
2069 -- It can also be an inequality that is expanded into the negation of a
2070 -- call to a user-defined equality operator.
2072 -- For the predefined case, the result is Boolean, regardless of the
2073 -- type of the operands. The operands may even be limited, if they are
2074 -- generic actuals. If they are overloaded, label the operands with the
2075 -- compare type if it is present, typically because it is a global type
2076 -- in a generic instance, or with the common type that must be present,
2077 -- or with the type of the formal of the user-defined function.
2079 if Present
(Entity
(N
)) then
2080 Op_Id
:= Entity
(N
);
2082 if Ekind
(Op_Id
) = E_Operator
then
2083 Add_One_Interp
(N
, Op_Id
, Standard_Boolean
);
2085 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
2088 if Is_Overloaded
(L
) then
2089 if Ekind
(Op_Id
) = E_Operator
then
2091 (if Present
(Compare_Type
(N
))
2092 then Compare_Type
(N
)
2093 else Intersect_Types
(L
, R
)));
2095 Set_Etype
(L
, Etype
(First_Formal
(Op_Id
)));
2099 if Is_Overloaded
(R
) then
2100 if Ekind
(Op_Id
) = E_Operator
then
2102 (if Present
(Compare_Type
(N
))
2103 then Compare_Type
(N
)
2104 else Intersect_Types
(L
, R
)));
2106 Set_Etype
(R
, Etype
(Next_Formal
(First_Formal
(Op_Id
))));
2111 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
2113 while Present
(Op_Id
) loop
2114 if Ekind
(Op_Id
) = E_Operator
then
2115 Find_Comparison_Equality_Types
(L
, R
, Op_Id
, N
);
2117 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2120 Op_Id
:= Homonym
(Op_Id
);
2124 -- If there was no match and the operator is inequality, this may be
2125 -- a case where inequality has not been made explicit, as for tagged
2126 -- types. Analyze the node as the negation of an equality operation.
2127 -- This cannot be done earlier because, before analysis, we cannot rule
2128 -- out the presence of an explicit inequality.
2130 if Etype
(N
) = Any_Type
and then Nkind
(N
) = N_Op_Ne
then
2131 Op_Id
:= Get_Name_Entity_Id
(Name_Op_Eq
);
2133 while Present
(Op_Id
) loop
2134 if Ekind
(Op_Id
) = E_Operator
then
2135 Find_Comparison_Equality_Types
(L
, R
, Op_Id
, N
);
2137 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
2140 Op_Id
:= Homonym
(Op_Id
);
2143 if Etype
(N
) /= Any_Type
then
2144 Op_Id
:= Entity
(N
);
2150 Left_Opnd
=> Left_Opnd
(N
),
2151 Right_Opnd
=> Right_Opnd
(N
))));
2153 Set_Entity
(Right_Opnd
(N
), Op_Id
);
2159 Check_Function_Writable_Actuals
(N
);
2160 end Analyze_Comparison_Equality_Op
;
2162 ----------------------------------
2163 -- Analyze_Explicit_Dereference --
2164 ----------------------------------
2166 procedure Analyze_Explicit_Dereference
(N
: Node_Id
) is
2167 Loc
: constant Source_Ptr
:= Sloc
(N
);
2168 P
: constant Node_Id
:= Prefix
(N
);
2174 function Is_Function_Type
return Boolean;
2175 -- Check whether node may be interpreted as an implicit function call
2177 ----------------------
2178 -- Is_Function_Type --
2179 ----------------------
2181 function Is_Function_Type
return Boolean is
2186 if not Is_Overloaded
(N
) then
2187 return Ekind
(Base_Type
(Etype
(N
))) = E_Subprogram_Type
2188 and then Etype
(Base_Type
(Etype
(N
))) /= Standard_Void_Type
;
2191 Get_First_Interp
(N
, I
, It
);
2192 while Present
(It
.Nam
) loop
2193 if Ekind
(Base_Type
(It
.Typ
)) /= E_Subprogram_Type
2194 or else Etype
(Base_Type
(It
.Typ
)) = Standard_Void_Type
2199 Get_Next_Interp
(I
, It
);
2204 end Is_Function_Type
;
2206 -- Start of processing for Analyze_Explicit_Dereference
2209 -- In formal verification mode, keep track of all reads and writes
2210 -- through explicit dereferences.
2212 if GNATprove_Mode
then
2213 SPARK_Specific
.Generate_Dereference
(N
);
2217 Set_Etype
(N
, Any_Type
);
2219 -- Test for remote access to subprogram type, and if so return
2220 -- after rewriting the original tree.
2222 if Remote_AST_E_Dereference
(P
) then
2226 -- Normal processing for other than remote access to subprogram type
2228 if not Is_Overloaded
(P
) then
2229 if Is_Access_Type
(Etype
(P
)) then
2234 DT
: constant Entity_Id
:= Designated_Type
(Etype
(P
));
2237 -- An explicit dereference is a legal occurrence of an
2238 -- incomplete type imported through a limited_with clause, if
2239 -- the full view is visible, or if we are within an instance
2240 -- body, where the enclosing body has a regular with_clause
2243 if From_Limited_With
(DT
)
2244 and then not From_Limited_With
(Scope
(DT
))
2246 (Is_Immediately_Visible
(Scope
(DT
))
2248 (Is_Child_Unit
(Scope
(DT
))
2249 and then Is_Visible_Lib_Unit
(Scope
(DT
)))
2250 or else In_Instance_Body
)
2252 Set_Etype
(N
, Available_View
(DT
));
2259 elsif Etype
(P
) /= Any_Type
then
2260 Error_Msg_N
("prefix of dereference must be an access type", N
);
2265 Get_First_Interp
(P
, I
, It
);
2266 while Present
(It
.Nam
) loop
2269 if Is_Access_Type
(T
) then
2270 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
2273 Get_Next_Interp
(I
, It
);
2276 -- Error if no interpretation of the prefix has an access type
2278 if Etype
(N
) = Any_Type
then
2280 ("access type required in prefix of explicit dereference", P
);
2281 Set_Etype
(N
, Any_Type
);
2287 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
2289 and then (Nkind
(Parent
(N
)) /= N_Function_Call
2290 or else N
/= Name
(Parent
(N
)))
2292 and then (Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2293 or else N
/= Name
(Parent
(N
)))
2295 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
2296 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
2298 (Attribute_Name
(Parent
(N
)) /= Name_Address
2300 Attribute_Name
(Parent
(N
)) /= Name_Access
))
2302 -- Name is a function call with no actuals, in a context that
2303 -- requires deproceduring (including as an actual in an enclosing
2304 -- function or procedure call). There are some pathological cases
2305 -- where the prefix might include functions that return access to
2306 -- subprograms and others that return a regular type. Disambiguation
2307 -- of those has to take place in Resolve.
2310 Make_Function_Call
(Loc
,
2311 Name
=> Make_Explicit_Dereference
(Loc
, P
),
2312 Parameter_Associations
=> New_List
);
2314 -- If the prefix is overloaded, remove operations that have formals,
2315 -- we know that this is a parameterless call.
2317 if Is_Overloaded
(P
) then
2318 Get_First_Interp
(P
, I
, It
);
2319 while Present
(It
.Nam
) loop
2322 if Is_Access_Type
(T
)
2323 and then No
(First_Formal
(Base_Type
(Designated_Type
(T
))))
2330 Get_Next_Interp
(I
, It
);
2337 elsif not Is_Function_Type
2338 and then Is_Overloaded
(N
)
2340 -- The prefix may include access to subprograms and other access
2341 -- types. If the context selects the interpretation that is a
2342 -- function call (not a procedure call) we cannot rewrite the node
2343 -- yet, but we include the result of the call interpretation.
2345 Get_First_Interp
(N
, I
, It
);
2346 while Present
(It
.Nam
) loop
2347 if Ekind
(Base_Type
(It
.Typ
)) = E_Subprogram_Type
2348 and then Etype
(Base_Type
(It
.Typ
)) /= Standard_Void_Type
2349 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
2351 Add_One_Interp
(N
, Etype
(It
.Typ
), Etype
(It
.Typ
));
2354 Get_Next_Interp
(I
, It
);
2358 -- A value of remote access-to-class-wide must not be dereferenced
2361 Validate_Remote_Access_To_Class_Wide_Type
(N
);
2362 end Analyze_Explicit_Dereference
;
2364 ------------------------
2365 -- Analyze_Expression --
2366 ------------------------
2368 procedure Analyze_Expression
(N
: Node_Id
) is
2370 -- If the expression is an indexed component that will be rewritten
2371 -- as a container indexing, it has already been analyzed.
2373 if Nkind
(N
) = N_Indexed_Component
2374 and then Present
(Generalized_Indexing
(N
))
2380 Check_Parameterless_Call
(N
);
2382 end Analyze_Expression
;
2384 -------------------------------------
2385 -- Analyze_Expression_With_Actions --
2386 -------------------------------------
2388 procedure Analyze_Expression_With_Actions
(N
: Node_Id
) is
2390 procedure Check_Action_OK
(A
: Node_Id
);
2391 -- Check that the action A is allowed as a declare_item of a declare
2392 -- expression if N and A come from source.
2394 ---------------------
2395 -- Check_Action_OK --
2396 ---------------------
2398 procedure Check_Action_OK
(A
: Node_Id
) is
2400 if not Comes_From_Source
(N
) or else not Comes_From_Source
(A
) then
2402 -- If, for example, an (illegal) expression function is
2403 -- transformed into a "vanilla" function then we don't want to
2404 -- allow it just because Comes_From_Source is now False. So look
2405 -- at the Original_Node.
2407 if Is_Rewrite_Substitution
(A
) then
2408 Check_Action_OK
(Original_Node
(A
));
2411 return; -- Allow anything in generated code
2415 when N_Object_Declaration
=>
2416 if Nkind
(Object_Definition
(A
)) = N_Access_Definition
then
2418 ("anonymous access type not allowed in declare_expression",
2419 Object_Definition
(A
));
2422 if Aliased_Present
(A
) then
2423 Error_Msg_N
("ALIASED not allowed in declare_expression", A
);
2426 if Constant_Present
(A
)
2427 and then not Is_Limited_Type
(Etype
(Defining_Identifier
(A
)))
2429 return; -- nonlimited constants are OK
2432 when N_Object_Renaming_Declaration
=>
2433 if Present
(Access_Definition
(A
)) then
2435 ("anonymous access type not allowed in declare_expression",
2436 Access_Definition
(A
));
2439 if not Is_Limited_Type
(Etype
(Defining_Identifier
(A
))) then
2440 return; -- ???For now; the RM rule is a bit more complicated
2445 -- See AI22-0045 pragma categorization.
2446 subtype Executable_Pragma_Id
is Pragma_Id
2447 with Predicate
=> Executable_Pragma_Id
in
2448 -- language-defined executable pragmas
2449 Pragma_Assert | Pragma_Inspection_Point
2451 -- GNAT-defined executable pragmas
2452 | Pragma_Assume | Pragma_Debug
;
2454 if Get_Pragma_Id
(A
) in Executable_Pragma_Id
then
2460 null; -- Nothing else allowed
2463 -- We could mention pragmas in the message text; let's not.
2464 Error_Msg_N
("object renaming or constant declaration expected", A
);
2465 end Check_Action_OK
;
2468 EWA_Scop
: Entity_Id
;
2470 -- Start of processing for Analyze_Expression_With_Actions
2473 -- Create a scope, which is needed to provide proper visibility of the
2476 EWA_Scop
:= New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
2477 Set_Etype
(EWA_Scop
, Standard_Void_Type
);
2478 Set_Scope
(EWA_Scop
, Current_Scope
);
2479 Set_Parent
(EWA_Scop
, N
);
2480 Push_Scope
(EWA_Scop
);
2482 -- If this Expression_With_Actions node comes from source, then it
2483 -- represents a declare_expression; increment the counter to take note
2486 if Comes_From_Source
(N
) then
2487 In_Declare_Expr
:= In_Declare_Expr
+ 1;
2490 A
:= First
(Actions
(N
));
2491 while Present
(A
) loop
2493 Check_Action_OK
(A
);
2497 Analyze_Expression
(Expression
(N
));
2498 Set_Etype
(N
, Etype
(Expression
(N
)));
2501 if Comes_From_Source
(N
) then
2502 In_Declare_Expr
:= In_Declare_Expr
- 1;
2504 end Analyze_Expression_With_Actions
;
2506 ---------------------------
2507 -- Analyze_If_Expression --
2508 ---------------------------
2510 procedure Analyze_If_Expression
(N
: Node_Id
) is
2511 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2513 Then_Expr
: Node_Id
;
2514 Else_Expr
: Node_Id
;
2516 procedure Check_Else_Expression
(T
: Entity_Id
);
2517 -- Check one interpretation of the THEN expression with type T
2519 procedure Check_Expression_Pair
(T1
, T2
: Entity_Id
);
2520 -- Check THEN expression with type T1 and ELSE expression with type T2
2522 ---------------------------
2523 -- Check_Else_Expression --
2524 ---------------------------
2526 procedure Check_Else_Expression
(T
: Entity_Id
) is
2531 -- Loop through the interpretations of the ELSE expression
2533 if not Is_Overloaded
(Else_Expr
) then
2534 Check_Expression_Pair
(T
, Etype
(Else_Expr
));
2537 Get_First_Interp
(Else_Expr
, I
, It
);
2538 while Present
(It
.Typ
) loop
2539 Check_Expression_Pair
(T
, It
.Typ
);
2540 Get_Next_Interp
(I
, It
);
2543 end Check_Else_Expression
;
2545 ---------------------------
2546 -- Check_Expression_Pair --
2547 ---------------------------
2549 procedure Check_Expression_Pair
(T1
, T2
: Entity_Id
) is
2553 if Covers
(T1
=> T1
, T2
=> T2
)
2554 or else Covers
(T1
=> T2
, T2
=> T1
)
2556 T
:= Specific_Type
(T1
, T2
);
2558 elsif Is_User_Defined_Literal
(Then_Expr
, T2
) then
2561 elsif Is_User_Defined_Literal
(Else_Expr
, T1
) then
2565 T
:= Possible_Type_For_Conditional_Expression
(T1
, T2
);
2572 Add_One_Interp
(N
, T
, T
);
2573 end Check_Expression_Pair
;
2580 -- Start of processing for Analyze_If_Expression
2583 -- Defend against error of missing expressions from previous error
2585 if No
(Condition
) then
2586 Check_Error_Detected
;
2590 Set_Etype
(N
, Any_Type
);
2592 Then_Expr
:= Next
(Condition
);
2594 if No
(Then_Expr
) then
2595 Check_Error_Detected
;
2599 Else_Expr
:= Next
(Then_Expr
);
2601 -- Analyze and resolve the condition. We need to resolve this now so
2602 -- that it gets folded to True/False if possible, before we analyze
2603 -- the THEN/ELSE branches, because when analyzing these branches, we
2604 -- may call Is_Statically_Unevaluated, which expects the condition of
2605 -- an enclosing IF to have been analyze/resolved/evaluated.
2607 Analyze_Expression
(Condition
);
2608 Resolve
(Condition
, Any_Boolean
);
2610 -- Analyze the THEN expression and (if present) the ELSE expression. For
2611 -- them we delay resolution in the normal manner because of overloading.
2613 Analyze_Expression
(Then_Expr
);
2615 if Present
(Else_Expr
) then
2616 Analyze_Expression
(Else_Expr
);
2619 -- RM 4.5.7(10/3): If the if_expression is the operand of a type
2620 -- conversion, the type of the if_expression is the target type
2621 -- of the conversion.
2623 if Nkind
(Parent
(N
)) = N_Type_Conversion
then
2624 Set_Etype
(N
, Etype
(Parent
(N
)));
2628 -- Loop through the interpretations of the THEN expression and check the
2629 -- ELSE expression if present.
2631 if not Is_Overloaded
(Then_Expr
) then
2632 if Present
(Else_Expr
) then
2633 Check_Else_Expression
(Etype
(Then_Expr
));
2635 Set_Etype
(N
, Etype
(Then_Expr
));
2639 Get_First_Interp
(Then_Expr
, I
, It
);
2640 while Present
(It
.Typ
) loop
2641 if Present
(Else_Expr
) then
2642 Check_Else_Expression
(It
.Typ
);
2644 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
2647 Get_Next_Interp
(I
, It
);
2651 -- If no possible interpretation has been found, the type of the
2652 -- ELSE expression does not match any interpretation of the THEN
2655 if Etype
(N
) = Any_Type
then
2656 if Is_Overloaded
(Then_Expr
) then
2657 if Is_Overloaded
(Else_Expr
) then
2659 ("no interpretation compatible with those of THEN expression",
2663 ("type of ELSE incompatible with interpretations of THEN "
2667 ("\ELSE expression has}!", Else_Expr
, Etype
(Else_Expr
));
2670 elsif Present
(Else_Expr
) then
2671 if Is_Overloaded
(Else_Expr
) then
2673 ("no interpretation compatible with type of THEN expression",
2676 ("\THEN expression has}!", Else_Expr
, Etype
(Then_Expr
));
2679 ("type of ELSE incompatible with that of THEN expression",
2682 ("\THEN expression has}!", Else_Expr
, Etype
(Then_Expr
));
2684 ("\ELSE expression has}!", Else_Expr
, Etype
(Else_Expr
));
2688 end Analyze_If_Expression
;
2690 ------------------------------------
2691 -- Analyze_Indexed_Component_Form --
2692 ------------------------------------
2694 procedure Analyze_Indexed_Component_Form
(N
: Node_Id
) is
2695 P
: constant Node_Id
:= Prefix
(N
);
2696 Exprs
: constant List_Id
:= Expressions
(N
);
2702 procedure Process_Function_Call
;
2703 -- Prefix in indexed component form is an overloadable entity, so the
2704 -- node is very likely a function call; reformat it as such. The only
2705 -- exception is a call to a parameterless function that returns an
2706 -- array type, or an access type thereof, in which case this will be
2707 -- undone later by Resolve_Call or Resolve_Entry_Call.
2709 procedure Process_Indexed_Component
;
2710 -- Prefix in indexed component form is actually an indexed component.
2711 -- This routine processes it, knowing that the prefix is already
2714 procedure Process_Indexed_Component_Or_Slice
;
2715 -- An indexed component with a single index may designate a slice if
2716 -- the index is a subtype mark. This routine disambiguates these two
2717 -- cases by resolving the prefix to see if it is a subtype mark.
2719 procedure Process_Overloaded_Indexed_Component
;
2720 -- If the prefix of an indexed component is overloaded, the proper
2721 -- interpretation is selected by the index types and the context.
2723 ---------------------------
2724 -- Process_Function_Call --
2725 ---------------------------
2727 procedure Process_Function_Call
is
2728 Loc
: constant Source_Ptr
:= Sloc
(N
);
2732 Change_Node
(N
, N_Function_Call
);
2734 Set_Parameter_Associations
(N
, Exprs
);
2736 -- Analyze actuals prior to analyzing the call itself
2738 Actual
:= First
(Parameter_Associations
(N
));
2739 while Present
(Actual
) loop
2741 Check_Parameterless_Call
(Actual
);
2743 -- Move to next actual. Note that we use Next, not Next_Actual
2744 -- here. The reason for this is a bit subtle. If a function call
2745 -- includes named associations, the parser recognizes the node
2746 -- as a call, and it is analyzed as such. If all associations are
2747 -- positional, the parser builds an indexed_component node, and
2748 -- it is only after analysis of the prefix that the construct
2749 -- is recognized as a call, in which case Process_Function_Call
2750 -- rewrites the node and analyzes the actuals. If the list of
2751 -- actuals is malformed, the parser may leave the node as an
2752 -- indexed component (despite the presence of named associations).
2753 -- The iterator Next_Actual is equivalent to Next if the list is
2754 -- positional, but follows the normalized chain of actuals when
2755 -- named associations are present. In this case normalization has
2756 -- not taken place, and actuals remain unanalyzed, which leads to
2757 -- subsequent crashes or loops if there is an attempt to continue
2758 -- analysis of the program.
2760 -- IF there is a single actual and it is a type name, the node
2761 -- can only be interpreted as a slice of a parameterless call.
2762 -- Rebuild the node as such and analyze.
2764 if No
(Next
(Actual
))
2765 and then Is_Entity_Name
(Actual
)
2766 and then Is_Type
(Entity
(Actual
))
2767 and then Is_Discrete_Type
(Entity
(Actual
))
2768 and then not Is_Current_Instance
(Actual
)
2774 New_Occurrence_Of
(Entity
(Actual
), Loc
)));
2784 end Process_Function_Call
;
2786 -------------------------------
2787 -- Process_Indexed_Component --
2788 -------------------------------
2790 procedure Process_Indexed_Component
is
2792 Array_Type
: Entity_Id
;
2794 Pent
: Entity_Id
:= Empty
;
2797 Exp
:= First
(Exprs
);
2799 if Is_Overloaded
(P
) then
2800 Process_Overloaded_Indexed_Component
;
2803 Array_Type
:= Etype
(P
);
2805 if Is_Entity_Name
(P
) then
2807 elsif Nkind
(P
) = N_Selected_Component
2808 and then Is_Entity_Name
(Selector_Name
(P
))
2810 Pent
:= Entity
(Selector_Name
(P
));
2813 -- Prefix must be appropriate for an array type, taking into
2814 -- account a possible implicit dereference.
2816 if Is_Access_Type
(Array_Type
) then
2818 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2819 Array_Type
:= Implicitly_Designated_Type
(Array_Type
);
2822 if Is_Array_Type
(Array_Type
) then
2824 -- In order to correctly access First_Index component later,
2825 -- replace string literal subtype by its parent type.
2827 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
2828 Array_Type
:= Etype
(Array_Type
);
2831 elsif Present
(Pent
) and then Ekind
(Pent
) = E_Entry_Family
then
2833 Set_Etype
(N
, Any_Type
);
2835 if not Has_Compatible_Type
(Exp
, Entry_Index_Type
(Pent
)) then
2836 Error_Msg_N
("invalid index type in entry name", N
);
2838 elsif Present
(Next
(Exp
)) then
2839 Error_Msg_N
("too many subscripts in entry reference", N
);
2842 Set_Etype
(N
, Etype
(P
));
2847 elsif Is_Record_Type
(Array_Type
)
2848 and then Remote_AST_I_Dereference
(P
)
2852 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
2855 elsif Array_Type
= Any_Type
then
2856 Set_Etype
(N
, Any_Type
);
2858 -- In most cases the analysis of the prefix will have emitted
2859 -- an error already, but if the prefix may be interpreted as a
2860 -- call in prefixed notation, the report is left to the caller.
2861 -- To prevent cascaded errors, report only if no previous ones.
2863 if Serious_Errors_Detected
= 0 then
2864 Error_Msg_N
("invalid prefix in indexed component", P
);
2866 if Nkind
(P
) = N_Expanded_Name
then
2867 Error_Msg_NE
("\& is not visible", P
, Selector_Name
(P
));
2873 -- Here we definitely have a bad indexing
2876 if Nkind
(Parent
(N
)) = N_Requeue_Statement
2877 and then Present
(Pent
) and then Ekind
(Pent
) = E_Entry
2880 ("REQUEUE does not permit parameters", First
(Exprs
));
2882 elsif Is_Entity_Name
(P
)
2883 and then Etype
(P
) = Standard_Void_Type
2885 Error_Msg_NE
("incorrect use of &", P
, Entity
(P
));
2888 Error_Msg_N
("array type required in indexed component", P
);
2891 Set_Etype
(N
, Any_Type
);
2895 Index
:= First_Index
(Array_Type
);
2896 while Present
(Index
) and then Present
(Exp
) loop
2897 if not Has_Compatible_Type
(Exp
, Etype
(Index
)) then
2898 Wrong_Type
(Exp
, Etype
(Index
));
2899 Set_Etype
(N
, Any_Type
);
2907 Set_Etype
(N
, Component_Type
(Array_Type
));
2908 Check_Implicit_Dereference
(N
, Etype
(N
));
2910 -- Generate conversion to class-wide type
2912 if Is_Mutably_Tagged_CW_Equivalent_Type
(Etype
(N
)) then
2913 Make_Mutably_Tagged_Conversion
(N
);
2916 if Present
(Index
) then
2918 ("too few subscripts in array reference", First
(Exprs
));
2920 elsif Present
(Exp
) then
2921 Error_Msg_N
("too many subscripts in array reference", Exp
);
2924 end Process_Indexed_Component
;
2926 ----------------------------------------
2927 -- Process_Indexed_Component_Or_Slice --
2928 ----------------------------------------
2930 procedure Process_Indexed_Component_Or_Slice
is
2932 Exp
:= First
(Exprs
);
2933 while Present
(Exp
) loop
2934 Analyze_Expression
(Exp
);
2938 Exp
:= First
(Exprs
);
2940 -- If one index is present, and it is a subtype name, then the node
2941 -- denotes a slice (note that the case of an explicit range for a
2942 -- slice was already built as an N_Slice node in the first place,
2943 -- so that case is not handled here).
2945 -- We use a replace rather than a rewrite here because this is one
2946 -- of the cases in which the tree built by the parser is plain wrong.
2949 and then Is_Entity_Name
(Exp
)
2950 and then Is_Type
(Entity
(Exp
))
2953 Make_Slice
(Sloc
(N
),
2955 Discrete_Range
=> New_Copy
(Exp
)));
2958 -- Otherwise (more than one index present, or single index is not
2959 -- a subtype name), then we have the indexed component case.
2962 Process_Indexed_Component
;
2964 end Process_Indexed_Component_Or_Slice
;
2966 ------------------------------------------
2967 -- Process_Overloaded_Indexed_Component --
2968 ------------------------------------------
2970 procedure Process_Overloaded_Indexed_Component
is
2979 Set_Etype
(N
, Any_Type
);
2981 Get_First_Interp
(P
, I
, It
);
2982 while Present
(It
.Nam
) loop
2985 if Is_Access_Type
(Typ
) then
2986 Typ
:= Designated_Type
(Typ
);
2988 (Warn_On_Dereference
, "?d?implicit dereference", N
);
2991 if Is_Array_Type
(Typ
) then
2993 -- Got a candidate: verify that index types are compatible
2995 Index
:= First_Index
(Typ
);
2997 Exp
:= First
(Exprs
);
2998 while Present
(Index
) and then Present
(Exp
) loop
2999 if Has_Compatible_Type
(Exp
, Etype
(Index
)) then
3011 if Found
and then No
(Index
) and then No
(Exp
) then
3013 CT
: constant Entity_Id
:=
3014 Base_Type
(Component_Type
(Typ
));
3016 Add_One_Interp
(N
, CT
, CT
);
3017 Check_Implicit_Dereference
(N
, CT
);
3021 elsif Try_Container_Indexing
(N
, P
, Exprs
) then
3026 Get_Next_Interp
(I
, It
);
3029 if Etype
(N
) = Any_Type
then
3030 Error_Msg_N
("no legal interpretation for indexed component", N
);
3031 Set_Is_Overloaded
(N
, False);
3033 end Process_Overloaded_Indexed_Component
;
3035 -- Start of processing for Analyze_Indexed_Component_Form
3038 -- Get name of array, function or type
3042 -- If P is an explicit dereference whose prefix is of a remote access-
3043 -- to-subprogram type, then N has already been rewritten as a subprogram
3044 -- call and analyzed.
3046 if Nkind
(N
) in N_Subprogram_Call
then
3049 -- When the prefix is attribute 'Loop_Entry and the sole expression of
3050 -- the indexed component denotes a loop name, the indexed form is turned
3051 -- into an attribute reference.
3053 elsif Nkind
(N
) = N_Attribute_Reference
3054 and then Attribute_Name
(N
) = Name_Loop_Entry
3059 pragma Assert
(Nkind
(N
) = N_Indexed_Component
);
3061 P_T
:= Base_Type
(Etype
(P
));
3063 if Is_Entity_Name
(P
) and then Present
(Entity
(P
)) then
3066 if Is_Type
(U_N
) then
3068 -- Reformat node as a type conversion
3070 E
:= Remove_Head
(Exprs
);
3072 if Present
(First
(Exprs
)) then
3074 ("argument of type conversion must be single expression", N
);
3077 Change_Node
(N
, N_Type_Conversion
);
3078 Set_Subtype_Mark
(N
, P
);
3080 Set_Expression
(N
, E
);
3082 -- After changing the node, call for the specific Analysis
3083 -- routine directly, to avoid a double call to the expander.
3085 Analyze_Type_Conversion
(N
);
3089 if Is_Overloadable
(U_N
) then
3090 Process_Function_Call
;
3092 elsif Ekind
(Etype
(P
)) = E_Subprogram_Type
3093 or else (Is_Access_Type
(Etype
(P
))
3095 Ekind
(Designated_Type
(Etype
(P
))) =
3098 -- Call to access_to-subprogram with possible implicit dereference
3100 Process_Function_Call
;
3102 elsif Is_Generic_Subprogram
(U_N
) then
3104 -- A common beginner's (or C++ templates fan) error
3106 Error_Msg_N
("generic subprogram cannot be called", N
);
3107 Set_Etype
(N
, Any_Type
);
3111 Process_Indexed_Component_Or_Slice
;
3114 -- If not an entity name, prefix is an expression that may denote
3115 -- an array or an access-to-subprogram.
3118 if Ekind
(P_T
) = E_Subprogram_Type
3119 or else (Is_Access_Type
(P_T
)
3121 Ekind
(Designated_Type
(P_T
)) = E_Subprogram_Type
)
3123 Process_Function_Call
;
3125 elsif Nkind
(P
) = N_Selected_Component
3126 and then Present
(Entity
(Selector_Name
(P
)))
3127 and then Is_Overloadable
(Entity
(Selector_Name
(P
)))
3129 Process_Function_Call
;
3131 -- Indexed component, slice, or a call to a member of a family
3132 -- entry, which will be converted to an entry call later.
3134 Process_Indexed_Component_Or_Slice
;
3138 Analyze_Dimension
(N
);
3139 end Analyze_Indexed_Component_Form
;
3141 ------------------------
3142 -- Analyze_Logical_Op --
3143 ------------------------
3145 procedure Analyze_Logical_Op
(N
: Node_Id
) is
3146 L
: constant Node_Id
:= Left_Opnd
(N
);
3147 R
: constant Node_Id
:= Right_Opnd
(N
);
3152 Set_Etype
(N
, Any_Type
);
3153 Candidate_Type
:= Empty
;
3155 Analyze_Expression
(L
);
3156 Analyze_Expression
(R
);
3158 -- If the entity is already set, the node is the instantiation of a
3159 -- generic node with a non-local reference, or was manufactured by a
3160 -- call to Make_Op_xxx. In either case the entity is known to be valid,
3161 -- and we do not need to collect interpretations, instead we just get
3162 -- the single possible interpretation.
3164 if Present
(Entity
(N
)) then
3165 Op_Id
:= Entity
(N
);
3167 if Ekind
(Op_Id
) = E_Operator
then
3168 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
3170 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
3173 -- Entity is not already set, so we do need to collect interpretations
3176 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
3177 while Present
(Op_Id
) loop
3178 if Ekind
(Op_Id
) = E_Operator
then
3179 Find_Boolean_Types
(L
, R
, Op_Id
, N
);
3181 Analyze_User_Defined_Binary_Op
(N
, Op_Id
);
3184 Op_Id
:= Homonym
(Op_Id
);
3189 Check_Function_Writable_Actuals
(N
);
3192 if Nkind
(L
) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor
3193 and then Is_Boolean_Type
(Etype
(L
))
3195 Check_Xtra_Parens_Precedence
(L
);
3198 if Nkind
(R
) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor
3199 and then Is_Boolean_Type
(Etype
(R
))
3201 Check_Xtra_Parens_Precedence
(R
);
3204 end Analyze_Logical_Op
;
3206 ---------------------------
3207 -- Analyze_Membership_Op --
3208 ---------------------------
3210 procedure Analyze_Membership_Op
(N
: Node_Id
) is
3211 Loc
: constant Source_Ptr
:= Sloc
(N
);
3212 L
: constant Node_Id
:= Left_Opnd
(N
);
3213 R
: constant Node_Id
:= Right_Opnd
(N
);
3215 procedure Analyze_Set_Membership
;
3216 -- If a set of alternatives is present, analyze each and find the
3217 -- common type to which they must all resolve.
3219 function Find_Interp
return Boolean;
3220 -- Find a valid interpretation of the test. Note that the context of the
3221 -- operation plays no role in resolving the operands, so that if there
3222 -- is more than one interpretation of the operands that is compatible
3223 -- with the test, the operation is ambiguous.
3225 function Try_Left_Interp
(T
: Entity_Id
) return Boolean;
3226 -- Try an interpretation of the left operand with type T. Return true if
3227 -- one interpretation (at least) of the right operand making up a valid
3228 -- operand pair exists, otherwise false if no such pair exists.
3230 function Is_Valid_Pair
(T1
, T2
: Entity_Id
) return Boolean;
3231 -- Return true if T1 and T2 constitute a valid pair of operand types for
3232 -- L and R respectively.
3234 ----------------------------
3235 -- Analyze_Set_Membership --
3236 ----------------------------
3238 procedure Analyze_Set_Membership
is
3240 Index
: Interp_Index
;
3242 Candidate_Interps
: Node_Id
;
3243 Common_Type
: Entity_Id
:= Empty
;
3247 Candidate_Interps
:= L
;
3249 if not Is_Overloaded
(L
) then
3250 Common_Type
:= Etype
(L
);
3252 Alt
:= First
(Alternatives
(N
));
3253 while Present
(Alt
) loop
3256 if not Has_Compatible_Type
(Alt
, Common_Type
) then
3257 Wrong_Type
(Alt
, Common_Type
);
3264 Alt
:= First
(Alternatives
(N
));
3265 while Present
(Alt
) loop
3267 if not Is_Overloaded
(Alt
) then
3268 Common_Type
:= Etype
(Alt
);
3271 Get_First_Interp
(Alt
, Index
, It
);
3272 while Present
(It
.Typ
) loop
3274 Has_Compatible_Type
(Candidate_Interps
, It
.Typ
)
3276 Remove_Interp
(Index
);
3279 Get_Next_Interp
(Index
, It
);
3282 Get_First_Interp
(Alt
, Index
, It
);
3285 Error_Msg_N
("alternative has no legal type", Alt
);
3289 -- If alternative is not overloaded, we have a unique type
3292 Set_Etype
(Alt
, It
.Typ
);
3294 -- If the alternative is an enumeration literal, use the one
3295 -- for this interpretation.
3297 if Is_Entity_Name
(Alt
) then
3298 Set_Entity
(Alt
, It
.Nam
);
3301 Get_Next_Interp
(Index
, It
);
3304 Set_Is_Overloaded
(Alt
, False);
3305 Common_Type
:= Etype
(Alt
);
3308 Candidate_Interps
:= Alt
;
3315 if Present
(Common_Type
) then
3316 Set_Etype
(L
, Common_Type
);
3318 -- The left operand may still be overloaded, to be resolved using
3322 Error_Msg_N
("cannot resolve membership operation", N
);
3324 end Analyze_Set_Membership
;
3330 function Find_Interp
return Boolean is
3335 Valid_I
: Interp_Index
;
3338 -- Loop through the interpretations of the left operand
3340 if not Is_Overloaded
(L
) then
3341 Found
:= Try_Left_Interp
(Etype
(L
));
3348 Get_First_Interp
(L
, I
, It
);
3349 while Present
(It
.Typ
) loop
3350 if Try_Left_Interp
(It
.Typ
) then
3351 -- If several interpretations are possible, disambiguate
3354 and then Base_Type
(It
.Typ
) /= Base_Type
(L_Typ
)
3356 It
:= Disambiguate
(L
, Valid_I
, I
, Any_Type
);
3358 if It
= No_Interp
then
3359 Ambiguous_Operands
(N
);
3360 Set_Etype
(L
, Any_Type
);
3369 Set_Etype
(L
, L_Typ
);
3373 Get_Next_Interp
(I
, It
);
3380 ---------------------
3381 -- Try_Left_Interp --
3382 ---------------------
3384 function Try_Left_Interp
(T
: Entity_Id
) return Boolean is
3389 Valid_I
: Interp_Index
;
3392 -- Defend against previous error
3394 if Nkind
(R
) = N_Error
then
3397 -- Loop through the interpretations of the right operand
3399 elsif not Is_Overloaded
(R
) then
3400 Found
:= Is_Valid_Pair
(T
, Etype
(R
));
3407 Get_First_Interp
(R
, I
, It
);
3408 while Present
(It
.Typ
) loop
3409 if Is_Valid_Pair
(T
, It
.Typ
) then
3410 -- If several interpretations are possible, disambiguate
3413 and then Base_Type
(It
.Typ
) /= Base_Type
(R_Typ
)
3415 It
:= Disambiguate
(R
, Valid_I
, I
, Any_Type
);
3417 if It
= No_Interp
then
3418 Ambiguous_Operands
(N
);
3419 Set_Etype
(R
, Any_Type
);
3431 Get_Next_Interp
(I
, It
);
3436 end Try_Left_Interp
;
3442 function Is_Valid_Pair
(T1
, T2
: Entity_Id
) return Boolean is
3444 return Covers
(T1
=> T1
, T2
=> T2
)
3445 or else Covers
(T1
=> T2
, T2
=> T1
)
3446 or else Is_User_Defined_Literal
(L
, T2
)
3447 or else Is_User_Defined_Literal
(R
, T1
);
3455 -- Start of processing for Analyze_Membership_Op
3458 Analyze_Expression
(L
);
3461 pragma Assert
(Ada_Version
>= Ada_2012
);
3463 Analyze_Set_Membership
;
3468 Alt
:= First
(Alternatives
(N
));
3469 while Present
(Alt
) loop
3470 if Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)) then
3471 Check_Fully_Declared
(Entity
(Alt
), Alt
);
3473 if Has_Ghost_Predicate_Aspect
(Entity
(Alt
)) then
3475 ("subtype& has ghost predicate, "
3476 & "not allowed in membership test",
3485 elsif Nkind
(R
) = N_Range
3486 or else (Nkind
(R
) = N_Attribute_Reference
3487 and then Attribute_Name
(R
) = Name_Range
)
3489 Analyze_Expression
(R
);
3491 Dummy
:= Find_Interp
;
3493 -- If not a range, it can be a subtype mark, or else it is a degenerate
3494 -- membership test with a singleton value, i.e. a test for equality,
3495 -- if the types are compatible.
3498 Analyze_Expression
(R
);
3500 if Is_Entity_Name
(R
) and then Is_Type
(Entity
(R
)) then
3502 Check_Fully_Declared
(Entity
(R
), R
);
3504 if Has_Ghost_Predicate_Aspect
(Entity
(R
)) then
3506 ("subtype& has ghost predicate, "
3507 & "not allowed in membership test",
3511 elsif Ada_Version
>= Ada_2012
and then Find_Interp
then
3512 Op
:= Make_Op_Eq
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
3513 Resolve_Membership_Equality
(Op
, Etype
(L
));
3515 if Nkind
(N
) = N_Not_In
then
3516 Op
:= Make_Op_Not
(Loc
, Op
);
3524 -- In all versions of the language, if we reach this point there
3525 -- is a previous error that will be diagnosed below.
3531 -- Compatibility between expression and subtype mark or range is
3532 -- checked during resolution. The result of the operation is Boolean
3535 Set_Etype
(N
, Standard_Boolean
);
3537 if Comes_From_Source
(N
)
3538 and then Present
(Right_Opnd
(N
))
3539 and then Is_CPP_Class
(Etype
(Etype
(Right_Opnd
(N
))))
3541 Error_Msg_N
("membership test not applicable to cpp-class types", N
);
3544 Check_Function_Writable_Actuals
(N
);
3545 end Analyze_Membership_Op
;
3551 procedure Analyze_Mod
(N
: Node_Id
) is
3553 -- A special warning check, if we have an expression of the form:
3554 -- expr mod 2 * literal
3555 -- where literal is 128 or less, then probably what was meant was
3556 -- expr mod 2 ** literal
3557 -- so issue an appropriate warning.
3559 if Warn_On_Suspicious_Modulus_Value
3560 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
3561 and then Intval
(Right_Opnd
(N
)) = Uint_2
3562 and then Nkind
(Parent
(N
)) = N_Op_Multiply
3563 and then Nkind
(Right_Opnd
(Parent
(N
))) = N_Integer_Literal
3564 and then Intval
(Right_Opnd
(Parent
(N
))) <= Uint_128
3567 ("suspicious MOD value, was '*'* intended'??.m?", Parent
(N
));
3570 -- Remaining processing is same as for other arithmetic operators
3572 Analyze_Arithmetic_Op
(N
);
3575 ----------------------
3576 -- Analyze_Negation --
3577 ----------------------
3579 procedure Analyze_Negation
(N
: Node_Id
) is
3580 R
: constant Node_Id
:= Right_Opnd
(N
);
3585 Set_Etype
(N
, Any_Type
);
3586 Candidate_Type
:= Empty
;
3588 Analyze_Expression
(R
);
3590 -- If the entity is already set, the node is the instantiation of a
3591 -- generic node with a non-local reference, or was manufactured by a
3592 -- call to Make_Op_xxx. In either case the entity is known to be valid,
3593 -- and we do not need to collect interpretations, instead we just get
3594 -- the single possible interpretation.
3596 if Present
(Entity
(N
)) then
3597 Op_Id
:= Entity
(N
);
3599 if Ekind
(Op_Id
) = E_Operator
then
3600 Find_Negation_Types
(R
, Op_Id
, N
);
3602 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
3606 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
3607 while Present
(Op_Id
) loop
3608 if Ekind
(Op_Id
) = E_Operator
then
3609 Find_Negation_Types
(R
, Op_Id
, N
);
3611 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
3614 Op_Id
:= Homonym
(Op_Id
);
3619 end Analyze_Negation
;
3625 procedure Analyze_Null
(N
: Node_Id
) is
3627 Set_Etype
(N
, Universal_Access
);
3630 ----------------------
3631 -- Analyze_One_Call --
3632 ----------------------
3634 procedure Analyze_One_Call
3638 Success
: out Boolean;
3639 Skip_First
: Boolean := False)
3641 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
3642 Prev_T
: constant Entity_Id
:= Etype
(N
);
3644 -- Recognize cases of prefixed calls that have been rewritten in
3645 -- various ways. The simplest case is a rewritten selected component,
3646 -- but it can also be an already-examined indexed component, or a
3647 -- prefix that is itself a rewritten prefixed call that is in turn
3648 -- an indexed call (the syntactic ambiguity involving the indexing of
3649 -- a function with defaulted parameters that returns an array).
3650 -- A flag Maybe_Indexed_Call might be useful here ???
3652 Must_Skip
: constant Boolean := Skip_First
3653 or else Nkind
(Original_Node
(N
)) = N_Selected_Component
3655 (Nkind
(Original_Node
(N
)) = N_Indexed_Component
3656 and then Nkind
(Prefix
(Original_Node
(N
))) =
3657 N_Selected_Component
)
3659 (Nkind
(Parent
(N
)) = N_Function_Call
3660 and then Is_Array_Type
(Etype
(Name
(N
)))
3661 and then Etype
(Original_Node
(N
)) =
3662 Component_Type
(Etype
(Name
(N
)))
3663 and then Nkind
(Original_Node
(Parent
(N
))) =
3664 N_Selected_Component
);
3666 -- The first formal must be omitted from the match when trying to find
3667 -- a primitive operation that is a possible interpretation, and also
3668 -- after the call has been rewritten, because the corresponding actual
3669 -- is already known to be compatible, and because this may be an
3670 -- indexing of a call with default parameters.
3672 First_Form
: Entity_Id
;
3675 Is_Indexed
: Boolean := False;
3676 Is_Indirect
: Boolean := False;
3677 Subp_Type
: constant Entity_Id
:= Etype
(Nam
);
3680 function Compatible_Types_In_Predicate
3682 T2
: Entity_Id
) return Boolean;
3683 -- For an Ada 2012 predicate or invariant, a call may mention an
3684 -- incomplete type, while resolution of the corresponding predicate
3685 -- function may see the full view, as a consequence of the delayed
3686 -- resolution of the corresponding expressions. This may occur in
3687 -- the body of a predicate function, or in a call to such. Anomalies
3688 -- involving private and full views can also happen. In each case,
3689 -- rewrite node or add conversions to remove spurious type errors.
3691 procedure Indicate_Name_And_Type
;
3692 -- If candidate interpretation matches, indicate name and type of result
3695 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean;
3696 -- There may be a user-defined operator that hides the current
3697 -- interpretation. We must check for this independently of the
3698 -- analysis of the call with the user-defined operation, because
3699 -- the parameter names may be wrong and yet the hiding takes place.
3700 -- This fixes a problem with ACATS test B34014O.
3702 -- When the type Address is a visible integer type, and the DEC
3703 -- system extension is visible, the predefined operator may be
3704 -- hidden as well, by one of the address operations in auxdec.
3705 -- Finally, the abstract operations on address do not hide the
3706 -- predefined operator (this is the purpose of making them abstract).
3708 -----------------------------------
3709 -- Compatible_Types_In_Predicate --
3710 -----------------------------------
3712 function Compatible_Types_In_Predicate
3714 T2
: Entity_Id
) return Boolean
3716 function Common_Type
(T
: Entity_Id
) return Entity_Id
;
3717 -- Find non-private underlying full view if any, without going to
3718 -- ancestor type (as opposed to Underlying_Type).
3724 function Common_Type
(T
: Entity_Id
) return Entity_Id
is
3730 if Is_Private_Type
(CT
) and then Present
(Full_View
(CT
)) then
3731 CT
:= Full_View
(CT
);
3734 if Is_Private_Type
(CT
)
3735 and then Present
(Underlying_Full_View
(CT
))
3737 CT
:= Underlying_Full_View
(CT
);
3740 return Base_Type
(CT
);
3743 -- Start of processing for Compatible_Types_In_Predicate
3746 if (Ekind
(Current_Scope
) = E_Function
3747 and then Is_Predicate_Function
(Current_Scope
))
3749 (Ekind
(Nam
) = E_Function
3750 and then Is_Predicate_Function
(Nam
))
3752 if Is_Incomplete_Type
(T1
)
3753 and then Present
(Full_View
(T1
))
3754 and then Full_View
(T1
) = T2
3756 Set_Etype
(Formal
, Etype
(Actual
));
3759 elsif Common_Type
(T1
) = Common_Type
(T2
) then
3760 Rewrite
(Actual
, Unchecked_Convert_To
(Etype
(Formal
), Actual
));
3770 end Compatible_Types_In_Predicate
;
3772 ----------------------------
3773 -- Indicate_Name_And_Type --
3774 ----------------------------
3776 procedure Indicate_Name_And_Type
is
3778 Add_One_Interp
(N
, Nam
, Etype
(Nam
));
3779 Check_Implicit_Dereference
(N
, Etype
(Nam
));
3782 -- If the prefix of the call is a name, indicate the entity
3783 -- being called. If it is not a name, it is an expression that
3784 -- denotes an access to subprogram or else an entry or family. In
3785 -- the latter case, the name is a selected component, and the entity
3786 -- being called is noted on the selector.
3788 if not Is_Type
(Nam
) then
3789 if Is_Entity_Name
(Name
(N
)) then
3790 Set_Entity
(Name
(N
), Nam
);
3791 Set_Etype
(Name
(N
), Etype
(Nam
));
3793 elsif Nkind
(Name
(N
)) = N_Selected_Component
then
3794 Set_Entity
(Selector_Name
(Name
(N
)), Nam
);
3798 if Debug_Flag_E
and not Report
then
3799 Write_Str
(" Overloaded call ");
3800 Write_Int
(Int
(N
));
3801 Write_Str
(" compatible with ");
3802 Write_Int
(Int
(Nam
));
3805 end Indicate_Name_And_Type
;
3807 ------------------------
3808 -- Operator_Hidden_By --
3809 ------------------------
3811 function Operator_Hidden_By
(Fun
: Entity_Id
) return Boolean is
3812 Act1
: constant Node_Id
:= First_Actual
(N
);
3813 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
3814 Form1
: constant Entity_Id
:= First_Formal
(Fun
);
3815 Form2
: constant Entity_Id
:= Next_Formal
(Form1
);
3818 if Ekind
(Fun
) /= E_Function
or else Is_Abstract_Subprogram
(Fun
) then
3821 elsif not Has_Compatible_Type
(Act1
, Etype
(Form1
)) then
3824 elsif Present
(Form2
) then
3826 or else not Has_Compatible_Type
(Act2
, Etype
(Form2
))
3831 elsif Present
(Act2
) then
3835 -- Now we know that the arity of the operator matches the function,
3836 -- and the function call is a valid interpretation. The function
3837 -- hides the operator if it has the right signature, or if one of
3838 -- its operands is a non-abstract operation on Address when this is
3839 -- a visible integer type.
3841 return Hides_Op
(Fun
, Nam
)
3842 or else Is_Descendant_Of_Address
(Etype
(Form1
))
3845 and then Is_Descendant_Of_Address
(Etype
(Form2
)));
3846 end Operator_Hidden_By
;
3848 -- Start of processing for Analyze_One_Call
3853 -- If the subprogram has no formals or if all the formals have defaults,
3854 -- and the return type is an array type, the node may denote an indexing
3855 -- of the result of a parameterless call. In Ada 2005, the subprogram
3856 -- may have one non-defaulted formal, and the call may have been written
3857 -- in prefix notation, so that the rebuilt parameter list has more than
3860 if not Is_Overloadable
(Nam
)
3861 and then Ekind
(Nam
) /= E_Subprogram_Type
3862 and then Ekind
(Nam
) /= E_Entry_Family
3867 -- An indexing requires at least one actual. The name of the call cannot
3868 -- be an implicit indirect call, so it cannot be a generated explicit
3871 if not Is_Empty_List
(Actuals
)
3873 (Needs_No_Actuals
(Nam
)
3875 (Needs_One_Actual
(Nam
)
3876 and then Present
(Next_Actual
(First
(Actuals
)))))
3878 if Is_Array_Type
(Subp_Type
)
3880 (Nkind
(Name
(N
)) /= N_Explicit_Dereference
3881 or else Comes_From_Source
(Name
(N
)))
3883 Is_Indexed
:= Try_Indexed_Call
(N
, Nam
, Subp_Type
, Must_Skip
);
3885 elsif Is_Access_Type
(Subp_Type
)
3886 and then Is_Array_Type
(Designated_Type
(Subp_Type
))
3890 (N
, Nam
, Designated_Type
(Subp_Type
), Must_Skip
);
3892 -- The prefix can also be a parameterless function that returns an
3893 -- access to subprogram, in which case this is an indirect call.
3894 -- If this succeeds, an explicit dereference is added later on,
3895 -- in Analyze_Call or Resolve_Call.
3897 elsif Is_Access_Type
(Subp_Type
)
3898 and then Ekind
(Designated_Type
(Subp_Type
)) = E_Subprogram_Type
3900 Is_Indirect
:= Try_Indirect_Call
(N
, Nam
, Subp_Type
);
3905 -- If the call has been transformed into a slice, it is of the form
3906 -- F (Subtype) where F is parameterless. The node has been rewritten in
3907 -- Try_Indexed_Call and there is nothing else to do.
3910 and then Nkind
(N
) = N_Slice
3916 (N
, Nam
, (Report
and not Is_Indexed
and not Is_Indirect
), Norm_OK
);
3920 -- If an indirect call is a possible interpretation, indicate
3921 -- success to the caller. This may be an indexing of an explicit
3922 -- dereference of a call that returns an access type (see above).
3926 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
3927 and then Comes_From_Source
(Name
(N
)))
3932 -- Mismatch in number or names of parameters
3934 elsif Debug_Flag_E
then
3935 Write_Str
(" normalization fails in call ");
3936 Write_Int
(Int
(N
));
3937 Write_Str
(" with subprogram ");
3938 Write_Int
(Int
(Nam
));
3942 -- If the context expects a function call, discard any interpretation
3943 -- that is a procedure. If the node is not overloaded, leave as is for
3944 -- better error reporting when type mismatch is found.
3946 elsif Nkind
(N
) = N_Function_Call
3947 and then Is_Overloaded
(Name
(N
))
3948 and then Ekind
(Nam
) = E_Procedure
3952 -- Ditto for function calls in a procedure context
3954 elsif Nkind
(N
) = N_Procedure_Call_Statement
3955 and then Is_Overloaded
(Name
(N
))
3956 and then Etype
(Nam
) /= Standard_Void_Type
3960 elsif No
(Actuals
) then
3962 -- If Normalize succeeds, then there are default parameters for
3965 Indicate_Name_And_Type
;
3967 elsif Ekind
(Nam
) = E_Operator
then
3968 if Nkind
(N
) = N_Procedure_Call_Statement
then
3972 -- This occurs when the prefix of the call is an operator name
3973 -- or an expanded name whose selector is an operator name.
3975 Analyze_Operator_Call
(N
, Nam
);
3977 if Etype
(N
) /= Prev_T
then
3979 -- Check that operator is not hidden by a function interpretation
3981 if Is_Overloaded
(Name
(N
)) then
3987 Get_First_Interp
(Name
(N
), I
, It
);
3988 while Present
(It
.Nam
) loop
3989 if Operator_Hidden_By
(It
.Nam
) then
3990 Set_Etype
(N
, Prev_T
);
3994 Get_Next_Interp
(I
, It
);
3999 -- If operator matches formals, record its name on the call.
4000 -- If the operator is overloaded, Resolve will select the
4001 -- correct one from the list of interpretations. The call
4002 -- node itself carries the first candidate.
4004 Set_Entity
(Name
(N
), Nam
);
4007 elsif Report
and then Etype
(N
) = Any_Type
then
4008 Error_Msg_N
("incompatible arguments for operator", N
);
4012 -- Normalize_Actuals has chained the named associations in the
4013 -- correct order of the formals.
4015 Actual
:= First_Actual
(N
);
4016 Formal
:= First_Formal
(Nam
);
4017 First_Form
:= Formal
;
4019 -- If we are analyzing a call rewritten from object notation, skip
4020 -- first actual, which may be rewritten later as an explicit
4024 Next_Actual
(Actual
);
4025 Next_Formal
(Formal
);
4028 while Present
(Actual
) and then Present
(Formal
) loop
4029 if Nkind
(Parent
(Actual
)) /= N_Parameter_Association
4030 or else Chars
(Selector_Name
(Parent
(Actual
))) = Chars
(Formal
)
4032 -- The actual can be compatible with the formal, but we must
4033 -- also check that the context is not an address type that is
4034 -- visibly an integer type. In this case the use of literals is
4035 -- illegal, except in the body of descendants of system, where
4036 -- arithmetic operations on address are of course used.
4038 if Has_Compatible_Type
(Actual
, Etype
(Formal
))
4040 (Etype
(Actual
) /= Universal_Integer
4041 or else not Is_Descendant_Of_Address
(Etype
(Formal
))
4042 or else In_Predefined_Unit
(N
))
4044 Next_Actual
(Actual
);
4045 Next_Formal
(Formal
);
4047 -- In Allow_Integer_Address mode, we allow an actual integer to
4048 -- match a formal address type and vice versa. We only do this
4049 -- if we are certain that an error will otherwise be issued
4051 elsif Address_Integer_Convert_OK
4052 (Etype
(Actual
), Etype
(Formal
))
4053 and then (Report
and not Is_Indexed
and not Is_Indirect
)
4055 -- Handle this case by introducing an unchecked conversion
4058 Unchecked_Convert_To
(Etype
(Formal
),
4059 Relocate_Node
(Actual
)));
4060 Analyze_And_Resolve
(Actual
, Etype
(Formal
));
4061 Next_Actual
(Actual
);
4062 Next_Formal
(Formal
);
4064 -- Under relaxed RM semantics silently replace occurrences of
4065 -- null by System.Address_Null. We only do this if we know that
4066 -- an error will otherwise be issued.
4068 elsif Null_To_Null_Address_Convert_OK
(Actual
, Etype
(Formal
))
4069 and then (Report
and not Is_Indexed
and not Is_Indirect
)
4071 Replace_Null_By_Null_Address
(Actual
);
4072 Analyze_And_Resolve
(Actual
, Etype
(Formal
));
4073 Next_Actual
(Actual
);
4074 Next_Formal
(Formal
);
4076 elsif Compatible_Types_In_Predicate
4077 (Etype
(Formal
), Etype
(Actual
))
4079 Next_Actual
(Actual
);
4080 Next_Formal
(Formal
);
4082 -- A current instance used as an actual of a function,
4083 -- whose body has not been seen, may include a formal
4084 -- whose type is an incomplete view of an enclosing
4085 -- type declaration containing the current call (e.g.
4086 -- in the Expression for a component declaration).
4088 -- In this case, update the signature of the subprogram
4089 -- so the formal has the type of the full view.
4091 elsif Inside_Init_Proc
4092 and then Nkind
(Actual
) = N_Identifier
4093 and then Ekind
(Etype
(Formal
)) = E_Incomplete_Type
4094 and then Etype
(Actual
) = Full_View
(Etype
(Formal
))
4096 Set_Etype
(Formal
, Etype
(Actual
));
4097 Next_Actual
(Actual
);
4098 Next_Formal
(Formal
);
4100 -- Generate a class-wide type conversion for instances of
4101 -- class-wide equivalent types to their corresponding
4102 -- mutably tagged type.
4104 elsif Is_Mutably_Tagged_CW_Equivalent_Type
(Etype
(Actual
))
4105 and then Etype
(Formal
) = Parent_Subtype
(Etype
(Actual
))
4107 Make_Mutably_Tagged_Conversion
(Actual
);
4108 Next_Actual
(Actual
);
4109 Next_Formal
(Formal
);
4111 -- Handle failed type check
4114 if Debug_Flag_E
then
4115 Write_Str
(" type checking fails in call ");
4116 Write_Int
(Int
(N
));
4117 Write_Str
(" with formal ");
4118 Write_Int
(Int
(Formal
));
4119 Write_Str
(" in subprogram ");
4120 Write_Int
(Int
(Nam
));
4124 -- Comment needed on the following test???
4126 if Report
and not Is_Indexed
and not Is_Indirect
then
4128 -- Ada 2005 (AI-251): Complete the error notification
4129 -- to help new Ada 2005 users.
4131 if Is_Class_Wide_Type
(Etype
(Formal
))
4132 and then Is_Interface
(Etype
(Etype
(Formal
)))
4133 and then not Interface_Present_In_Ancestor
4134 (Typ
=> Etype
(Actual
),
4135 Iface
=> Etype
(Etype
(Formal
)))
4138 ("(Ada 2005) does not implement interface }",
4139 Actual
, Etype
(Etype
(Formal
)));
4142 -- If we are going to output a secondary error message
4143 -- below, we need to have Wrong_Type output the main one.
4146 (Actual
, Etype
(Formal
), Multiple
=> All_Errors_Mode
);
4148 if Nkind
(Actual
) = N_Op_Eq
4149 and then Nkind
(Left_Opnd
(Actual
)) = N_Identifier
4151 Formal
:= First_Formal
(Nam
);
4152 while Present
(Formal
) loop
4153 if Chars
(Left_Opnd
(Actual
)) = Chars
(Formal
) then
4154 Error_Msg_N
-- CODEFIX
4155 ("possible misspelling of `='>`!", Actual
);
4159 Next_Formal
(Formal
);
4163 if All_Errors_Mode
then
4164 Error_Msg_Sloc
:= Sloc
(Nam
);
4166 if Etype
(Formal
) = Any_Type
then
4168 ("there is no legal actual parameter", Actual
);
4171 if Is_Overloadable
(Nam
)
4172 and then Present
(Alias
(Nam
))
4173 and then not Comes_From_Source
(Nam
)
4176 ("\\ =='> in call to inherited operation & #!",
4179 elsif Ekind
(Nam
) = E_Subprogram_Type
then
4181 Access_To_Subprogram_Typ
:
4182 constant Entity_Id
:=
4184 (Associated_Node_For_Itype
(Nam
));
4187 ("\\ =='> in call to dereference of &#!",
4188 Actual
, Access_To_Subprogram_Typ
);
4193 ("\\ =='> in call to &#!", Actual
, Nam
);
4203 -- Normalize_Actuals has verified that a default value exists
4204 -- for this formal. Current actual names a subsequent formal.
4206 Next_Formal
(Formal
);
4210 -- Due to our current model of controlled type expansion we may
4211 -- have resolved a user call to a non-visible controlled primitive
4212 -- since these inherited subprograms may be generated in the current
4213 -- scope. This is a side effect of the need for the expander to be
4214 -- able to resolve internally generated calls.
4216 -- Specifically, the issue appears when predefined controlled
4217 -- operations get called on a type extension whose parent is a
4218 -- private extension completed with a controlled extension - see
4222 -- type Par_Typ is tagged private;
4224 -- type Par_Typ is new Controlled with null record;
4227 -- procedure Main is
4228 -- type Ext_Typ is new Par_Typ with null record;
4231 -- Finalize (Obj); -- Will improperly resolve
4234 -- To avoid breaking privacy, Is_Hidden gets set elsewhere on such
4235 -- primitives, but we still need to verify that Nam is indeed a
4236 -- non-visible controlled subprogram. So, we do that here and issue
4237 -- the appropriate error.
4240 and then not In_Instance
4241 and then not Comes_From_Source
(Nam
)
4242 and then Comes_From_Source
(N
)
4244 -- Verify Nam is a non-visible controlled primitive
4246 and then Chars
(Nam
) in Name_Adjust
4249 and then Ekind
(Nam
) = E_Procedure
4250 and then Is_Controlled
(Etype
(First_Form
))
4251 and then No
(Next_Formal
(First_Form
))
4252 and then not Is_Visibly_Controlled
(Etype
(First_Form
))
4254 Error_Msg_Node_2
:= Etype
(First_Form
);
4255 Error_Msg_NE
("call to non-visible controlled primitive & on type"
4259 -- On exit, all actuals match
4261 Indicate_Name_And_Type
;
4263 end Analyze_One_Call
;
4265 ---------------------------
4266 -- Analyze_Operator_Call --
4267 ---------------------------
4269 procedure Analyze_Operator_Call
(N
: Node_Id
; Op_Id
: Entity_Id
) is
4270 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
4271 Act1
: constant Node_Id
:= First_Actual
(N
);
4272 Act2
: constant Node_Id
:= Next_Actual
(Act1
);
4275 -- Binary operator case
4277 if Present
(Act2
) then
4279 -- If more than two operands, then not binary operator after all
4281 if Present
(Next_Actual
(Act2
)) then
4285 -- Otherwise action depends on operator
4296 Find_Arithmetic_Types
(Act1
, Act2
, Op_Id
, N
);
4302 Find_Boolean_Types
(Act1
, Act2
, Op_Id
, N
);
4311 Find_Comparison_Equality_Types
(Act1
, Act2
, Op_Id
, N
);
4313 when Name_Op_Concat
=>
4314 Find_Concatenation_Types
(Act1
, Act2
, Op_Id
, N
);
4316 -- Is this when others, or should it be an abort???
4322 -- Unary operator case
4330 Find_Unary_Types
(Act1
, Op_Id
, N
);
4333 Find_Negation_Types
(Act1
, Op_Id
, N
);
4335 -- Is this when others correct, or should it be an abort???
4341 end Analyze_Operator_Call
;
4343 -------------------------------------------
4344 -- Analyze_Overloaded_Selected_Component --
4345 -------------------------------------------
4347 procedure Analyze_Overloaded_Selected_Component
(N
: Node_Id
) is
4348 Nam
: constant Node_Id
:= Prefix
(N
);
4349 Sel
: constant Node_Id
:= Selector_Name
(N
);
4356 Set_Etype
(Sel
, Any_Type
);
4358 Get_First_Interp
(Nam
, I
, It
);
4359 while Present
(It
.Typ
) loop
4360 if Is_Access_Type
(It
.Typ
) then
4361 T
:= Designated_Type
(It
.Typ
);
4362 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
4367 -- Locate the component. For a private prefix the selector can denote
4370 if Is_Record_Type
(T
) or else Is_Private_Type
(T
) then
4372 -- If the prefix is a class-wide type, the visible components are
4373 -- those of the base type.
4375 if Is_Class_Wide_Type
(T
) then
4379 Comp
:= First_Entity
(T
);
4380 while Present
(Comp
) loop
4381 if Chars
(Comp
) = Chars
(Sel
)
4382 and then Is_Visible_Component
(Comp
, Sel
)
4385 -- AI05-105: if the context is an object renaming with
4386 -- an anonymous access type, the expected type of the
4387 -- object must be anonymous. This is a name resolution rule.
4389 if Nkind
(Parent
(N
)) /= N_Object_Renaming_Declaration
4390 or else No
(Access_Definition
(Parent
(N
)))
4391 or else Is_Anonymous_Access_Type
(Etype
(Comp
))
4393 Set_Entity
(Sel
, Comp
);
4394 Set_Etype
(Sel
, Etype
(Comp
));
4395 Add_One_Interp
(N
, Etype
(Comp
), Etype
(Comp
));
4396 Check_Implicit_Dereference
(N
, Etype
(Comp
));
4398 -- This also specifies a candidate to resolve the name.
4399 -- Further overloading will be resolved from context.
4400 -- The selector name itself does not carry overloading
4403 Set_Etype
(Nam
, It
.Typ
);
4406 -- Named access type in the context of a renaming
4407 -- declaration with an access definition. Remove
4408 -- inapplicable candidate.
4417 elsif Is_Concurrent_Type
(T
) then
4418 Comp
:= First_Entity
(T
);
4419 while Present
(Comp
)
4420 and then Comp
/= First_Private_Entity
(T
)
4422 if Chars
(Comp
) = Chars
(Sel
) then
4423 if Is_Overloadable
(Comp
) then
4424 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
4426 Set_Entity_With_Checks
(Sel
, Comp
);
4427 Generate_Reference
(Comp
, Sel
);
4430 Set_Etype
(Sel
, Etype
(Comp
));
4431 Set_Etype
(N
, Etype
(Comp
));
4432 Set_Etype
(Nam
, It
.Typ
);
4438 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
4441 Get_Next_Interp
(I
, It
);
4444 if Etype
(N
) = Any_Type
4445 and then not Try_Object_Operation
(N
)
4447 Error_Msg_NE
("undefined selector& for overloaded prefix", N
, Sel
);
4448 Set_Entity
(Sel
, Any_Id
);
4449 Set_Etype
(Sel
, Any_Type
);
4451 end Analyze_Overloaded_Selected_Component
;
4453 ----------------------------------
4454 -- Analyze_Qualified_Expression --
4455 ----------------------------------
4457 procedure Analyze_Qualified_Expression
(N
: Node_Id
) is
4458 Expr
: constant Node_Id
:= Expression
(N
);
4459 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
4469 if Nkind
(Enclosing_Declaration
(N
)) in
4470 N_Formal_Type_Declaration |
4471 N_Full_Type_Declaration |
4472 N_Incomplete_Type_Declaration |
4473 N_Protected_Type_Declaration |
4474 N_Private_Extension_Declaration |
4475 N_Private_Type_Declaration |
4476 N_Subtype_Declaration |
4477 N_Task_Type_Declaration
4478 and then T
= Defining_Identifier
(Enclosing_Declaration
(N
))
4480 Error_Msg_N
("current instance not allowed", Mark
);
4486 Analyze_Expression
(Expr
);
4488 if T
= Any_Type
then
4492 Check_Fully_Declared
(T
, N
);
4494 -- If expected type is class-wide, check for exact match before
4495 -- expansion, because if the expression is a dispatching call it
4496 -- may be rewritten as explicit dereference with class-wide result.
4497 -- If expression is overloaded, retain only interpretations that
4498 -- will yield exact matches.
4500 if Is_Class_Wide_Type
(T
) then
4501 if not Is_Overloaded
(Expr
) then
4502 if Base_Type
(Etype
(Expr
)) /= Base_Type
(T
)
4503 and then Etype
(Expr
) /= Raise_Type
4505 if Nkind
(Expr
) = N_Aggregate
then
4506 Error_Msg_N
("type of aggregate cannot be class-wide", Expr
);
4508 Wrong_Type
(Expr
, T
);
4513 Get_First_Interp
(Expr
, I
, It
);
4515 while Present
(It
.Nam
) loop
4516 if Base_Type
(It
.Typ
) /= Base_Type
(T
) then
4520 Get_Next_Interp
(I
, It
);
4524 end Analyze_Qualified_Expression
;
4526 -----------------------------------
4527 -- Analyze_Quantified_Expression --
4528 -----------------------------------
4530 procedure Analyze_Quantified_Expression
(N
: Node_Id
) is
4531 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean;
4532 -- Return True if the iterator is part of a quantified expression and
4533 -- the range is known to be statically empty.
4535 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean;
4536 -- Determine whether if expression If_Expr lacks an else part or if it
4537 -- has one, it evaluates to True.
4539 --------------------
4540 -- Is_Empty_Range --
4541 --------------------
4543 function Is_Empty_Range
(Typ
: Entity_Id
) return Boolean is
4545 return Is_Array_Type
(Typ
)
4546 and then Compile_Time_Known_Bounds
(Typ
)
4548 Expr_Value
(Type_Low_Bound
(Etype
(First_Index
(Typ
)))) >
4549 Expr_Value
(Type_High_Bound
(Etype
(First_Index
(Typ
))));
4552 -----------------------------
4553 -- No_Else_Or_Trivial_True --
4554 -----------------------------
4556 function No_Else_Or_Trivial_True
(If_Expr
: Node_Id
) return Boolean is
4557 Else_Expr
: constant Node_Id
:=
4558 Next
(Next
(First
(Expressions
(If_Expr
))));
4562 or else (Compile_Time_Known_Value
(Else_Expr
)
4563 and then Is_True
(Expr_Value
(Else_Expr
)));
4564 end No_Else_Or_Trivial_True
;
4568 Cond
: constant Node_Id
:= Condition
(N
);
4569 Loc
: constant Source_Ptr
:= Sloc
(N
);
4570 Loop_Id
: Entity_Id
;
4571 QE_Scop
: Entity_Id
;
4573 -- Start of processing for Analyze_Quantified_Expression
4576 -- Create a scope to emulate the loop-like behavior of the quantified
4577 -- expression. The scope is needed to provide proper visibility of the
4580 QE_Scop
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Loc
, 'L');
4581 Set_Etype
(QE_Scop
, Standard_Void_Type
);
4582 Set_Scope
(QE_Scop
, Current_Scope
);
4583 Set_Parent
(QE_Scop
, N
);
4585 Push_Scope
(QE_Scop
);
4587 -- All constituents are preanalyzed and resolved to avoid untimely
4588 -- generation of various temporaries and types. Full analysis and
4589 -- expansion is carried out when the quantified expression is
4590 -- transformed into an expression with actions.
4592 if Present
(Iterator_Specification
(N
)) then
4593 Preanalyze
(Iterator_Specification
(N
));
4595 -- Do not proceed with the analysis when the range of iteration is
4598 if Is_Entity_Name
(Name
(Iterator_Specification
(N
)))
4599 and then Is_Empty_Range
(Etype
(Name
(Iterator_Specification
(N
))))
4601 Preanalyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
4604 -- Emit a warning and replace expression with its static value
4606 if All_Present
(N
) then
4608 ("??quantified expression with ALL "
4609 & "over a null range has value True", N
);
4610 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
4614 ("??quantified expression with SOME "
4615 & "over a null range has value False", N
);
4616 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
4623 else pragma Assert
(Present
(Loop_Parameter_Specification
(N
)));
4625 Loop_Par
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
4628 Preanalyze
(Loop_Par
);
4630 if Nkind
(Discrete_Subtype_Definition
(Loop_Par
)) = N_Function_Call
4631 and then Parent
(Loop_Par
) /= N
4633 -- The parser cannot distinguish between a loop specification
4634 -- and an iterator specification. If after preanalysis the
4635 -- proper form has been recognized, rewrite the expression to
4636 -- reflect the right kind. This is needed for proper ASIS
4637 -- navigation. If expansion is enabled, the transformation is
4638 -- performed when the expression is rewritten as a loop.
4639 -- Is this still needed???
4641 Set_Iterator_Specification
(N
,
4642 New_Copy_Tree
(Iterator_Specification
(Parent
(Loop_Par
))));
4644 Set_Defining_Identifier
(Iterator_Specification
(N
),
4645 Relocate_Node
(Defining_Identifier
(Loop_Par
)));
4646 Set_Name
(Iterator_Specification
(N
),
4647 Relocate_Node
(Discrete_Subtype_Definition
(Loop_Par
)));
4648 Set_Comes_From_Source
(Iterator_Specification
(N
),
4649 Comes_From_Source
(Loop_Parameter_Specification
(N
)));
4650 Set_Loop_Parameter_Specification
(N
, Empty
);
4655 Preanalyze_And_Resolve
(Cond
, Standard_Boolean
);
4658 Set_Etype
(N
, Standard_Boolean
);
4660 -- Verify that the loop variable is used within the condition of the
4661 -- quantified expression.
4663 if Present
(Iterator_Specification
(N
)) then
4664 Loop_Id
:= Defining_Identifier
(Iterator_Specification
(N
));
4666 Loop_Id
:= Defining_Identifier
(Loop_Parameter_Specification
(N
));
4670 type Subexpr_Kind
is (Full
, Conjunct
, Disjunct
);
4672 procedure Check_Subexpr
(Expr
: Node_Id
; Kind
: Subexpr_Kind
);
4673 -- Check that the quantified variable appears in every sub-expression
4674 -- of the quantified expression. If Kind is Full, Expr is the full
4675 -- expression. If Kind is Conjunct (resp. Disjunct), Expr is a
4676 -- conjunct (resp. disjunct) of the full expression.
4682 procedure Check_Subexpr
(Expr
: Node_Id
; Kind
: Subexpr_Kind
) is
4684 if Nkind
(Expr
) in N_Op_And | N_And_Then
4685 and then Kind
/= Disjunct
4687 Check_Subexpr
(Left_Opnd
(Expr
), Conjunct
);
4688 Check_Subexpr
(Right_Opnd
(Expr
), Conjunct
);
4690 elsif Nkind
(Expr
) in N_Op_Or | N_Or_Else
4691 and then Kind
/= Conjunct
4693 Check_Subexpr
(Left_Opnd
(Expr
), Disjunct
);
4694 Check_Subexpr
(Right_Opnd
(Expr
), Disjunct
);
4697 and then not Referenced
(Loop_Id
, Expr
)
4700 Sub
: constant String :=
4701 (if Kind
= Conjunct
then "conjunct" else "disjunct");
4704 ("?.t?unused variable & in " & Sub
, Expr
, Loop_Id
);
4706 ("\consider extracting " & Sub
& " from quantified "
4707 & "expression", Expr
, Loop_Id
);
4713 if Warn_On_Suspicious_Contract
4714 and then not Is_Internal_Name
(Chars
(Loop_Id
))
4716 if not Referenced
(Loop_Id
, Cond
) then
4717 Error_Msg_N
("?.t?unused variable &", Loop_Id
);
4719 Check_Subexpr
(Cond
, Kind
=> Full
);
4724 -- Diagnose a possible misuse of the SOME existential quantifier. When
4725 -- we have a quantified expression of the form:
4727 -- for some X => (if P then Q [else True])
4729 -- any value for X that makes P False results in the if expression being
4730 -- trivially True, and so also results in the quantified expression
4731 -- being trivially True.
4733 if Warn_On_Suspicious_Contract
4734 and then not All_Present
(N
)
4735 and then Nkind
(Cond
) = N_If_Expression
4736 and then No_Else_Or_Trivial_True
(Cond
)
4738 Error_Msg_N
("?.t?suspicious expression", N
);
4739 Error_Msg_N
("\\did you mean (for all X ='> (if P then Q))", N
);
4740 Error_Msg_N
("\\or (for some X ='> P and then Q) instead'?", N
);
4742 end Analyze_Quantified_Expression
;
4748 procedure Analyze_Range
(N
: Node_Id
) is
4749 L
: constant Node_Id
:= Low_Bound
(N
);
4750 H
: constant Node_Id
:= High_Bound
(N
);
4751 I1
, I2
: Interp_Index
;
4754 procedure Check_Common_Type
(T1
, T2
: Entity_Id
);
4755 -- Verify the compatibility of two types, and choose the
4756 -- non universal one if the other is universal.
4758 procedure Check_High_Bound
(T
: Entity_Id
);
4759 -- Test one interpretation of the low bound against all those
4760 -- of the high bound.
4762 procedure Check_Universal_Expression
(N
: Node_Id
);
4763 -- In Ada 83, reject bounds of a universal range that are not literals
4766 -----------------------
4767 -- Check_Common_Type --
4768 -----------------------
4770 procedure Check_Common_Type
(T1
, T2
: Entity_Id
) is
4772 if Covers
(T1
=> T1
, T2
=> T2
)
4774 Covers
(T1
=> T2
, T2
=> T1
)
4776 if Is_Universal_Numeric_Type
(T1
)
4777 or else T1
= Any_Character
4779 Add_One_Interp
(N
, Base_Type
(T2
), Base_Type
(T2
));
4782 Add_One_Interp
(N
, T1
, T1
);
4785 Add_One_Interp
(N
, Base_Type
(T1
), Base_Type
(T1
));
4788 end Check_Common_Type
;
4790 ----------------------
4791 -- Check_High_Bound --
4792 ----------------------
4794 procedure Check_High_Bound
(T
: Entity_Id
) is
4796 if not Is_Overloaded
(H
) then
4797 Check_Common_Type
(T
, Etype
(H
));
4799 Get_First_Interp
(H
, I2
, It2
);
4800 while Present
(It2
.Typ
) loop
4801 Check_Common_Type
(T
, It2
.Typ
);
4802 Get_Next_Interp
(I2
, It2
);
4805 end Check_High_Bound
;
4807 --------------------------------
4808 -- Check_Universal_Expression --
4809 --------------------------------
4811 procedure Check_Universal_Expression
(N
: Node_Id
) is
4813 if Etype
(N
) = Universal_Integer
4814 and then Nkind
(N
) /= N_Integer_Literal
4815 and then not Is_Entity_Name
(N
)
4816 and then Nkind
(N
) /= N_Attribute_Reference
4818 Error_Msg_N
("illegal bound in discrete range", N
);
4820 end Check_Universal_Expression
;
4822 -- Start of processing for Analyze_Range
4825 Set_Etype
(N
, Any_Type
);
4826 Analyze_Expression
(L
);
4827 Analyze_Expression
(H
);
4829 if Etype
(L
) = Any_Type
or else Etype
(H
) = Any_Type
then
4833 if not Is_Overloaded
(L
) then
4834 Check_High_Bound
(Etype
(L
));
4836 Get_First_Interp
(L
, I1
, It1
);
4837 while Present
(It1
.Typ
) loop
4838 Check_High_Bound
(It1
.Typ
);
4839 Get_Next_Interp
(I1
, It1
);
4843 -- If result is Any_Type, then we did not find a compatible pair
4845 if Etype
(N
) = Any_Type
then
4846 Error_Msg_N
("incompatible types in range", N
);
4850 if Ada_Version
= Ada_83
4852 (Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
4853 or else Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
)
4855 Check_Universal_Expression
(L
);
4856 Check_Universal_Expression
(H
);
4859 Check_Function_Writable_Actuals
(N
);
4862 -----------------------
4863 -- Analyze_Reference --
4864 -----------------------
4866 procedure Analyze_Reference
(N
: Node_Id
) is
4867 P
: constant Node_Id
:= Prefix
(N
);
4870 Acc_Type
: Entity_Id
;
4875 -- An interesting error check, if we take the 'Ref of an object for
4876 -- which a pragma Atomic or Volatile has been given, and the type of the
4877 -- object is not Atomic or Volatile, then we are in trouble. The problem
4878 -- is that no trace of the atomic/volatile status will remain for the
4879 -- backend to respect when it deals with the resulting pointer, since
4880 -- the pointer type will not be marked atomic (it is a pointer to the
4881 -- base type of the object).
4883 -- It is not clear if that can ever occur, but in case it does, we will
4884 -- generate an error message. Not clear if this message can ever be
4885 -- generated, and pretty clear that it represents a bug if it is, still
4886 -- seems worth checking, except in CodePeer mode where we do not really
4887 -- care and don't want to bother the user.
4891 if Is_Entity_Name
(P
)
4892 and then Is_Object_Reference
(P
)
4893 and then not CodePeer_Mode
4898 if (Has_Atomic_Components
(E
)
4899 and then not Has_Atomic_Components
(T
))
4901 (Has_Volatile_Components
(E
)
4902 and then not Has_Volatile_Components
(T
))
4903 or else (Is_Atomic
(E
) and then not Is_Atomic
(T
))
4904 or else (Is_Volatile
(E
) and then not Is_Volatile
(T
))
4906 Error_Msg_N
("cannot take reference to Atomic/Volatile object", N
);
4910 -- Carry on with normal processing
4912 Acc_Type
:= Create_Itype
(E_Allocator_Type
, N
);
4913 Set_Etype
(Acc_Type
, Acc_Type
);
4914 Set_Directly_Designated_Type
(Acc_Type
, Etype
(P
));
4915 Set_Etype
(N
, Acc_Type
);
4916 end Analyze_Reference
;
4918 --------------------------------
4919 -- Analyze_Selected_Component --
4920 --------------------------------
4922 -- Prefix is a record type or a task or protected type. In the latter case,
4923 -- the selector must denote a visible entry.
4925 procedure Analyze_Selected_Component
(N
: Node_Id
) is
4926 Pref
: constant Node_Id
:= Prefix
(N
);
4927 Sel
: constant Node_Id
:= Selector_Name
(N
);
4929 Comp
: Entity_Id
:= Empty
;
4930 Has_Candidate
: Boolean := False;
4931 Hidden_Comp
: Entity_Id
;
4933 Is_Private_Op
: Boolean;
4935 Prefix_Type
: Entity_Id
;
4937 Type_To_Use
: Entity_Id
;
4938 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
4939 -- a class-wide type, we use its root type, whose components are
4940 -- present in the class-wide type.
4942 Is_Single_Concurrent_Object
: Boolean;
4943 -- Set True if the prefix is a single task or a single protected object
4945 function Constraint_Has_Unprefixed_Discriminant_Reference
4946 (Typ
: Entity_Id
) return Boolean;
4947 -- Given a subtype that is subject to a discriminant-dependent
4948 -- constraint, returns True if any of the values of the constraint
4949 -- (i.e., any of the index values for an index constraint, any of
4950 -- the discriminant values for a discriminant constraint)
4951 -- are unprefixed discriminant names.
4953 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean;
4954 -- It is known that the parent of N denotes a subprogram call. Comp
4955 -- is an overloadable component of the concurrent type of the prefix.
4956 -- Determine whether all formals of the parent of N and Comp are mode
4957 -- conformant. If the parent node is not analyzed yet it may be an
4958 -- indexed component rather than a function call.
4960 function Has_Dereference
(Nod
: Node_Id
) return Boolean;
4961 -- Check whether Nod includes a dereference, explicit or implicit, at
4962 -- any recursive level.
4964 function Is_Simple_Indexed_Component
(Nod
: Node_Id
) return Boolean;
4965 -- Check whether Nod is a simple indexed component in the context
4967 function Try_By_Protected_Procedure_Prefixed_View
return Boolean;
4968 -- Return True if N is an access attribute whose prefix is a prefixed
4969 -- class-wide (synchronized or protected) interface view for which some
4970 -- interpretation is a procedure with synchronization kind By_Protected
4971 -- _Procedure, and collect all its interpretations (since it may be an
4972 -- overloaded interface primitive); otherwise return False.
4974 function Try_Selected_Component_In_Instance
4975 (Typ
: Entity_Id
) return Boolean;
4976 -- If Typ is the actual for a formal derived type, or a derived type
4977 -- thereof, the component inherited from the generic parent may not
4978 -- be visible in the actual, but the selected component is legal. Climb
4979 -- up the derivation chain of the generic parent type and return True if
4980 -- we find the proper ancestor type; otherwise return False.
4982 ------------------------------------------------------
4983 -- Constraint_Has_Unprefixed_Discriminant_Reference --
4984 ------------------------------------------------------
4986 function Constraint_Has_Unprefixed_Discriminant_Reference
4987 (Typ
: Entity_Id
) return Boolean
4989 function Is_Discriminant_Name
(N
: Node_Id
) return Boolean is
4990 (Nkind
(N
) = N_Identifier
4991 and then Ekind
(Entity
(N
)) = E_Discriminant
);
4993 if Is_Array_Type
(Typ
) then
4995 Index
: Node_Id
:= First_Index
(Typ
);
4998 while Present
(Index
) loop
5000 if Nkind
(Rng
) = N_Subtype_Indication
then
5001 Rng
:= Range_Expression
(Constraint
(Rng
));
5004 if Nkind
(Rng
) = N_Range
then
5005 if Is_Discriminant_Name
(Low_Bound
(Rng
))
5006 or else Is_Discriminant_Name
(High_Bound
(Rng
))
5017 Elmt
: Elmt_Id
:= First_Elmt
(Discriminant_Constraint
(Typ
));
5019 while Present
(Elmt
) loop
5020 if Is_Discriminant_Name
(Node
(Elmt
)) then
5029 end Constraint_Has_Unprefixed_Discriminant_Reference
;
5031 ------------------------------
5032 -- Has_Mode_Conformant_Spec --
5033 ------------------------------
5035 function Has_Mode_Conformant_Spec
(Comp
: Entity_Id
) return Boolean is
5036 Comp_Param
: Entity_Id
;
5038 Param_Typ
: Entity_Id
;
5041 Comp_Param
:= First_Formal
(Comp
);
5043 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
5044 Param
:= First
(Expressions
(Parent
(N
)));
5046 Param
:= First
(Parameter_Associations
(Parent
(N
)));
5049 while Present
(Comp_Param
)
5050 and then Present
(Param
)
5052 Param_Typ
:= Find_Parameter_Type
(Param
);
5054 if Present
(Param_Typ
)
5056 not Conforming_Types
5057 (Etype
(Comp_Param
), Param_Typ
, Mode_Conformant
)
5062 Next_Formal
(Comp_Param
);
5066 -- One of the specs has additional formals; there is no match, unless
5067 -- this may be an indexing of a parameterless call.
5069 -- Note that when expansion is disabled, the corresponding record
5070 -- type of synchronized types is not constructed, so that there is
5071 -- no point is attempting an interpretation as a prefixed call, as
5072 -- this is bound to fail because the primitive operations will not
5073 -- be properly located.
5075 if Present
(Comp_Param
) or else Present
(Param
) then
5076 if Needs_No_Actuals
(Comp
)
5077 and then Is_Array_Type
(Etype
(Comp
))
5078 and then not Expander_Active
5087 end Has_Mode_Conformant_Spec
;
5089 ---------------------
5090 -- Has_Dereference --
5091 ---------------------
5093 function Has_Dereference
(Nod
: Node_Id
) return Boolean is
5095 if Nkind
(Nod
) = N_Explicit_Dereference
then
5098 elsif Is_Access_Type
(Etype
(Nod
)) then
5101 elsif Nkind
(Nod
) in N_Indexed_Component | N_Selected_Component
then
5102 return Has_Dereference
(Prefix
(Nod
));
5107 end Has_Dereference
;
5109 ---------------------------------
5110 -- Is_Simple_Indexed_Component --
5111 ---------------------------------
5113 function Is_Simple_Indexed_Component
(Nod
: Node_Id
) return Boolean is
5117 -- Nod must be an indexed component
5119 if Nkind
(Nod
) /= N_Indexed_Component
then
5123 -- The context must not be a nested selected component
5125 if Nkind
(Pref
) = N_Selected_Component
then
5129 -- The expressions must not be case expressions
5131 Expr
:= First
(Expressions
(Nod
));
5132 while Present
(Expr
) loop
5133 if Nkind
(Expr
) = N_Case_Expression
then
5141 end Is_Simple_Indexed_Component
;
5143 ----------------------------------------------
5144 -- Try_By_Protected_Procedure_Prefixed_View --
5145 ----------------------------------------------
5147 function Try_By_Protected_Procedure_Prefixed_View
return Boolean is
5148 Candidate
: Node_Id
:= Empty
;
5153 if Nkind
(Parent
(N
)) = N_Attribute_Reference
5154 and then Attribute_Name
(Parent
(N
)) in
5156 | Name_Unchecked_Access
5157 | Name_Unrestricted_Access
5158 and then Is_Class_Wide_Type
(Prefix_Type
)
5159 and then (Is_Synchronized_Interface
(Prefix_Type
)
5160 or else Is_Protected_Interface
(Prefix_Type
))
5162 -- If we have not found yet any interpretation then mark this
5163 -- one as the first interpretation (cf. Add_One_Interp).
5165 if No
(Etype
(Sel
)) then
5166 Set_Etype
(Sel
, Any_Type
);
5169 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Prefix_Type
)));
5170 while Present
(Elmt
) loop
5171 Prim
:= Node
(Elmt
);
5173 if Chars
(Prim
) = Chars
(Sel
)
5174 and then Is_By_Protected_Procedure
(Prim
)
5176 Candidate
:= New_Copy
(Prim
);
5178 -- Skip the controlling formal; required to check type
5179 -- conformance of the target access to protected type
5180 -- (see Conforming_Types).
5182 Set_First_Entity
(Candidate
,
5183 Next_Entity
(First_Entity
(Prim
)));
5185 Add_One_Interp
(Sel
, Candidate
, Etype
(Prim
));
5186 Set_Etype
(N
, Etype
(Prim
));
5193 -- Propagate overloaded attribute
5195 if Present
(Candidate
) and then Is_Overloaded
(Sel
) then
5196 Set_Is_Overloaded
(N
);
5199 return Present
(Candidate
);
5200 end Try_By_Protected_Procedure_Prefixed_View
;
5202 ----------------------------------------
5203 -- Try_Selected_Component_In_Instance --
5204 ----------------------------------------
5206 function Try_Selected_Component_In_Instance
5207 (Typ
: Entity_Id
) return Boolean
5209 procedure Find_Component_In_Instance
(Rec
: Entity_Id
);
5210 -- In an instance, a component of a private extension may not be
5211 -- visible while it was visible in the generic. Search candidate
5212 -- scope for a component with the proper identifier. If a match is
5213 -- found, the Etype of both N and Sel are set from this component,
5214 -- and the entity of Sel is set to reference this component. If no
5215 -- match is found, Entity (Sel) remains unset. For a derived type
5216 -- that is an actual of the instance, the desired component may be
5217 -- found in any ancestor.
5219 --------------------------------
5220 -- Find_Component_In_Instance --
5221 --------------------------------
5223 procedure Find_Component_In_Instance
(Rec
: Entity_Id
) is
5229 while Present
(Typ
) loop
5230 Comp
:= First_Component
(Typ
);
5231 while Present
(Comp
) loop
5232 if Chars
(Comp
) = Chars
(Sel
) then
5233 Set_Entity_With_Checks
(Sel
, Comp
);
5234 Set_Etype
(Sel
, Etype
(Comp
));
5235 Set_Etype
(N
, Etype
(Comp
));
5239 Next_Component
(Comp
);
5242 -- If not found, the component may be declared in the parent
5243 -- type or its full view, if any.
5245 if Is_Derived_Type
(Typ
) then
5248 if Is_Private_Type
(Typ
) then
5249 Typ
:= Full_View
(Typ
);
5257 -- If we fall through, no match, so no changes made
5260 end Find_Component_In_Instance
;
5266 -- Start of processing for Try_Selected_Component_In_Instance
5269 pragma Assert
(In_Instance
and then Is_Tagged_Type
(Typ
));
5270 pragma Assert
(Etype
(N
) = Any_Type
);
5272 -- Climb up derivation chain to generic actual subtype
5275 while not Is_Generic_Actual_Type
(Par
) loop
5276 if Ekind
(Par
) = E_Record_Type
then
5277 Par
:= Parent_Subtype
(Par
);
5280 exit when Par
= Etype
(Par
);
5285 -- Another special case: the type is an extension of a private
5286 -- type T, either is an actual in an instance or is immediately
5287 -- visible, and we are in the body of the instance, which means
5288 -- the generic body had a full view of the type declaration for
5289 -- T or some ancestor that defines the component in question.
5290 -- This happens because Is_Visible_Component returned False on
5291 -- this component, as T or the ancestor is still private since
5292 -- the Has_Private_View mechanism is bypassed because T or the
5293 -- ancestor is not directly referenced in the generic body.
5295 if Is_Derived_Type
(Typ
)
5296 and then (Used_As_Generic_Actual
(Base_Type
(Typ
))
5297 or else Is_Immediately_Visible
(Typ
))
5298 and then In_Instance_Body
5299 and then Present
(Parent_Subtype
(Typ
))
5301 Find_Component_In_Instance
(Parent_Subtype
(Typ
));
5303 -- If Par is a generic actual, look for component in ancestor types.
5304 -- Skip this if we have no Declaration_Node, as is the case for
5308 and then Is_Generic_Actual_Type
(Par
)
5309 and then Present
(Declaration_Node
(Par
))
5311 Par
:= Generic_Parent_Type
(Declaration_Node
(Par
));
5313 Find_Component_In_Instance
(Par
);
5314 exit when Present
(Entity
(Sel
))
5315 or else Par
= Etype
(Par
);
5320 return Etype
(N
) /= Any_Type
;
5321 end Try_Selected_Component_In_Instance
;
5323 -- Start of processing for Analyze_Selected_Component
5326 Set_Etype
(N
, Any_Type
);
5328 if Is_Overloaded
(Pref
) then
5329 Analyze_Overloaded_Selected_Component
(N
);
5332 elsif Etype
(Pref
) = Any_Type
then
5333 Set_Entity
(Sel
, Any_Id
);
5334 Set_Etype
(Sel
, Any_Type
);
5338 Prefix_Type
:= Etype
(Pref
);
5341 if Is_Access_Type
(Prefix_Type
) then
5343 -- A RACW object can never be used as prefix of a selected component
5344 -- since that means it is dereferenced without being a controlling
5345 -- operand of a dispatching operation (RM E.2.2(16/1)). Before
5346 -- reporting an error, we must check whether this is actually a
5347 -- dispatching call in prefix form.
5349 if Is_Remote_Access_To_Class_Wide_Type
(Prefix_Type
)
5350 and then Comes_From_Source
(N
)
5352 if Try_Object_Operation
(N
) then
5356 ("invalid dereference of a remote access-to-class-wide value",
5360 -- Normal case of selected component applied to access type
5363 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
5364 Prefix_Type
:= Implicitly_Designated_Type
(Prefix_Type
);
5367 -- Handle mutably tagged types
5369 elsif Is_Class_Wide_Equivalent_Type
(Prefix_Type
) then
5370 Prefix_Type
:= Parent_Subtype
(Prefix_Type
);
5372 -- If we have an explicit dereference of a remote access-to-class-wide
5373 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
5374 -- have to check for the case of a prefix that is a controlling operand
5375 -- of a prefixed dispatching call, as the dereference is legal in that
5376 -- case. Normally this condition is checked in Validate_Remote_Access_
5377 -- To_Class_Wide_Type, but we have to defer the checking for selected
5378 -- component prefixes because of the prefixed dispatching call case.
5379 -- Note that implicit dereferences are checked for this just above.
5381 elsif Nkind
(Pref
) = N_Explicit_Dereference
5382 and then Is_Remote_Access_To_Class_Wide_Type
(Etype
(Prefix
(Pref
)))
5383 and then Comes_From_Source
(N
)
5385 if Try_Object_Operation
(N
) then
5389 ("invalid dereference of a remote access-to-class-wide value",
5394 -- (Ada 2005): if the prefix is the limited view of a type, and
5395 -- the context already includes the full view, use the full view
5396 -- in what follows, either to retrieve a component of to find
5397 -- a primitive operation. If the prefix is an explicit dereference,
5398 -- set the type of the prefix to reflect this transformation.
5399 -- If the nonlimited view is itself an incomplete type, get the
5400 -- full view if available.
5402 if From_Limited_With
(Prefix_Type
)
5403 and then Has_Non_Limited_View
(Prefix_Type
)
5405 Prefix_Type
:= Get_Full_View
(Non_Limited_View
(Prefix_Type
));
5407 if Nkind
(N
) = N_Explicit_Dereference
then
5408 Set_Etype
(Prefix
(N
), Prefix_Type
);
5412 if Ekind
(Prefix_Type
) = E_Private_Subtype
then
5413 Prefix_Type
:= Base_Type
(Prefix_Type
);
5416 Type_To_Use
:= Prefix_Type
;
5418 -- For class-wide types, use the entity list of the root type. This
5419 -- indirection is specially important for private extensions because
5420 -- only the root type get switched (not the class-wide type).
5422 if Is_Class_Wide_Type
(Prefix_Type
) then
5423 Type_To_Use
:= Root_Type
(Prefix_Type
);
5426 -- If the prefix is a single concurrent object, use its name in error
5427 -- messages, rather than that of its anonymous type.
5429 Is_Single_Concurrent_Object
:=
5430 Is_Concurrent_Type
(Prefix_Type
)
5431 and then Is_Internal_Name
(Chars
(Prefix_Type
))
5432 and then not Is_Derived_Type
(Prefix_Type
)
5433 and then Is_Entity_Name
(Pref
);
5435 -- Avoid initializing Comp if that initialization is not needed
5436 -- (and, more importantly, if the call to First_Entity could fail).
5438 if Has_Discriminants
(Type_To_Use
)
5439 or else Is_Record_Type
(Type_To_Use
)
5440 or else Is_Private_Type
(Type_To_Use
)
5441 or else Is_Concurrent_Type
(Type_To_Use
)
5443 Comp
:= First_Entity
(Type_To_Use
);
5446 -- If the selector has an original discriminant, the node appears in
5447 -- an instance. Replace the discriminant with the corresponding one
5448 -- in the current discriminated type. For nested generics, this must
5449 -- be done transitively, so note the new original discriminant.
5451 if Nkind
(Sel
) = N_Identifier
5452 and then In_Instance
5453 and then Present
(Original_Discriminant
(Sel
))
5455 Comp
:= Find_Corresponding_Discriminant
(Sel
, Prefix_Type
);
5457 -- Mark entity before rewriting, for completeness and because
5458 -- subsequent semantic checks might examine the original node.
5460 Set_Entity
(Sel
, Comp
);
5461 Rewrite
(Sel
, New_Occurrence_Of
(Comp
, Sloc
(N
)));
5462 Set_Original_Discriminant
(Sel
, Comp
);
5463 Set_Etype
(N
, Etype
(Comp
));
5464 Check_Implicit_Dereference
(N
, Etype
(Comp
));
5466 elsif Is_Record_Type
(Prefix_Type
) then
5467 -- Find a component with the given name. If the node is a prefixed
5468 -- call, do not examine components whose visibility may be
5471 while Present
(Comp
)
5472 and then not Is_Prefixed_Call
(N
)
5474 -- When the selector has been resolved to a function then we may be
5475 -- looking at a prefixed call which has been preanalyzed already as
5476 -- part of a class condition. In such cases it is possible for a
5477 -- derived type to declare a component which has the same name as
5478 -- a primitive used in a parent's class condition.
5480 -- Avoid seeing components as possible interpretations of the
5481 -- selected component when this is true.
5483 and then not (Inside_Class_Condition_Preanalysis
5484 and then Present
(Entity
(Sel
))
5485 and then Ekind
(Entity
(Sel
)) = E_Function
)
5487 if Chars
(Comp
) = Chars
(Sel
)
5488 and then Is_Visible_Component
(Comp
, N
)
5490 Set_Entity_With_Checks
(Sel
, Comp
);
5491 Set_Etype
(Sel
, Etype
(Comp
));
5493 if Ekind
(Comp
) = E_Discriminant
then
5494 if Is_Unchecked_Union
(Base_Type
(Prefix_Type
)) then
5496 ("cannot reference discriminant of unchecked union",
5500 if Is_Generic_Type
(Prefix_Type
)
5502 Is_Generic_Type
(Root_Type
(Prefix_Type
))
5504 Set_Original_Discriminant
(Sel
, Comp
);
5508 -- Resolve the prefix early otherwise it is not possible to
5509 -- build the actual subtype of the component: it may need
5510 -- to duplicate this prefix and duplication is only allowed
5511 -- on fully resolved expressions.
5515 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
5516 -- subtypes in a package specification.
5519 -- limited with Pkg;
5521 -- type Acc_Inc is access Pkg.T;
5523 -- N : Natural := X.all.Comp; -- ERROR, limited view
5524 -- end Pkg; -- Comp is not visible
5526 if Nkind
(Pref
) = N_Explicit_Dereference
5527 and then From_Limited_With
(Etype
(Prefix
(Pref
)))
5528 and then not Is_Potentially_Use_Visible
(Etype
(Pref
))
5529 and then Nkind
(Parent
(Cunit_Entity
(Current_Sem_Unit
))) =
5530 N_Package_Specification
5533 ("premature usage of incomplete}", Prefix
(Pref
),
5534 Etype
(Prefix
(Pref
)));
5537 -- We generally do not need an actual subtype for the case of
5538 -- a selection for an indexed component of a non-packed array,
5539 -- since, in this case, gigi can find all the necessary bound
5540 -- information. However, when the prefix is itself a selected
5541 -- component, for example a.b.c (i), gigi may regard a.b.c as
5542 -- a dynamic-sized temporary, so we generate an actual subtype
5543 -- for this case. Moreover, if the expressions are complex,
5544 -- the actual subtype may be needed for constructs generated
5545 -- by their analysis.
5547 -- We also do not need an actual subtype for the case of a
5548 -- first, last, length, or range attribute applied to a
5549 -- non-packed array, since gigi can again get the bounds in
5550 -- these cases (gigi cannot handle the packed case, since it
5551 -- has the bounds of the packed array type, not the original
5552 -- bounds of the type).
5554 Parent_N
:= Parent
(N
);
5556 if not Is_Packed
(Etype
(Comp
))
5558 (Is_Simple_Indexed_Component
(Parent_N
)
5560 (Nkind
(Parent_N
) = N_Attribute_Reference
5562 Attribute_Name
(Parent_N
) in Name_First
5567 Set_Etype
(N
, Etype
(Comp
));
5569 -- If full analysis is not enabled, we do not generate an
5570 -- actual subtype, because in the absence of expansion
5571 -- reference to a formal of a protected type, for example,
5572 -- will not be properly transformed, and will lead to
5573 -- out-of-scope references in gigi.
5575 -- In all other cases, we currently build an actual subtype.
5576 -- It seems likely that many of these cases can be avoided,
5577 -- but right now, the front end makes direct references to the
5578 -- bounds (e.g. in generating a length check), and if we do
5579 -- not make an actual subtype, we end up getting a direct
5580 -- reference to a discriminant, which will not do.
5582 elsif Full_Analysis
then
5584 Build_Actual_Subtype_Of_Component
(Etype
(Comp
), N
);
5585 Insert_Action
(N
, Act_Decl
);
5587 if No
(Act_Decl
) then
5588 Set_Etype
(N
, Etype
(Comp
));
5591 -- If discriminants were present in the component
5592 -- declaration, they have been replaced by the
5593 -- actual values in the prefix object.
5596 Subt
: constant Entity_Id
:=
5597 Defining_Identifier
(Act_Decl
);
5599 Set_Etype
(Subt
, Base_Type
(Etype
(Comp
)));
5600 Set_Etype
(N
, Subt
);
5604 -- If Etype (Comp) is an access type whose designated subtype
5605 -- is constrained by an unprefixed discriminant value,
5606 -- then ideally we would build a new subtype with an
5607 -- appropriately prefixed discriminant value and use that
5608 -- instead, as is done in Build_Actual_Subtype_Of_Component.
5609 -- That turns out to be difficult in this context (with
5610 -- Full_Analysis = False, we could be processing a selected
5611 -- component that occurs in a Postcondition pragma;
5612 -- PPC pragmas are odd because they can contain references
5613 -- to formal parameters that occur outside the subprogram).
5614 -- So instead we punt on building a new subtype and we
5615 -- use the base type instead. This might introduce
5616 -- correctness problems if N were the target of an
5617 -- assignment (because a required check might be omitted);
5618 -- fortunately, that's impossible because a reference to the
5619 -- current instance of a type does not denote a variable view
5620 -- when the reference occurs within an aspect_specification.
5621 -- GNAT's Precondition and Postcondition pragmas follow the
5622 -- same rules as a Pre or Post aspect_specification.
5624 elsif Has_Discriminant_Dependent_Constraint
(Comp
)
5625 and then Ekind
(Etype
(Comp
)) = E_Access_Subtype
5626 and then Constraint_Has_Unprefixed_Discriminant_Reference
5627 (Designated_Type
(Etype
(Comp
)))
5629 Set_Etype
(N
, Base_Type
(Etype
(Comp
)));
5631 -- If Full_Analysis not enabled, just set the Etype
5634 Set_Etype
(N
, Etype
(Comp
));
5637 -- Force the generation of a mutably tagged type conversion
5638 -- when we encounter a special class-wide equivalent type.
5640 if Is_Mutably_Tagged_CW_Equivalent_Type
(Etype
(Pref
)) then
5641 Make_Mutably_Tagged_Conversion
(Pref
, Force
=> True);
5644 Check_Implicit_Dereference
(N
, Etype
(N
));
5648 -- If the prefix is a private extension, check only the visible
5649 -- components of the partial view. This must include the tag,
5650 -- which can appear in expanded code in a tag check.
5652 if Ekind
(Type_To_Use
) = E_Record_Type_With_Private
5653 and then Chars
(Sel
) /= Name_uTag
5655 exit when Comp
= Last_Entity
(Type_To_Use
);
5661 -- Ada 2005 (AI-252): The selected component can be interpreted as
5662 -- a prefixed view of a subprogram. Depending on the context, this is
5663 -- either a name that can appear in a renaming declaration, or part
5664 -- of an enclosing call given in prefix form.
5666 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
5667 -- selected component should resolve to a name.
5669 -- Extension feature: Also support calls with prefixed views for
5670 -- untagged record types.
5672 if Ada_Version
>= Ada_2005
5673 and then (Is_Tagged_Type
(Prefix_Type
)
5674 or else Core_Extensions_Allowed
)
5675 and then not Is_Concurrent_Type
(Prefix_Type
)
5677 if Nkind
(Parent
(N
)) = N_Generic_Association
5678 or else Nkind
(Parent
(N
)) = N_Requeue_Statement
5679 or else Nkind
(Parent
(N
)) = N_Subprogram_Renaming_Declaration
5681 if Find_Primitive_Operation
(N
) then
5685 elsif Try_By_Protected_Procedure_Prefixed_View
then
5688 -- If the prefix type is the actual for a formal derived type,
5689 -- or a derived type thereof, the component inherited from the
5690 -- generic parent may not be visible in the actual, but the
5691 -- selected component is legal. This case must be handled before
5692 -- trying the object.operation notation to avoid reporting
5693 -- spurious errors, but must be skipped when Is_Prefixed_Call has
5694 -- been set (because that means that this node was resolved to an
5695 -- Object.Operation call when the generic unit was analyzed).
5698 and then not Is_Prefixed_Call
(N
)
5699 and then Is_Tagged_Type
(Prefix_Type
)
5700 and then Try_Selected_Component_In_Instance
(Type_To_Use
)
5704 elsif Try_Object_Operation
(N
) then
5708 -- If the transformation fails, it will be necessary to redo the
5709 -- analysis with all errors enabled, to indicate candidate
5710 -- interpretations and reasons for each failure ???
5714 elsif Is_Private_Type
(Prefix_Type
) then
5716 -- Allow access only to discriminants of the type. If the type has
5717 -- no full view, gigi uses the parent type for the components, so we
5718 -- do the same here.
5720 if No
(Full_View
(Prefix_Type
)) then
5721 Type_To_Use
:= Root_Type
(Base_Type
(Prefix_Type
));
5722 Comp
:= First_Entity
(Type_To_Use
);
5725 while Present
(Comp
) loop
5726 if Chars
(Comp
) = Chars
(Sel
) then
5727 if Ekind
(Comp
) = E_Discriminant
then
5728 Set_Entity_With_Checks
(Sel
, Comp
);
5729 Generate_Reference
(Comp
, Sel
);
5731 Set_Etype
(Sel
, Etype
(Comp
));
5732 Set_Etype
(N
, Etype
(Comp
));
5733 Check_Implicit_Dereference
(N
, Etype
(N
));
5735 if Is_Generic_Type
(Prefix_Type
)
5736 or else Is_Generic_Type
(Root_Type
(Prefix_Type
))
5738 Set_Original_Discriminant
(Sel
, Comp
);
5741 -- Before declaring an error, check whether this is tagged
5742 -- private type and a call to a primitive operation.
5744 elsif Ada_Version
>= Ada_2005
5745 and then Is_Tagged_Type
(Prefix_Type
)
5746 and then Try_Object_Operation
(N
)
5751 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
5752 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
5753 Set_Entity
(Sel
, Any_Id
);
5754 Set_Etype
(N
, Any_Type
);
5763 -- Extension feature: Also support calls with prefixed views for
5764 -- untagged private types.
5766 if Core_Extensions_Allowed
then
5767 if Try_Object_Operation
(N
) then
5772 elsif Is_Concurrent_Type
(Prefix_Type
) then
5774 -- Find visible operation with given name. For a protected type,
5775 -- the possible candidates are discriminants, entries or protected
5776 -- subprograms. For a task type, the set can only include entries or
5777 -- discriminants if the task type is not an enclosing scope. If it
5778 -- is an enclosing scope (e.g. in an inner task) then all entities
5779 -- are visible, but the prefix must denote the enclosing scope, i.e.
5780 -- can only be a direct name or an expanded name.
5782 Set_Etype
(Sel
, Any_Type
);
5783 Hidden_Comp
:= Empty
;
5784 In_Scope
:= In_Open_Scopes
(Prefix_Type
);
5785 Is_Private_Op
:= False;
5787 while Present
(Comp
) loop
5789 -- Do not examine private operations of the type if not within
5792 if Chars
(Comp
) = Chars
(Sel
) then
5793 if Is_Overloadable
(Comp
)
5795 or else Comp
/= First_Private_Entity
(Type_To_Use
))
5797 Add_One_Interp
(Sel
, Comp
, Etype
(Comp
));
5798 if Comp
= First_Private_Entity
(Type_To_Use
) then
5799 Is_Private_Op
:= True;
5802 -- If the prefix is tagged, the correct interpretation may
5803 -- lie in the primitive or class-wide operations of the
5804 -- type. Perform a simple conformance check to determine
5805 -- whether Try_Object_Operation should be invoked even if
5806 -- a visible entity is found.
5808 if Is_Tagged_Type
(Prefix_Type
)
5809 and then Nkind
(Parent
(N
)) in N_Function_Call
5810 | N_Indexed_Component
5811 | N_Procedure_Call_Statement
5812 and then Has_Mode_Conformant_Spec
(Comp
)
5814 Has_Candidate
:= True;
5817 -- Note: a selected component may not denote a component of a
5818 -- protected type (4.1.3(7)).
5820 elsif Ekind
(Comp
) in E_Discriminant | E_Entry_Family
5822 and then not Is_Protected_Type
(Prefix_Type
)
5823 and then Is_Entity_Name
(Pref
))
5825 Set_Entity_With_Checks
(Sel
, Comp
);
5826 Generate_Reference
(Comp
, Sel
);
5828 -- The selector is not overloadable, so we have a candidate
5831 Has_Candidate
:= True;
5834 if Ekind
(Comp
) = E_Component
then
5835 Hidden_Comp
:= Comp
;
5841 Set_Etype
(Sel
, Etype
(Comp
));
5842 Set_Etype
(N
, Etype
(Comp
));
5844 if Ekind
(Comp
) = E_Discriminant
then
5845 Set_Original_Discriminant
(Sel
, Comp
);
5850 if Comp
= First_Private_Entity
(Type_To_Use
) then
5851 if Etype
(Sel
) /= Any_Type
then
5853 -- If the first private entity's name matches, then treat
5854 -- it as a private op: needed for the error check for
5855 -- illegal selection of private entities further below.
5857 if Chars
(Comp
) = Chars
(Sel
) then
5858 Is_Private_Op
:= True;
5861 -- We have a candidate, so exit the loop
5866 -- Indicate that subsequent operations are private,
5867 -- for better error reporting.
5869 Is_Private_Op
:= True;
5873 -- Do not examine private operations if not within scope of
5874 -- the synchronized type.
5876 exit when not In_Scope
5878 Comp
= First_Private_Entity
(Base_Type
(Prefix_Type
));
5882 -- If the scope is a current instance, the prefix cannot be an
5883 -- expression of the same type, unless the selector designates a
5884 -- public operation (otherwise that would represent an attempt to
5885 -- reach an internal entity of another synchronized object).
5887 -- This is legal if prefix is an access to such type and there is
5888 -- a dereference, or is a component with a dereferenced prefix.
5889 -- It is also legal if the prefix is a component of a task type,
5890 -- and the selector is one of the task operations.
5893 and then not Is_Entity_Name
(Pref
)
5894 and then not Has_Dereference
(Pref
)
5896 if Is_Task_Type
(Prefix_Type
)
5897 and then Present
(Entity
(Sel
))
5898 and then Is_Entry
(Entity
(Sel
))
5902 elsif Is_Protected_Type
(Prefix_Type
)
5903 and then Is_Overloadable
(Entity
(Sel
))
5904 and then not Is_Private_Op
5910 ("invalid reference to internal operation of some object of "
5911 & "type &", N
, Type_To_Use
);
5912 Set_Entity
(Sel
, Any_Id
);
5913 Set_Etype
(Sel
, Any_Type
);
5917 -- Another special case: the prefix may denote an object of the type
5918 -- (but not a type) in which case this is an external call and the
5919 -- operation must be public.
5922 and then Is_Object_Reference
(Original_Node
(Prefix
(N
)))
5923 and then Comes_From_Source
(N
)
5924 and then Is_Private_Op
5926 if Present
(Hidden_Comp
) then
5928 ("invalid reference to private component of object of type "
5929 & "&", N
, Type_To_Use
);
5933 ("invalid reference to private operation of some object of "
5934 & "type &", N
, Type_To_Use
);
5937 Set_Entity
(Sel
, Any_Id
);
5938 Set_Etype
(Sel
, Any_Type
);
5942 -- If there is no visible entity with the given name or none of the
5943 -- visible entities are plausible interpretations, check whether
5944 -- there is some other primitive operation with that name.
5946 if Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Prefix_Type
) then
5947 if (Etype
(N
) = Any_Type
5948 or else not Has_Candidate
)
5949 and then Try_Object_Operation
(N
)
5953 -- If the context is not syntactically a procedure call, it
5954 -- may be a call to a primitive function declared outside of
5955 -- the synchronized type.
5957 -- If the context is a procedure call, there might still be
5958 -- an overloading between an entry and a primitive procedure
5959 -- declared outside of the synchronized type, called in prefix
5960 -- notation. This is harder to disambiguate because in one case
5961 -- the controlling formal is implicit ???
5963 elsif Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
5964 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
5965 and then Try_Object_Operation
(N
)
5970 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
5971 -- entry or procedure of a tagged concurrent type we must check
5972 -- if there are class-wide subprograms covering the primitive. If
5973 -- true then Try_Object_Operation reports the error.
5976 and then Is_Concurrent_Type
(Prefix_Type
)
5977 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5979 -- Duplicate the call. This is required to avoid problems with
5980 -- the tree transformations performed by Try_Object_Operation.
5981 -- Set properly the parent of the copied call, because it is
5982 -- about to be reanalyzed.
5985 Par
: constant Node_Id
:= New_Copy_Tree
(Parent
(N
));
5988 Set_Parent
(Par
, Parent
(Parent
(N
)));
5990 if Try_Object_Operation
5991 (Sinfo
.Nodes
.Name
(Par
), CW_Test_Only
=> True)
5999 if Etype
(N
) = Any_Type
and then Is_Protected_Type
(Prefix_Type
) then
6001 -- Case of a prefix of a protected type: selector might denote
6002 -- an invisible private component.
6004 Comp
:= First_Private_Entity
(Base_Type
(Prefix_Type
));
6005 while Present
(Comp
) and then Chars
(Comp
) /= Chars
(Sel
) loop
6009 if Present
(Comp
) then
6010 if Is_Single_Concurrent_Object
then
6011 Error_Msg_Node_2
:= Entity
(Pref
);
6012 Error_Msg_NE
("invisible selector& for &", N
, Sel
);
6015 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
6016 Error_Msg_NE
("invisible selector& for }", N
, Sel
);
6022 Set_Is_Overloaded
(N
, Is_Overloaded
(Sel
));
6024 -- Extension feature: Also support calls with prefixed views for
6027 elsif Core_Extensions_Allowed
6028 and then Try_Object_Operation
(N
)
6035 Error_Msg_NE
("invalid prefix in selected component&", N
, Sel
);
6038 -- If N still has no type, the component is not defined in the prefix
6040 if Etype
(N
) = Any_Type
then
6042 if Is_Single_Concurrent_Object
then
6043 Error_Msg_Node_2
:= Entity
(Pref
);
6044 Error_Msg_NE
("no selector& for&", N
, Sel
);
6046 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
6048 -- If this is a derived formal type, the parent may have different
6049 -- visibility at this point. Try for an inherited component before
6050 -- reporting an error.
6052 elsif Is_Generic_Type
(Prefix_Type
)
6053 and then Ekind
(Prefix_Type
) = E_Record_Type_With_Private
6054 and then Prefix_Type
/= Etype
(Prefix_Type
)
6055 and then Is_Record_Type
(Etype
(Prefix_Type
))
6057 Set_Etype
(Prefix
(N
), Etype
(Prefix_Type
));
6058 Analyze_Selected_Component
(N
);
6061 -- Similarly, if this is the actual for a formal derived type, or
6062 -- a derived type thereof, the component inherited from the generic
6063 -- parent may not be visible in the actual, but the selected
6064 -- component is legal.
6066 elsif In_Instance
and then Is_Tagged_Type
(Prefix_Type
) then
6068 -- Climb up the derivation chain of the generic parent type until
6069 -- we find the proper ancestor type.
6071 if Try_Selected_Component_In_Instance
(Type_To_Use
) then
6074 -- The search above must have eventually succeeded, since the
6075 -- selected component was legal in the generic.
6078 raise Program_Error
;
6081 -- Component not found, specialize error message when appropriate
6084 if Ekind
(Prefix_Type
) = E_Record_Subtype
then
6086 -- Check whether this is a component of the base type which
6087 -- is absent from a statically constrained subtype. This will
6088 -- raise constraint error at run time, but is not a compile-
6089 -- time error. When the selector is illegal for base type as
6090 -- well fall through and generate a compilation error anyway.
6092 Comp
:= First_Component
(Base_Type
(Prefix_Type
));
6093 while Present
(Comp
) loop
6094 if Chars
(Comp
) = Chars
(Sel
)
6095 and then Is_Visible_Component
(Comp
, Sel
)
6097 Set_Entity_With_Checks
(Sel
, Comp
);
6098 Generate_Reference
(Comp
, Sel
);
6099 Set_Etype
(Sel
, Etype
(Comp
));
6100 Set_Etype
(N
, Etype
(Comp
));
6102 -- Emit appropriate message. The node will be replaced
6103 -- by an appropriate raise statement.
6105 -- Note that in GNATprove mode, as with all calls to
6106 -- apply a compile time constraint error, this will be
6107 -- made into an error to simplify the processing of the
6108 -- formal verification backend.
6110 Apply_Compile_Time_Constraint_Error
6111 (N
, "component not present in }??",
6112 CE_Discriminant_Check_Failed
,
6115 GNATprove_Mode
or not In_Instance_Not_Visible
);
6119 Next_Component
(Comp
);
6124 Error_Msg_Node_2
:= First_Subtype
(Prefix_Type
);
6125 Error_Msg_NE
("no selector& for}", N
, Sel
);
6127 -- Add information in the case of an incomplete prefix
6129 if Is_Incomplete_Type
(Type_To_Use
) then
6131 Inc
: constant Entity_Id
:= First_Subtype
(Type_To_Use
);
6134 if From_Limited_With
(Scope
(Type_To_Use
)) then
6136 ("\limited view of& has no components", N
, Inc
);
6140 ("\premature usage of incomplete type&", N
, Inc
);
6142 if Nkind
(Parent
(Inc
)) =
6143 N_Incomplete_Type_Declaration
6145 -- Record location of premature use in entity so that
6146 -- a continuation message is generated when the
6147 -- completion is seen.
6149 Set_Premature_Use
(Parent
(Inc
), N
);
6155 Check_Misspelled_Selector
(Type_To_Use
, Sel
);
6158 Set_Entity
(Sel
, Any_Id
);
6159 Set_Etype
(Sel
, Any_Type
);
6161 end Analyze_Selected_Component
;
6163 ---------------------------
6164 -- Analyze_Short_Circuit --
6165 ---------------------------
6167 procedure Analyze_Short_Circuit
(N
: Node_Id
) is
6168 L
: constant Node_Id
:= Left_Opnd
(N
);
6169 R
: constant Node_Id
:= Right_Opnd
(N
);
6174 Set_Etype
(N
, Any_Type
);
6175 Analyze_Expression
(L
);
6176 Analyze_Expression
(R
);
6178 if not Is_Overloaded
(L
) then
6179 if Root_Type
(Etype
(L
)) = Standard_Boolean
6180 and then Has_Compatible_Type
(R
, Etype
(L
))
6182 Add_One_Interp
(N
, Etype
(L
), Etype
(L
));
6186 Get_First_Interp
(L
, Ind
, It
);
6187 while Present
(It
.Typ
) loop
6188 if Root_Type
(It
.Typ
) = Standard_Boolean
6189 and then Has_Compatible_Type
(R
, It
.Typ
)
6191 Add_One_Interp
(N
, It
.Typ
, It
.Typ
);
6194 Get_Next_Interp
(Ind
, It
);
6198 -- Here we have failed to find an interpretation. Clearly we know that
6199 -- it is not the case that both operands can have an interpretation of
6200 -- Boolean, but this is by far the most likely intended interpretation.
6201 -- So we simply resolve both operands as Booleans, and at least one of
6202 -- these resolutions will generate an error message, and we do not need
6203 -- to give another error message on the short circuit operation itself.
6205 if Etype
(N
) = Any_Type
then
6206 Resolve
(L
, Standard_Boolean
);
6207 Resolve
(R
, Standard_Boolean
);
6208 Set_Etype
(N
, Standard_Boolean
);
6212 if Nkind
(L
) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor
6214 Check_Xtra_Parens_Precedence
(L
);
6217 if Nkind
(R
) not in N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor
6219 Check_Xtra_Parens_Precedence
(R
);
6222 end Analyze_Short_Circuit
;
6228 procedure Analyze_Slice
(N
: Node_Id
) is
6229 D
: constant Node_Id
:= Discrete_Range
(N
);
6230 P
: constant Node_Id
:= Prefix
(N
);
6231 Array_Type
: Entity_Id
;
6232 Index_Type
: Entity_Id
;
6234 procedure Analyze_Overloaded_Slice
;
6235 -- If the prefix is overloaded, select those interpretations that
6236 -- yield a one-dimensional array type.
6238 ------------------------------
6239 -- Analyze_Overloaded_Slice --
6240 ------------------------------
6242 procedure Analyze_Overloaded_Slice
is
6248 Set_Etype
(N
, Any_Type
);
6250 Get_First_Interp
(P
, I
, It
);
6251 while Present
(It
.Nam
) loop
6254 if Is_Access_Type
(Typ
) then
6255 Typ
:= Designated_Type
(Typ
);
6257 (Warn_On_Dereference
, "?d?implicit dereference", N
);
6260 if Is_Array_Type
(Typ
)
6261 and then Number_Dimensions
(Typ
) = 1
6262 and then Has_Compatible_Type
(D
, Etype
(First_Index
(Typ
)))
6264 Add_One_Interp
(N
, Typ
, Typ
);
6267 Get_Next_Interp
(I
, It
);
6270 if Etype
(N
) = Any_Type
then
6271 Error_Msg_N
("expect array type in prefix of slice", N
);
6273 end Analyze_Overloaded_Slice
;
6275 -- Start of processing for Analyze_Slice
6281 if Is_Overloaded
(P
) then
6282 Analyze_Overloaded_Slice
;
6285 Array_Type
:= Etype
(P
);
6286 Set_Etype
(N
, Any_Type
);
6288 if Is_Access_Type
(Array_Type
) then
6289 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
6290 Array_Type
:= Implicitly_Designated_Type
(Array_Type
);
6293 if not Is_Array_Type
(Array_Type
) then
6294 Wrong_Type
(P
, Any_Array
);
6296 elsif Number_Dimensions
(Array_Type
) > 1 then
6298 ("type is not one-dimensional array in slice prefix", N
);
6301 if Ekind
(Array_Type
) = E_String_Literal_Subtype
then
6302 Index_Type
:= Etype
(String_Literal_Low_Bound
(Array_Type
));
6304 Index_Type
:= Etype
(First_Index
(Array_Type
));
6307 if not Has_Compatible_Type
(D
, Index_Type
) then
6308 Wrong_Type
(D
, Index_Type
);
6310 Set_Etype
(N
, Array_Type
);
6316 -----------------------------
6317 -- Analyze_Type_Conversion --
6318 -----------------------------
6320 procedure Analyze_Type_Conversion
(N
: Node_Id
) is
6321 Expr
: constant Node_Id
:= Expression
(N
);
6322 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
6327 -- If Conversion_OK is set, then the Etype is already set, and the only
6328 -- processing required is to analyze the expression. This is used to
6329 -- construct certain "illegal" conversions which are not allowed by Ada
6330 -- semantics, but can be handled by Gigi, see Sinfo for further details.
6332 if Conversion_OK
(N
) then
6337 -- Otherwise full type analysis is required, as well as some semantic
6338 -- checks to make sure the argument of the conversion is appropriate.
6341 Typ
:= Entity
(Mark
);
6344 Analyze_Expression
(Expr
);
6346 Check_Fully_Declared
(Typ
, N
);
6347 Validate_Remote_Type_Type_Conversion
(N
);
6349 -- Only remaining step is validity checks on the argument. These
6350 -- are skipped if the conversion does not come from the source.
6352 if not Comes_From_Source
(N
) then
6355 -- If there was an error in a generic unit, no need to replicate the
6356 -- error message. Conversely, constant-folding in the generic may
6357 -- transform the argument of a conversion into a string literal, which
6358 -- is legal. Therefore the following tests are not performed in an
6359 -- instance. The same applies to an inlined body.
6361 elsif In_Instance
or In_Inlined_Body
then
6364 elsif Nkind
(Expr
) = N_Null
then
6365 Error_Msg_N
("argument of conversion cannot be null", N
);
6366 Error_Msg_N
("\use qualified expression instead", N
);
6367 Set_Etype
(N
, Any_Type
);
6369 elsif Nkind
(Expr
) = N_Aggregate
then
6370 Error_Msg_N
("argument of conversion cannot be aggregate", N
);
6371 Error_Msg_N
("\use qualified expression instead", N
);
6373 elsif Nkind
(Expr
) = N_Allocator
then
6374 Error_Msg_N
("argument of conversion cannot be allocator", N
);
6375 Error_Msg_N
("\use qualified expression instead", N
);
6377 elsif Nkind
(Expr
) = N_String_Literal
then
6378 Error_Msg_N
("argument of conversion cannot be string literal", N
);
6379 Error_Msg_N
("\use qualified expression instead", N
);
6381 elsif Nkind
(Expr
) = N_Character_Literal
then
6382 if Ada_Version
= Ada_83
then
6383 Resolve
(Expr
, Typ
);
6386 ("argument of conversion cannot be character literal", N
);
6387 Error_Msg_N
("\use qualified expression instead", N
);
6390 elsif Nkind
(Expr
) = N_Attribute_Reference
6391 and then Attribute_Name
(Expr
) in Name_Access
6392 | Name_Unchecked_Access
6393 | Name_Unrestricted_Access
6396 ("argument of conversion cannot be access attribute", N
);
6397 Error_Msg_N
("\use qualified expression instead", N
);
6400 -- A formal parameter of a specific tagged type whose related subprogram
6401 -- is subject to pragma Extensions_Visible with value "False" cannot
6402 -- appear in a class-wide conversion (SPARK RM 6.1.7(3)). Do not check
6403 -- internally generated expressions.
6405 if Is_Class_Wide_Type
(Typ
)
6406 and then Comes_From_Source
(Expr
)
6407 and then Is_EVF_Expression
(Expr
)
6410 ("formal parameter cannot be converted to class-wide type when "
6411 & "Extensions_Visible is False", Expr
);
6414 -- Perform special checking for access to mutably tagged type since they
6415 -- are not compatible with interfaces.
6417 if Is_Access_Type
(Typ
)
6418 and then Is_Access_Type
(Etype
(Expr
))
6419 and then not Error_Posted
(N
)
6422 if Is_Mutably_Tagged_Type
(Directly_Designated_Type
(Typ
))
6423 and then Is_Interface
(Directly_Designated_Type
(Etype
(Expr
)))
6426 ("argument of conversion to mutably tagged access type cannot "
6427 & "be access to interface", Expr
);
6429 elsif Is_Mutably_Tagged_Type
(Directly_Designated_Type
(Etype
(Expr
)))
6430 and then Is_Interface
(Directly_Designated_Type
(Typ
))
6433 ("argument of conversion to interface access type cannot "
6434 & "be access to mutably tagged type", Expr
);
6437 end Analyze_Type_Conversion
;
6439 ----------------------
6440 -- Analyze_Unary_Op --
6441 ----------------------
6443 procedure Analyze_Unary_Op
(N
: Node_Id
) is
6444 R
: constant Node_Id
:= Right_Opnd
(N
);
6449 Set_Etype
(N
, Any_Type
);
6450 Candidate_Type
:= Empty
;
6452 Analyze_Expression
(R
);
6454 -- If the entity is already set, the node is the instantiation of a
6455 -- generic node with a non-local reference, or was manufactured by a
6456 -- call to Make_Op_xxx. In either case the entity is known to be valid,
6457 -- and we do not need to collect interpretations, instead we just get
6458 -- the single possible interpretation.
6460 if Present
(Entity
(N
)) then
6461 Op_Id
:= Entity
(N
);
6463 if Ekind
(Op_Id
) = E_Operator
then
6464 Find_Unary_Types
(R
, Op_Id
, N
);
6466 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
6470 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
6471 while Present
(Op_Id
) loop
6472 if Ekind
(Op_Id
) = E_Operator
then
6473 if No
(Next_Entity
(First_Entity
(Op_Id
))) then
6474 Find_Unary_Types
(R
, Op_Id
, N
);
6477 elsif Is_Overloadable
(Op_Id
) then
6478 Analyze_User_Defined_Unary_Op
(N
, Op_Id
);
6481 Op_Id
:= Homonym
(Op_Id
);
6486 end Analyze_Unary_Op
;
6488 ----------------------------------
6489 -- Analyze_Unchecked_Expression --
6490 ----------------------------------
6492 procedure Analyze_Unchecked_Expression
(N
: Node_Id
) is
6493 Expr
: constant Node_Id
:= Expression
(N
);
6496 Analyze
(Expr
, Suppress
=> All_Checks
);
6497 Set_Etype
(N
, Etype
(Expr
));
6498 Save_Interps
(Expr
, N
);
6499 end Analyze_Unchecked_Expression
;
6501 ---------------------------------------
6502 -- Analyze_Unchecked_Type_Conversion --
6503 ---------------------------------------
6505 procedure Analyze_Unchecked_Type_Conversion
(N
: Node_Id
) is
6506 Expr
: constant Node_Id
:= Expression
(N
);
6507 Mark
: constant Entity_Id
:= Subtype_Mark
(N
);
6511 Set_Etype
(N
, Entity
(Mark
));
6512 Analyze_Expression
(Expr
);
6513 end Analyze_Unchecked_Type_Conversion
;
6515 ------------------------------------
6516 -- Analyze_User_Defined_Binary_Op --
6517 ------------------------------------
6519 procedure Analyze_User_Defined_Binary_Op
6521 Op_Id
: Entity_Id
) is
6524 F1
: constant Entity_Id
:= First_Formal
(Op_Id
);
6525 F2
: constant Entity_Id
:= Next_Formal
(F1
);
6528 -- Verify that Op_Id is a visible binary function. Note that since
6529 -- we know Op_Id is overloaded, potentially use visible means use
6530 -- visible for sure (RM 9.4(11)). Be prepared for previous errors.
6532 if Ekind
(Op_Id
) = E_Function
6533 and then Present
(F2
)
6534 and then (Is_Immediately_Visible
(Op_Id
)
6535 or else Is_Potentially_Use_Visible
(Op_Id
))
6536 and then (Has_Compatible_Type
(Left_Opnd
(N
), Etype
(F1
))
6537 or else Etype
(F1
) = Any_Type
)
6538 and then (Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F2
))
6539 or else Etype
(F2
) = Any_Type
)
6541 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(Op_Id
)));
6543 -- If the operands are overloaded, indicate that the current
6544 -- type is a viable candidate. This is redundant in most cases,
6545 -- but for equality and comparison operators where the context
6546 -- does not impose a type on the operands, setting the proper
6547 -- type is necessary to avoid subsequent ambiguities during
6548 -- resolution, when both user-defined and predefined operators
6549 -- may be candidates.
6551 if Is_Overloaded
(Left_Opnd
(N
)) then
6552 Set_Etype
(Left_Opnd
(N
), Etype
(F1
));
6555 if Is_Overloaded
(Right_Opnd
(N
)) then
6556 Set_Etype
(Right_Opnd
(N
), Etype
(F2
));
6559 if Debug_Flag_E
then
6560 Write_Str
("user defined operator ");
6561 Write_Name
(Chars
(Op_Id
));
6562 Write_Str
(" on node ");
6563 Write_Int
(Int
(N
));
6568 end Analyze_User_Defined_Binary_Op
;
6570 -----------------------------------
6571 -- Analyze_User_Defined_Unary_Op --
6572 -----------------------------------
6574 procedure Analyze_User_Defined_Unary_Op
6579 -- Only do analysis if the operator Comes_From_Source, since otherwise
6580 -- the operator was generated by the expander, and all such operators
6581 -- always refer to the operators in package Standard.
6583 if Comes_From_Source
(N
) then
6585 F
: constant Entity_Id
:= First_Formal
(Op_Id
);
6588 -- Verify that Op_Id is a visible unary function. Note that since
6589 -- we know Op_Id is overloaded, potentially use visible means use
6590 -- visible for sure (RM 9.4(11)).
6592 if Ekind
(Op_Id
) = E_Function
6593 and then No
(Next_Formal
(F
))
6594 and then (Is_Immediately_Visible
(Op_Id
)
6595 or else Is_Potentially_Use_Visible
(Op_Id
))
6596 and then Has_Compatible_Type
(Right_Opnd
(N
), Etype
(F
))
6598 Add_One_Interp
(N
, Op_Id
, Etype
(Op_Id
));
6602 end Analyze_User_Defined_Unary_Op
;
6604 ---------------------------
6605 -- Check_Arithmetic_Pair --
6606 ---------------------------
6608 procedure Check_Arithmetic_Pair
6609 (T1
, T2
: Entity_Id
;
6613 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
6615 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean;
6616 -- Check whether the fixed-point type Typ has a user-defined operator
6617 -- (multiplication or division) that should hide the corresponding
6618 -- predefined operator. Used to implement Ada 2005 AI-264, to make
6619 -- such operators more visible and therefore useful.
6621 -- If the name of the operation is an expanded name with prefix
6622 -- Standard, the predefined universal fixed operator is available,
6623 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
6629 function Has_Fixed_Op
(Typ
: Entity_Id
; Op
: Entity_Id
) return Boolean is
6630 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
6636 -- If the universal_fixed operation is given explicitly the rule
6637 -- concerning primitive operations of the type do not apply.
6639 if Nkind
(N
) = N_Function_Call
6640 and then Nkind
(Name
(N
)) = N_Expanded_Name
6641 and then Entity
(Prefix
(Name
(N
))) = Standard_Standard
6646 -- The operation is treated as primitive if it is declared in the
6647 -- same scope as the type, and therefore on the same entity chain.
6649 Ent
:= Next_Entity
(Typ
);
6650 while Present
(Ent
) loop
6651 if Chars
(Ent
) = Chars
(Op
) then
6652 F1
:= First_Formal
(Ent
);
6653 F2
:= Next_Formal
(F1
);
6655 -- The operation counts as primitive if either operand or
6656 -- result are of the given base type, and both operands are
6657 -- fixed point types.
6659 if (Base_Type
(Etype
(F1
)) = Bas
6660 and then Is_Fixed_Point_Type
(Etype
(F2
)))
6663 (Base_Type
(Etype
(F2
)) = Bas
6664 and then Is_Fixed_Point_Type
(Etype
(F1
)))
6667 (Base_Type
(Etype
(Ent
)) = Bas
6668 and then Is_Fixed_Point_Type
(Etype
(F1
))
6669 and then Is_Fixed_Point_Type
(Etype
(F2
)))
6681 -- Start of processing for Check_Arithmetic_Pair
6684 if Op_Name
in Name_Op_Add | Name_Op_Subtract
then
6685 if Is_Numeric_Type
(T1
)
6686 and then Is_Numeric_Type
(T2
)
6687 and then (Covers
(T1
=> T1
, T2
=> T2
)
6689 Covers
(T1
=> T2
, T2
=> T1
))
6690 and then Is_Effectively_Visible_Operator
6691 (N
, Specific_Type
(T1
, T2
))
6693 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
6696 elsif Op_Name
in Name_Op_Multiply | Name_Op_Divide
then
6697 if Is_Fixed_Point_Type
(T1
)
6698 and then (Is_Fixed_Point_Type
(T2
) or else T2
= Universal_Real
)
6700 -- Add one interpretation with universal fixed result
6702 if not Has_Fixed_Op
(T1
, Op_Id
)
6703 or else Nkind
(Parent
(N
)) = N_Type_Conversion
6705 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
6708 elsif Is_Fixed_Point_Type
(T2
)
6709 and then T1
= Universal_Real
6711 (not Has_Fixed_Op
(T1
, Op_Id
)
6712 or else Nkind
(Parent
(N
)) = N_Type_Conversion
)
6714 Add_One_Interp
(N
, Op_Id
, Universal_Fixed
);
6716 elsif Is_Numeric_Type
(T1
)
6717 and then Is_Numeric_Type
(T2
)
6718 and then (Covers
(T1
=> T1
, T2
=> T2
)
6720 Covers
(T1
=> T2
, T2
=> T1
))
6721 and then Is_Effectively_Visible_Operator
6722 (N
, Specific_Type
(T1
, T2
))
6724 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
6726 elsif Is_Fixed_Point_Type
(T1
)
6727 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
6728 or else T2
= Universal_Integer
)
6730 Add_One_Interp
(N
, Op_Id
, T1
);
6732 elsif T2
= Universal_Real
6733 and then Base_Type
(T1
) = Base_Type
(Standard_Integer
)
6734 and then Op_Name
= Name_Op_Multiply
6736 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
6738 elsif T1
= Universal_Real
6739 and then Base_Type
(T2
) = Base_Type
(Standard_Integer
)
6741 Add_One_Interp
(N
, Op_Id
, Any_Fixed
);
6743 elsif Is_Fixed_Point_Type
(T2
)
6744 and then (Base_Type
(T1
) = Base_Type
(Standard_Integer
)
6745 or else T1
= Universal_Integer
)
6746 and then Op_Name
= Name_Op_Multiply
6748 Add_One_Interp
(N
, Op_Id
, T2
);
6750 elsif T1
= Universal_Real
and then T2
= Universal_Integer
then
6751 Add_One_Interp
(N
, Op_Id
, T1
);
6753 elsif T2
= Universal_Real
6754 and then T1
= Universal_Integer
6755 and then Op_Name
= Name_Op_Multiply
6757 Add_One_Interp
(N
, Op_Id
, T2
);
6760 elsif Op_Name
= Name_Op_Mod
or else Op_Name
= Name_Op_Rem
then
6762 if Is_Integer_Type
(T1
)
6763 and then (Covers
(T1
=> T1
, T2
=> T2
)
6765 Covers
(T1
=> T2
, T2
=> T1
))
6766 and then Is_Effectively_Visible_Operator
6767 (N
, Specific_Type
(T1
, T2
))
6769 Add_One_Interp
(N
, Op_Id
, Specific_Type
(T1
, T2
));
6772 elsif Op_Name
= Name_Op_Expon
then
6773 if Is_Numeric_Type
(T1
)
6774 and then not Is_Fixed_Point_Type
(T1
)
6775 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
6776 or else T2
= Universal_Integer
)
6778 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
6781 else pragma Assert
(Nkind
(N
) in N_Op_Shift
);
6783 -- If not one of the predefined operators, the node may be one
6784 -- of the intrinsic functions. Its kind is always specific, and
6785 -- we can use it directly, rather than the name of the operation.
6787 if Is_Integer_Type
(T1
)
6788 and then (Base_Type
(T2
) = Base_Type
(Standard_Integer
)
6789 or else T2
= Universal_Integer
)
6791 Add_One_Interp
(N
, Op_Id
, Base_Type
(T1
));
6794 end Check_Arithmetic_Pair
;
6796 -------------------------------
6797 -- Check_Misspelled_Selector --
6798 -------------------------------
6800 procedure Check_Misspelled_Selector
6801 (Prefix
: Entity_Id
;
6804 Max_Suggestions
: constant := 2;
6805 Nr_Of_Suggestions
: Natural := 0;
6807 Suggestion_1
: Entity_Id
:= Empty
;
6808 Suggestion_2
: Entity_Id
:= Empty
;
6813 -- All the components of the prefix of selector Sel are matched against
6814 -- Sel and a count is maintained of possible misspellings. When at
6815 -- the end of the analysis there are one or two (not more) possible
6816 -- misspellings, these misspellings will be suggested as possible
6819 if not (Is_Private_Type
(Prefix
) or else Is_Record_Type
(Prefix
)) then
6821 -- Concurrent types should be handled as well ???
6826 Comp
:= First_Entity
(Prefix
);
6827 while Nr_Of_Suggestions
<= Max_Suggestions
and then Present
(Comp
) loop
6828 if Is_Visible_Component
(Comp
, Sel
) then
6829 if Is_Bad_Spelling_Of
(Chars
(Comp
), Chars
(Sel
)) then
6830 Nr_Of_Suggestions
:= Nr_Of_Suggestions
+ 1;
6832 case Nr_Of_Suggestions
is
6833 when 1 => Suggestion_1
:= Comp
;
6834 when 2 => Suggestion_2
:= Comp
;
6835 when others => null;
6843 -- Report at most two suggestions
6845 if Nr_Of_Suggestions
= 1 then
6846 Error_Msg_NE
-- CODEFIX
6847 ("\possible misspelling of&", Sel
, Suggestion_1
);
6849 elsif Nr_Of_Suggestions
= 2 then
6850 Error_Msg_Node_2
:= Suggestion_2
;
6851 Error_Msg_NE
-- CODEFIX
6852 ("\possible misspelling of& or&", Sel
, Suggestion_1
);
6854 end Check_Misspelled_Selector
;
6860 procedure Diagnose_Call
(N
: Node_Id
; Nam
: Node_Id
) is
6866 Num_Actuals
: Natural;
6867 Num_Interps
: Natural;
6868 Void_Interp_Seen
: Boolean := False;
6871 pragma Warnings
(Off
, Boolean);
6875 Actual
:= First_Actual
(N
);
6877 while Present
(Actual
) loop
6878 -- Ada 2005 (AI-50217): Post an error in case of premature
6879 -- usage of an entity from the limited view.
6881 if not Analyzed
(Etype
(Actual
))
6882 and then From_Limited_With
(Etype
(Actual
))
6883 and then Ada_Version
>= Ada_2005
6885 Error_Msg_Qual_Level
:= 1;
6887 ("missing with_clause for scope of imported type&",
6888 Actual
, Etype
(Actual
));
6889 Error_Msg_Qual_Level
:= 0;
6892 Num_Actuals
:= Num_Actuals
+ 1;
6893 Next_Actual
(Actual
);
6896 -- Before listing the possible candidates, check whether this is
6897 -- a prefix of a selected component that has been rewritten as a
6898 -- parameterless function call because there is a callable candidate
6899 -- interpretation. If there is a hidden package in the list of homonyms
6900 -- of the function name (bad programming style in any case) suggest that
6901 -- this is the intended entity.
6903 if No
(Parameter_Associations
(N
))
6904 and then Nkind
(Parent
(N
)) = N_Selected_Component
6905 and then Nkind
(Parent
(Parent
(N
))) in N_Declaration
6906 and then Is_Overloaded
(Nam
)
6912 Ent
:= Current_Entity
(Nam
);
6913 while Present
(Ent
) loop
6914 if Ekind
(Ent
) = E_Package
then
6916 ("no legal interpretations as function call,!", Nam
);
6917 Error_Msg_NE
("\package& is not visible", N
, Ent
);
6919 Rewrite
(Parent
(N
),
6920 New_Occurrence_Of
(Any_Type
, Sloc
(N
)));
6924 Ent
:= Homonym
(Ent
);
6929 -- If this is a call to an operation of a concurrent type, the failed
6930 -- interpretations have been removed from the name. Recover them now
6931 -- in order to provide full diagnostics.
6933 if Nkind
(Parent
(Nam
)) = N_Selected_Component
then
6934 Set_Entity
(Nam
, Empty
);
6935 New_Nam
:= New_Copy_Tree
(Parent
(Nam
));
6936 Set_Is_Overloaded
(New_Nam
, False);
6937 Set_Is_Overloaded
(Selector_Name
(New_Nam
), False);
6938 Set_Parent
(New_Nam
, Parent
(Parent
(Nam
)));
6939 Analyze_Selected_Component
(New_Nam
);
6940 Get_First_Interp
(Selector_Name
(New_Nam
), X
, It
);
6942 Get_First_Interp
(Nam
, X
, It
);
6945 -- If the number of actuals is 2, then remove interpretations involving
6946 -- a unary "+" operator as they might yield confusing errors downstream.
6949 and then Nkind
(Parent
(Nam
)) /= N_Selected_Component
6953 while Present
(It
.Nam
) loop
6954 if Ekind
(It
.Nam
) = E_Operator
6955 and then Chars
(It
.Nam
) = Name_Op_Add
6956 and then (No
(First_Formal
(It
.Nam
))
6957 or else No
(Next_Formal
(First_Formal
(It
.Nam
))))
6961 Num_Interps
:= Num_Interps
+ 1;
6964 Get_Next_Interp
(X
, It
);
6967 if Num_Interps
= 0 then
6968 Error_Msg_N
("!too many arguments in call to&", Nam
);
6972 Get_First_Interp
(Nam
, X
, It
);
6975 Num_Interps
:= 2; -- at least
6978 -- Analyze each candidate call again with full error reporting for each
6980 if Num_Interps
> 1 then
6981 Error_Msg_N
("!no candidate interpretations match the actuals:", Nam
);
6984 Err_Mode
:= All_Errors_Mode
;
6985 All_Errors_Mode
:= True;
6987 while Present
(It
.Nam
) loop
6988 if Etype
(It
.Nam
) = Standard_Void_Type
then
6989 Void_Interp_Seen
:= True;
6992 Analyze_One_Call
(N
, It
.Nam
, True, Success
);
6993 Get_Next_Interp
(X
, It
);
6996 if Nkind
(N
) = N_Function_Call
then
6997 Get_First_Interp
(Nam
, X
, It
);
7000 and then Ekind
(Entity
(Name
(N
))) = E_Function
7001 and then Present
(Homonym
(Entity
(Name
(N
))))
7003 -- A name may appear overloaded if it has a homonym, even if that
7004 -- homonym is non-overloadable, in which case the overload list is
7005 -- in fact empty. This specialized case deserves a special message
7006 -- if the homonym is a child package.
7009 Nam
: constant Node_Id
:= Name
(N
);
7010 H
: constant Entity_Id
:= Homonym
(Entity
(Nam
));
7013 if Ekind
(H
) = E_Package
and then Is_Child_Unit
(H
) then
7014 Error_Msg_Qual_Level
:= 2;
7015 Error_Msg_NE
("if an entity in package& is meant, ", Nam
, H
);
7016 Error_Msg_NE
("\use a fully qualified name", Nam
, H
);
7017 Error_Msg_Qual_Level
:= 0;
7022 while Present
(It
.Nam
) loop
7023 if Ekind
(It
.Nam
) in E_Function | E_Operator
then
7026 Get_Next_Interp
(X
, It
);
7030 -- If all interpretations are procedures, this deserves a more
7031 -- precise message. Ditto if this appears as the prefix of a
7032 -- selected component, which may be a lexical error.
7035 ("\context requires function call, found procedure name", Nam
);
7037 if Nkind
(Parent
(N
)) = N_Selected_Component
7038 and then N
= Prefix
(Parent
(N
))
7040 Error_Msg_N
-- CODEFIX
7041 ("\period should probably be semicolon", Parent
(N
));
7045 elsif Nkind
(N
) = N_Procedure_Call_Statement
7046 and then not Void_Interp_Seen
7048 Error_Msg_N
("\function name found in procedure call", Nam
);
7051 All_Errors_Mode
:= Err_Mode
;
7054 ---------------------------
7055 -- Find_Arithmetic_Types --
7056 ---------------------------
7058 procedure Find_Arithmetic_Types
7063 procedure Check_Right_Argument
(T
: Entity_Id
);
7064 -- Check right operand of operator
7066 --------------------------
7067 -- Check_Right_Argument --
7068 --------------------------
7070 procedure Check_Right_Argument
(T
: Entity_Id
) is
7075 if not Is_Overloaded
(R
) then
7076 Check_Arithmetic_Pair
(T
, Etype
(R
), Op_Id
, N
);
7079 Get_First_Interp
(R
, I
, It
);
7080 while Present
(It
.Typ
) loop
7081 Check_Arithmetic_Pair
(T
, It
.Typ
, Op_Id
, N
);
7082 Get_Next_Interp
(I
, It
);
7085 end Check_Right_Argument
;
7092 -- Start of processing for Find_Arithmetic_Types
7095 if not Is_Overloaded
(L
) then
7096 Check_Right_Argument
(Etype
(L
));
7099 Get_First_Interp
(L
, I
, It
);
7100 while Present
(It
.Typ
) loop
7101 Check_Right_Argument
(It
.Typ
);
7102 Get_Next_Interp
(I
, It
);
7105 end Find_Arithmetic_Types
;
7107 ------------------------
7108 -- Find_Boolean_Types --
7109 ------------------------
7111 procedure Find_Boolean_Types
7116 procedure Check_Boolean_Pair
(T1
, T2
: Entity_Id
);
7117 -- Check operand pair of operator
7119 procedure Check_Right_Argument
(T
: Entity_Id
);
7120 -- Check right operand of operator
7122 ------------------------
7123 -- Check_Boolean_Pair --
7124 ------------------------
7126 procedure Check_Boolean_Pair
(T1
, T2
: Entity_Id
) is
7130 if Valid_Boolean_Arg
(T1
)
7131 and then Valid_Boolean_Arg
(T2
)
7132 and then (Covers
(T1
=> T1
, T2
=> T2
)
7133 or else Covers
(T1
=> T2
, T2
=> T1
))
7135 T
:= Specific_Type
(T1
, T2
);
7137 if T
= Universal_Integer
then
7141 -- test Is_Effectively_Visible_Operator here ???
7142 Add_One_Interp
(N
, Op_Id
, T
);
7144 end Check_Boolean_Pair
;
7146 --------------------------
7147 -- Check_Right_Argument --
7148 --------------------------
7150 procedure Check_Right_Argument
(T
: Entity_Id
) is
7155 -- Defend against previous error
7157 if Nkind
(R
) = N_Error
then
7160 elsif not Is_Overloaded
(R
) then
7161 Check_Boolean_Pair
(T
, Etype
(R
));
7164 Get_First_Interp
(R
, I
, It
);
7165 while Present
(It
.Typ
) loop
7166 Check_Boolean_Pair
(T
, It
.Typ
);
7167 Get_Next_Interp
(I
, It
);
7170 end Check_Right_Argument
;
7177 -- Start of processing for Find_Boolean_Types
7180 if not Is_Overloaded
(L
) then
7181 Check_Right_Argument
(Etype
(L
));
7184 Get_First_Interp
(L
, I
, It
);
7185 while Present
(It
.Typ
) loop
7186 Check_Right_Argument
(It
.Typ
);
7187 Get_Next_Interp
(I
, It
);
7190 end Find_Boolean_Types
;
7192 ------------------------------------
7193 -- Find_Comparison_Equality_Types --
7194 ------------------------------------
7196 -- The context of the operator plays no role in resolving the operands,
7197 -- so that if there is more than one interpretation of the operands that
7198 -- is compatible with the comparison or equality, then the operation is
7199 -- ambiguous, but this cannot be reported at this point because there is
7200 -- no guarantee that the operation will be resolved to this operator yet.
7202 procedure Find_Comparison_Equality_Types
7207 Op_Name
: constant Name_Id
:= Chars
(Op_Id
);
7208 Op_Typ
: Entity_Id
renames Standard_Boolean
;
7210 function Try_Left_Interp
(T
: Entity_Id
) return Entity_Id
;
7211 -- Try an interpretation of the left operand with type T. Return the
7212 -- type of the interpretation of the right operand making up a valid
7213 -- operand pair, or else Any_Type if the right operand is ambiguous,
7214 -- otherwise Empty if no such pair exists.
7216 function Is_Valid_Comparison_Type
(T
: Entity_Id
) return Boolean;
7217 -- Return true if T is a valid comparison type
7219 function Is_Valid_Equality_Type
7221 Anon_Access
: Boolean) return Boolean;
7222 -- Return true if T is a valid equality type
7224 function Is_Valid_Pair
(T1
, T2
: Entity_Id
) return Boolean;
7225 -- Return true if T1 and T2 constitute a valid pair of operand types for
7226 -- L and R respectively.
7228 ---------------------
7229 -- Try_Left_Interp --
7230 ---------------------
7232 function Try_Left_Interp
(T
: Entity_Id
) return Entity_Id
is
7236 Valid_I
: Interp_Index
;
7239 -- Defend against previous error
7241 if Nkind
(R
) = N_Error
then
7244 -- Loop through the interpretations of the right operand
7246 elsif not Is_Overloaded
(R
) then
7247 if Is_Valid_Pair
(T
, Etype
(R
)) then
7255 Get_First_Interp
(R
, I
, It
);
7256 while Present
(It
.Typ
) loop
7257 if Is_Valid_Pair
(T
, It
.Typ
) then
7258 -- If several interpretations are possible, disambiguate
7261 and then Base_Type
(It
.Typ
) /= Base_Type
(R_Typ
)
7263 It
:= Disambiguate
(R
, Valid_I
, I
, Any_Type
);
7265 if It
= No_Interp
then
7277 Get_Next_Interp
(I
, It
);
7280 if Present
(R_Typ
) then
7286 end Try_Left_Interp
;
7288 ------------------------------
7289 -- Is_Valid_Comparison_Type --
7290 ------------------------------
7292 function Is_Valid_Comparison_Type
(T
: Entity_Id
) return Boolean is
7294 -- The operation must be performed in a context where the operators
7295 -- of the base type are visible.
7297 if Is_Visible_Operator
(N
, Base_Type
(T
)) then
7300 -- Save candidate type for subsequent error message, if any
7303 if Valid_Comparison_Arg
(T
) then
7304 Candidate_Type
:= T
;
7310 -- Defer to the common implementation for the rest
7312 return Valid_Comparison_Arg
(T
);
7313 end Is_Valid_Comparison_Type
;
7315 ----------------------------
7316 -- Is_Valid_Equality_Type --
7317 ----------------------------
7319 function Is_Valid_Equality_Type
7321 Anon_Access
: Boolean) return Boolean
7324 -- The operation must be performed in a context where the operators
7325 -- of the base type are visible. Deal with special types used with
7326 -- access types before type resolution is done.
7328 if Ekind
(T
) = E_Access_Attribute_Type
7329 or else (Ekind
(T
) in E_Access_Subprogram_Type
7330 | E_Access_Protected_Subprogram_Type
7332 Ekind
(Designated_Type
(T
)) /= E_Subprogram_Type
)
7333 or else Is_Visible_Operator
(N
, Base_Type
(T
))
7337 -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
7338 -- anonymous access types in universal_access equality operators.
7340 elsif Anon_Access
then
7341 if Ada_Version
< Ada_2005
then
7345 -- Save candidate type for subsequent error message, if any
7348 if Valid_Equality_Arg
(T
) then
7349 Candidate_Type
:= T
;
7355 -- For the use of a "/=" operator on a tagged type, several possible
7356 -- interpretations of equality need to be considered, we don't want
7357 -- the default inequality declared in Standard to be chosen, and the
7358 -- "/=" operator will be rewritten as a negation of "=" (see the end
7359 -- of Analyze_Comparison_Equality_Op). This ensures the rewriting
7360 -- occurs during analysis rather than being delayed until expansion.
7361 -- Note that, if the node is N_Op_Ne but Op_Id is Name_Op_Eq, then we
7362 -- still proceed with the interpretation, because this indicates
7363 -- the aforementioned rewriting case where the interpretation to be
7364 -- considered is actually that of the "=" operator.
7366 if Nkind
(N
) = N_Op_Ne
7367 and then Op_Name
/= Name_Op_Eq
7368 and then Is_Tagged_Type
(T
)
7372 -- Defer to the common implementation for the rest
7375 return Valid_Equality_Arg
(T
);
7377 end Is_Valid_Equality_Type
;
7383 function Is_Valid_Pair
(T1
, T2
: Entity_Id
) return Boolean is
7385 if Op_Name
= Name_Op_Eq
or else Op_Name
= Name_Op_Ne
then
7387 Anon_Access
: constant Boolean :=
7388 Is_Anonymous_Access_Type
(T1
)
7389 or else Is_Anonymous_Access_Type
(T2
);
7390 -- RM 4.5.2(9.1/2): At least one of the operands of an equality
7391 -- operator for universal_access shall be of specific anonymous
7395 if not Is_Valid_Equality_Type
(T1
, Anon_Access
)
7396 or else not Is_Valid_Equality_Type
(T2
, Anon_Access
)
7403 if not Is_Valid_Comparison_Type
(T1
)
7404 or else not Is_Valid_Comparison_Type
(T2
)
7410 return Covers
(T1
=> T1
, T2
=> T2
)
7411 or else Covers
(T1
=> T2
, T2
=> T1
)
7412 or else Is_User_Defined_Literal
(L
, T2
)
7413 or else Is_User_Defined_Literal
(R
, T1
);
7423 Valid_I
: Interp_Index
;
7425 -- Start of processing for Find_Comparison_Equality_Types
7428 -- Loop through the interpretations of the left operand
7430 if not Is_Overloaded
(L
) then
7431 T
:= Try_Left_Interp
(Etype
(L
));
7435 Add_One_Interp
(N
, Op_Id
, Op_Typ
, Find_Unique_Type
(L
, R
));
7443 Get_First_Interp
(L
, I
, It
);
7444 while Present
(It
.Typ
) loop
7445 T
:= Try_Left_Interp
(It
.Typ
);
7448 -- If several interpretations are possible, disambiguate
7451 and then Base_Type
(It
.Typ
) /= Base_Type
(L_Typ
)
7453 It
:= Disambiguate
(L
, Valid_I
, I
, Any_Type
);
7455 if It
= No_Interp
then
7469 Get_Next_Interp
(I
, It
);
7472 if Present
(L_Typ
) then
7473 Set_Etype
(L
, L_Typ
);
7474 Set_Etype
(R
, R_Typ
);
7475 Add_One_Interp
(N
, Op_Id
, Op_Typ
, Find_Unique_Type
(L
, R
));
7478 end Find_Comparison_Equality_Types
;
7480 ------------------------------
7481 -- Find_Concatenation_Types --
7482 ------------------------------
7484 procedure Find_Concatenation_Types
7489 Is_String
: constant Boolean := Nkind
(L
) = N_String_Literal
7491 Nkind
(R
) = N_String_Literal
;
7492 Op_Type
: constant Entity_Id
:= Etype
(Op_Id
);
7495 if Is_Array_Type
(Op_Type
)
7497 -- Small but very effective optimization: if at least one operand is a
7498 -- string literal, then the type of the operator must be either array
7499 -- of characters or array of strings.
7501 and then (not Is_String
7503 Is_Character_Type
(Component_Type
(Op_Type
))
7505 Is_String_Type
(Component_Type
(Op_Type
)))
7507 and then not Is_Limited_Type
(Op_Type
)
7509 and then (Has_Compatible_Type
(L
, Op_Type
)
7511 Has_Compatible_Type
(L
, Component_Type
(Op_Type
)))
7513 and then (Has_Compatible_Type
(R
, Op_Type
)
7515 Has_Compatible_Type
(R
, Component_Type
(Op_Type
)))
7517 Add_One_Interp
(N
, Op_Id
, Op_Type
);
7519 end Find_Concatenation_Types
;
7521 -------------------------
7522 -- Find_Negation_Types --
7523 -------------------------
7525 procedure Find_Negation_Types
7530 Index
: Interp_Index
;
7534 if not Is_Overloaded
(R
) then
7535 if Etype
(R
) = Universal_Integer
then
7536 Add_One_Interp
(N
, Op_Id
, Any_Modular
);
7537 elsif Valid_Boolean_Arg
(Etype
(R
)) then
7538 Add_One_Interp
(N
, Op_Id
, Etype
(R
));
7542 Get_First_Interp
(R
, Index
, It
);
7543 while Present
(It
.Typ
) loop
7544 if Valid_Boolean_Arg
(It
.Typ
) then
7545 Add_One_Interp
(N
, Op_Id
, It
.Typ
);
7548 Get_Next_Interp
(Index
, It
);
7551 end Find_Negation_Types
;
7553 ------------------------------
7554 -- Find_Primitive_Operation --
7555 ------------------------------
7557 function Find_Primitive_Operation
(N
: Node_Id
) return Boolean is
7558 Obj
: constant Node_Id
:= Prefix
(N
);
7559 Op
: constant Node_Id
:= Selector_Name
(N
);
7566 Set_Etype
(Op
, Any_Type
);
7568 if Is_Access_Type
(Etype
(Obj
)) then
7569 Typ
:= Designated_Type
(Etype
(Obj
));
7574 if Is_Class_Wide_Type
(Typ
) then
7575 Typ
:= Root_Type
(Typ
);
7578 Prims
:= Primitive_Operations
(Typ
);
7580 Prim
:= First_Elmt
(Prims
);
7581 while Present
(Prim
) loop
7582 if Chars
(Node
(Prim
)) = Chars
(Op
) then
7583 Add_One_Interp
(Op
, Node
(Prim
), Etype
(Node
(Prim
)));
7584 Set_Etype
(N
, Etype
(Node
(Prim
)));
7590 -- Now look for class-wide operations of the type or any of its
7591 -- ancestors by iterating over the homonyms of the selector.
7594 Cls_Type
: constant Entity_Id
:= Class_Wide_Type
(Typ
);
7598 Hom
:= Current_Entity
(Op
);
7599 while Present
(Hom
) loop
7600 if (Ekind
(Hom
) = E_Procedure
7602 Ekind
(Hom
) = E_Function
)
7603 and then Scope
(Hom
) = Scope
(Typ
)
7604 and then Present
(First_Formal
(Hom
))
7606 (Base_Type
(Etype
(First_Formal
(Hom
))) = Cls_Type
7608 (Is_Access_Type
(Etype
(First_Formal
(Hom
)))
7610 Ekind
(Etype
(First_Formal
(Hom
))) =
7611 E_Anonymous_Access_Type
7614 (Designated_Type
(Etype
(First_Formal
(Hom
)))) =
7617 Add_One_Interp
(Op
, Hom
, Etype
(Hom
));
7618 Set_Etype
(N
, Etype
(Hom
));
7621 Hom
:= Homonym
(Hom
);
7625 return Etype
(Op
) /= Any_Type
;
7626 end Find_Primitive_Operation
;
7628 ----------------------
7629 -- Find_Unary_Types --
7630 ----------------------
7632 procedure Find_Unary_Types
7637 Index
: Interp_Index
;
7641 if not Is_Overloaded
(R
) then
7642 if Is_Numeric_Type
(Etype
(R
)) then
7644 -- In an instance a generic actual may be a numeric type even if
7645 -- the formal in the generic unit was not. In that case, the
7646 -- predefined operator was not a possible interpretation in the
7647 -- generic, and cannot be one in the instance, unless the operator
7648 -- is an actual of an instance.
7652 not Is_Numeric_Type
(Corresponding_Generic_Type
(Etype
(R
)))
7656 Add_One_Interp
(N
, Op_Id
, Base_Type
(Etype
(R
)));
7661 Get_First_Interp
(R
, Index
, It
);
7662 while Present
(It
.Typ
) loop
7663 if Is_Numeric_Type
(It
.Typ
) then
7667 (Corresponding_Generic_Type
(Etype
(It
.Typ
)))
7671 elsif Is_Effectively_Visible_Operator
(N
, Base_Type
(It
.Typ
))
7673 Add_One_Interp
(N
, Op_Id
, Base_Type
(It
.Typ
));
7677 Get_Next_Interp
(Index
, It
);
7680 end Find_Unary_Types
;
7686 function Junk_Operand
(N
: Node_Id
) return Boolean is
7690 if Error_Posted
(N
) then
7694 -- Get entity to be tested
7696 if Is_Entity_Name
(N
)
7697 and then Present
(Entity
(N
))
7701 -- An odd case, a procedure name gets converted to a very peculiar
7702 -- function call, and here is where we detect this happening.
7704 elsif Nkind
(N
) = N_Function_Call
7705 and then Is_Entity_Name
(Name
(N
))
7706 and then Present
(Entity
(Name
(N
)))
7710 -- Another odd case, there are at least some cases of selected
7711 -- components where the selected component is not marked as having
7712 -- an entity, even though the selector does have an entity
7714 elsif Nkind
(N
) = N_Selected_Component
7715 and then Present
(Entity
(Selector_Name
(N
)))
7717 Enode
:= Selector_Name
(N
);
7723 -- Now test the entity we got to see if it is a bad case
7725 case Ekind
(Entity
(Enode
)) is
7728 ("package name cannot be used as operand", Enode
);
7730 when Generic_Unit_Kind
=>
7732 ("generic unit name cannot be used as operand", Enode
);
7736 ("subtype name cannot be used as operand", Enode
);
7740 ("entry name cannot be used as operand", Enode
);
7744 ("procedure name cannot be used as operand", Enode
);
7748 ("exception name cannot be used as operand", Enode
);
7755 ("label name cannot be used as operand", Enode
);
7764 --------------------
7765 -- Operator_Check --
7766 --------------------
7768 procedure Operator_Check
(N
: Node_Id
) is
7770 Remove_Abstract_Operations
(N
);
7772 -- Test for case of no interpretation found for operator
7774 if Etype
(N
) = Any_Type
then
7776 L
: constant Node_Id
:=
7777 (if Nkind
(N
) in N_Binary_Op
then Left_Opnd
(N
) else Empty
);
7778 R
: constant Node_Id
:= Right_Opnd
(N
);
7781 -- If either operand has no type, then don't complain further,
7782 -- since this simply means that we have a propagated error.
7785 or else Etype
(R
) = Any_Type
7786 or else (Nkind
(N
) in N_Binary_Op
and then Etype
(L
) = Any_Type
)
7788 -- For the rather unusual case where one of the operands is
7789 -- a Raise_Expression, whose initial type is Any_Type, use
7790 -- the type of the other operand.
7792 if Nkind
(L
) = N_Raise_Expression
then
7793 Set_Etype
(L
, Etype
(R
));
7794 Set_Etype
(N
, Etype
(R
));
7796 elsif Nkind
(R
) = N_Raise_Expression
then
7797 Set_Etype
(R
, Etype
(L
));
7798 Set_Etype
(N
, Etype
(L
));
7803 -- We explicitly check for the case of concatenation of component
7804 -- with component to avoid reporting spurious matching array types
7805 -- that might happen to be lurking in distant packages (such as
7806 -- run-time packages). This also prevents inconsistencies in the
7807 -- messages for certain ACVC B tests, which can vary depending on
7808 -- types declared in run-time interfaces. Another improvement when
7809 -- aggregates are present is to look for a well-typed operand.
7811 elsif Present
(Candidate_Type
)
7812 and then (Nkind
(N
) /= N_Op_Concat
7813 or else Is_Array_Type
(Etype
(L
))
7814 or else Is_Array_Type
(Etype
(R
)))
7816 if Nkind
(N
) = N_Op_Concat
then
7817 if Etype
(L
) /= Any_Composite
7818 and then Is_Array_Type
(Etype
(L
))
7820 Candidate_Type
:= Etype
(L
);
7822 elsif Etype
(R
) /= Any_Composite
7823 and then Is_Array_Type
(Etype
(R
))
7825 Candidate_Type
:= Etype
(R
);
7829 Error_Msg_NE
-- CODEFIX
7830 ("operator for} is not directly visible!",
7831 N
, First_Subtype
(Candidate_Type
));
7834 U
: constant Node_Id
:=
7835 Cunit
(Get_Source_Unit
(Candidate_Type
));
7837 if Unit_Is_Visible
(U
) then
7838 Error_Msg_N
-- CODEFIX
7839 ("use clause would make operation legal!", N
);
7841 Error_Msg_NE
-- CODEFIX
7842 ("add with_clause and use_clause for&!",
7843 N
, Defining_Entity
(Unit
(U
)));
7848 -- If either operand is a junk operand (e.g. package name), then
7849 -- post appropriate error messages, but do not complain further.
7851 -- Note that the use of OR in this test instead of OR ELSE is
7852 -- quite deliberate, we may as well check both operands in the
7853 -- binary operator case.
7855 elsif Junk_Operand
(R
)
7856 or -- really mean OR here and not OR ELSE, see above
7857 (Nkind
(N
) in N_Binary_Op
and then Junk_Operand
(L
))
7861 -- The handling of user-defined literals is deferred to the second
7862 -- pass of resolution.
7864 elsif Has_Possible_User_Defined_Literal
(N
) then
7867 -- If we have a logical operator, one of whose operands is
7868 -- Boolean, then we know that the other operand cannot resolve to
7869 -- Boolean (since we got no interpretations), but in that case we
7870 -- pretty much know that the other operand should be Boolean, so
7871 -- resolve it that way (generating an error).
7873 elsif Nkind
(N
) in N_Op_And | N_Op_Or | N_Op_Xor
then
7874 if Etype
(L
) = Standard_Boolean
then
7875 Resolve
(R
, Standard_Boolean
);
7877 elsif Etype
(R
) = Standard_Boolean
then
7878 Resolve
(L
, Standard_Boolean
);
7882 -- For an arithmetic operator or comparison operator, if one
7883 -- of the operands is numeric, then we know the other operand
7884 -- is not the same numeric type. If it is a non-numeric type,
7885 -- then probably it is intended to match the other operand.
7887 elsif Nkind
(N
) in N_Op_Add
7898 -- If Allow_Integer_Address is active, check whether the
7899 -- operation becomes legal after converting an operand.
7901 if Is_Numeric_Type
(Etype
(L
))
7902 and then not Is_Numeric_Type
(Etype
(R
))
7904 if Address_Integer_Convert_OK
(Etype
(R
), Etype
(L
)) then
7906 Unchecked_Convert_To
(
7907 Standard_Address
, Relocate_Node
(L
)));
7909 Unchecked_Convert_To
(
7910 Standard_Address
, Relocate_Node
(R
)));
7912 if Nkind
(N
) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt
then
7913 Analyze_Comparison_Equality_Op
(N
);
7915 Analyze_Arithmetic_Op
(N
);
7918 Resolve
(R
, Etype
(L
));
7923 elsif Is_Numeric_Type
(Etype
(R
))
7924 and then not Is_Numeric_Type
(Etype
(L
))
7926 if Address_Integer_Convert_OK
(Etype
(L
), Etype
(R
)) then
7928 Unchecked_Convert_To
(
7929 Standard_Address
, Relocate_Node
(L
)));
7931 Unchecked_Convert_To
(
7932 Standard_Address
, Relocate_Node
(R
)));
7934 if Nkind
(N
) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt
then
7935 Analyze_Comparison_Equality_Op
(N
);
7937 Analyze_Arithmetic_Op
(N
);
7943 Resolve
(L
, Etype
(R
));
7948 elsif Allow_Integer_Address
7949 and then Is_Descendant_Of_Address
(Etype
(L
))
7950 and then Is_Descendant_Of_Address
(Etype
(R
))
7951 and then not Error_Posted
(N
)
7954 Addr_Type
: constant Entity_Id
:= Etype
(L
);
7958 Unchecked_Convert_To
(
7959 Standard_Address
, Relocate_Node
(L
)));
7961 Unchecked_Convert_To
(
7962 Standard_Address
, Relocate_Node
(R
)));
7964 if Nkind
(N
) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt
then
7965 Analyze_Comparison_Equality_Op
(N
);
7967 Analyze_Arithmetic_Op
(N
);
7970 -- If this is an operand in an enclosing arithmetic
7971 -- operation, Convert the result as an address so that
7972 -- arithmetic folding of address can continue.
7974 if Nkind
(Parent
(N
)) in N_Op
then
7976 Unchecked_Convert_To
(Addr_Type
, Relocate_Node
(N
)));
7982 -- Under relaxed RM semantics silently replace occurrences of
7983 -- null by System.Address_Null.
7985 elsif Null_To_Null_Address_Convert_OK
(N
) then
7986 Replace_Null_By_Null_Address
(N
);
7988 if Nkind
(N
) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt
then
7989 Analyze_Comparison_Equality_Op
(N
);
7991 Analyze_Arithmetic_Op
(N
);
7997 -- Comparisons on A'Access are common enough to deserve a
8000 elsif Nkind
(N
) in N_Op_Eq | N_Op_Ne
8001 and then Ekind
(Etype
(L
)) = E_Access_Attribute_Type
8002 and then Ekind
(Etype
(R
)) = E_Access_Attribute_Type
8005 ("two access attributes cannot be compared directly", N
);
8007 ("\use qualified expression for one of the operands",
8011 -- Another one for C programmers
8013 elsif Nkind
(N
) = N_Op_Concat
8014 and then Valid_Boolean_Arg
(Etype
(L
))
8015 and then Valid_Boolean_Arg
(Etype
(R
))
8017 Error_Msg_N
("invalid operands for concatenation", N
);
8018 Error_Msg_N
-- CODEFIX
8019 ("\maybe AND was meant", N
);
8022 -- A special case for comparison of access parameter with null
8024 elsif Nkind
(N
) = N_Op_Eq
8025 and then Is_Entity_Name
(L
)
8026 and then Nkind
(Parent
(Entity
(L
))) = N_Parameter_Specification
8027 and then Nkind
(Parameter_Type
(Parent
(Entity
(L
)))) =
8029 and then Nkind
(R
) = N_Null
8031 Error_Msg_N
("access parameter is not allowed to be null", L
);
8032 Error_Msg_N
("\(call would raise Constraint_Error)", L
);
8035 -- Another special case for exponentiation, where the right
8036 -- operand must be Natural, independently of the base.
8038 elsif Nkind
(N
) = N_Op_Expon
8039 and then Is_Numeric_Type
(Etype
(L
))
8040 and then not Is_Overloaded
(R
)
8042 First_Subtype
(Base_Type
(Etype
(R
))) /= Standard_Integer
8043 and then Base_Type
(Etype
(R
)) /= Universal_Integer
8045 if Ada_Version
>= Ada_2012
8046 and then Has_Dimension_System
(Etype
(L
))
8049 ("exponent for dimensioned type must be a rational" &
8050 ", found}", R
, Etype
(R
));
8053 ("exponent must be of type Natural, found}", R
, Etype
(R
));
8058 elsif Nkind
(N
) in N_Op_Eq | N_Op_Ne
then
8059 if Address_Integer_Convert_OK
(Etype
(R
), Etype
(L
)) then
8061 Unchecked_Convert_To
(
8062 Standard_Address
, Relocate_Node
(L
)));
8064 Unchecked_Convert_To
(
8065 Standard_Address
, Relocate_Node
(R
)));
8066 Analyze_Comparison_Equality_Op
(N
);
8069 -- Under relaxed RM semantics silently replace occurrences of
8070 -- null by System.Address_Null.
8072 elsif Null_To_Null_Address_Convert_OK
(N
) then
8073 Replace_Null_By_Null_Address
(N
);
8074 Analyze_Comparison_Equality_Op
(N
);
8079 -- If we fall through then just give general message
8081 Unresolved_Operator
(N
);
8086 ---------------------------------------
8087 -- Has_Possible_User_Defined_Literal --
8088 ---------------------------------------
8090 function Has_Possible_User_Defined_Literal
(N
: Node_Id
) return Boolean is
8091 R
: constant Node_Id
:= Right_Opnd
(N
);
8093 procedure Check_Literal_Opnd
(Opnd
: Node_Id
);
8094 -- If an operand is a literal to which an aspect may apply,
8095 -- add the corresponding type to operator node.
8097 ------------------------
8098 -- Check_Literal_Opnd --
8099 ------------------------
8101 procedure Check_Literal_Opnd
(Opnd
: Node_Id
) is
8103 if Nkind
(Opnd
) in N_Numeric_Or_String_Literal
8104 or else (Is_Entity_Name
(Opnd
)
8105 and then Present
(Entity
(Opnd
))
8106 and then Is_Named_Number
(Entity
(Opnd
)))
8108 Add_One_Interp
(N
, Etype
(Opnd
), Etype
(Opnd
));
8110 end Check_Literal_Opnd
;
8112 -- Start of processing for Has_Possible_User_Defined_Literal
8115 if Ada_Version
< Ada_2022
then
8119 Check_Literal_Opnd
(R
);
8121 -- Check left operand only if right one did not provide a
8122 -- possible interpretation. Note that literal types are not
8123 -- overloadable, in the sense that there is no overloadable
8124 -- entity name whose several interpretations can be used to
8125 -- indicate possible resulting types, so there is no way to
8126 -- provide more than one interpretation to the operator node.
8127 -- The choice of one operand over the other is arbitrary at
8128 -- this point, and may lead to spurious resolution when both
8129 -- operands are literals of different kinds, but the second
8130 -- pass of resolution will examine anew both operands to
8131 -- determine whether a user-defined literal may apply to
8134 if Nkind
(N
) in N_Binary_Op
and then Etype
(N
) = Any_Type
then
8135 Check_Literal_Opnd
(Left_Opnd
(N
));
8138 return Etype
(N
) /= Any_Type
;
8139 end Has_Possible_User_Defined_Literal
;
8141 -----------------------------------------------
8142 -- Nondispatching_Call_To_Abstract_Operation --
8143 -----------------------------------------------
8145 procedure Nondispatching_Call_To_Abstract_Operation
8147 Abstract_Op
: Entity_Id
)
8149 Typ
: constant Entity_Id
:= Etype
(N
);
8152 -- In an instance body, this is a runtime check, but one we know will
8153 -- fail, so give an appropriate warning. As usual this kind of warning
8154 -- is an error in SPARK mode.
8156 Error_Msg_Sloc
:= Sloc
(Abstract_Op
);
8158 if In_Instance_Body
and then SPARK_Mode
/= On
then
8160 ("??cannot call abstract operation& declared#",
8162 Error_Msg_N
("\Program_Error [??", N
);
8164 Make_Raise_Program_Error
(Sloc
(N
),
8165 Reason
=> PE_Explicit_Raise
));
8171 ("cannot call abstract operation& declared#",
8173 Set_Etype
(N
, Any_Type
);
8175 end Nondispatching_Call_To_Abstract_Operation
;
8177 ----------------------------------------------
8178 -- Possible_Type_For_Conditional_Expression --
8179 ----------------------------------------------
8181 function Possible_Type_For_Conditional_Expression
8182 (T1
, T2
: Entity_Id
) return Entity_Id
8184 function Is_Access_Protected_Subprogram_Attribute
8185 (T
: Entity_Id
) return Boolean;
8186 -- Return true if T is the type of an access-to-protected-subprogram
8189 function Is_Access_Subprogram_Attribute
(T
: Entity_Id
) return Boolean;
8190 -- Return true if T is the type of an access-to-subprogram attribute
8192 ----------------------------------------------
8193 -- Is_Access_Protected_Subprogram_Attribute --
8194 ----------------------------------------------
8196 function Is_Access_Protected_Subprogram_Attribute
8197 (T
: Entity_Id
) return Boolean
8200 return Ekind
(T
) = E_Access_Protected_Subprogram_Type
8201 and then Ekind
(Designated_Type
(T
)) /= E_Subprogram_Type
;
8202 end Is_Access_Protected_Subprogram_Attribute
;
8204 ------------------------------------
8205 -- Is_Access_Subprogram_Attribute --
8206 ------------------------------------
8208 function Is_Access_Subprogram_Attribute
(T
: Entity_Id
) return Boolean is
8210 return Ekind
(T
) = E_Access_Subprogram_Type
8211 and then Ekind
(Designated_Type
(T
)) /= E_Subprogram_Type
;
8212 end Is_Access_Subprogram_Attribute
;
8214 -- Start of processing for Possible_Type_For_Conditional_Expression
8217 -- If both types are those of similar access attributes or allocators,
8218 -- pick one of them, for example the first.
8220 if Ekind
(T1
) in E_Access_Attribute_Type | E_Allocator_Type
8221 and then Ekind
(T2
) in E_Access_Attribute_Type | E_Allocator_Type
8225 elsif Is_Access_Subprogram_Attribute
(T1
)
8226 and then Is_Access_Subprogram_Attribute
(T2
)
8228 Subtype_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
8232 elsif Is_Access_Protected_Subprogram_Attribute
(T1
)
8233 and then Is_Access_Protected_Subprogram_Attribute
(T2
)
8235 Subtype_Conformant
(Designated_Type
(T1
), Designated_Type
(T2
))
8239 -- The other case to be considered is a pair of tagged types
8241 elsif Is_Tagged_Type
(T1
) and then Is_Tagged_Type
(T2
) then
8242 -- Covers performs the same checks when T1 or T2 are a CW type, so
8243 -- we don't need to do them again here.
8245 if not Is_Class_Wide_Type
(T1
) and then Is_Ancestor
(T1
, T2
) then
8248 elsif not Is_Class_Wide_Type
(T2
) and then Is_Ancestor
(T2
, T1
) then
8251 -- Neither type is an ancestor of the other, but they may have one in
8252 -- common, so we pick the first type as above. We could perform here
8253 -- the computation of the nearest common ancestors of T1 and T2, but
8254 -- this would require a significant amount of work and the practical
8255 -- benefit would very likely be negligible.
8261 -- Otherwise no type is possible
8266 end Possible_Type_For_Conditional_Expression
;
8268 --------------------------------
8269 -- Remove_Abstract_Operations --
8270 --------------------------------
8272 procedure Remove_Abstract_Operations
(N
: Node_Id
) is
8273 Abstract_Op
: Entity_Id
:= Empty
;
8274 Address_Descendant
: Boolean := False;
8278 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
8279 -- activate this if either extensions are enabled, or if the abstract
8280 -- operation in question comes from a predefined file. This latter test
8281 -- allows us to use abstract to make operations invisible to users. In
8282 -- particular, if type Address is non-private and abstract subprograms
8283 -- are used to hide its operators, they will be truly hidden.
8285 type Operand_Position
is (First_Op
, Second_Op
);
8286 Univ_Type
: constant Entity_Id
:= Universal_Interpretation
(N
);
8288 procedure Remove_Address_Interpretations
(Op
: Operand_Position
);
8289 -- Ambiguities may arise when the operands are literal and the address
8290 -- operations in s-auxdec are visible. In that case, remove the
8291 -- interpretation of a literal as Address, to retain the semantics
8292 -- of Address as a private type.
8294 ------------------------------------
8295 -- Remove_Address_Interpretations --
8296 ------------------------------------
8298 procedure Remove_Address_Interpretations
(Op
: Operand_Position
) is
8302 if Is_Overloaded
(N
) then
8303 Get_First_Interp
(N
, I
, It
);
8304 while Present
(It
.Nam
) loop
8305 Formal
:= First_Entity
(It
.Nam
);
8307 if Op
= Second_Op
then
8308 Next_Entity
(Formal
);
8311 if Is_Descendant_Of_Address
(Etype
(Formal
)) then
8312 Address_Descendant
:= True;
8316 Get_Next_Interp
(I
, It
);
8319 end Remove_Address_Interpretations
;
8321 -- Start of processing for Remove_Abstract_Operations
8324 if Is_Overloaded
(N
) then
8325 if Debug_Flag_V
then
8326 Write_Line
("Remove_Abstract_Operations: ");
8327 Write_Overloads
(N
);
8330 Get_First_Interp
(N
, I
, It
);
8332 while Present
(It
.Nam
) loop
8333 if Is_Overloadable
(It
.Nam
)
8334 and then Is_Abstract_Subprogram
(It
.Nam
)
8335 and then not Is_Dispatching_Operation
(It
.Nam
)
8337 Abstract_Op
:= It
.Nam
;
8339 if Is_Descendant_Of_Address
(It
.Typ
) then
8340 Address_Descendant
:= True;
8344 -- In Ada 2005, this operation does not participate in overload
8345 -- resolution. If the operation is defined in a predefined
8346 -- unit, it is one of the operations declared abstract in some
8347 -- variants of System, and it must be removed as well.
8349 elsif Ada_Version
>= Ada_2005
8350 or else In_Predefined_Unit
(It
.Nam
)
8357 Get_Next_Interp
(I
, It
);
8360 if No
(Abstract_Op
) then
8362 -- If some interpretation yields an integer type, it is still
8363 -- possible that there are address interpretations. Remove them
8364 -- if one operand is a literal, to avoid spurious ambiguities
8365 -- on systems where Address is a visible integer type.
8367 if Is_Overloaded
(N
)
8368 and then Nkind
(N
) in N_Op
8369 and then Is_Integer_Type
(Etype
(N
))
8371 if Nkind
(N
) in N_Binary_Op
then
8372 if Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
then
8373 Remove_Address_Interpretations
(Second_Op
);
8375 elsif Nkind
(Left_Opnd
(N
)) = N_Integer_Literal
then
8376 Remove_Address_Interpretations
(First_Op
);
8381 elsif Nkind
(N
) in N_Op
then
8383 -- Remove interpretations that treat literals as addresses. This
8384 -- is never appropriate, even when Address is defined as a visible
8385 -- Integer type. The reason is that we would really prefer Address
8386 -- to behave as a private type, even in this case. If Address is a
8387 -- visible integer type, we get lots of overload ambiguities.
8389 if Nkind
(N
) in N_Binary_Op
then
8391 U1
: constant Boolean :=
8392 Present
(Universal_Interpretation
(Right_Opnd
(N
)));
8393 U2
: constant Boolean :=
8394 Present
(Universal_Interpretation
(Left_Opnd
(N
)));
8398 Remove_Address_Interpretations
(Second_Op
);
8402 Remove_Address_Interpretations
(First_Op
);
8405 if not (U1
and U2
) then
8407 -- Remove corresponding predefined operator, which is
8408 -- always added to the overload set.
8410 Get_First_Interp
(N
, I
, It
);
8411 while Present
(It
.Nam
) loop
8412 if Scope
(It
.Nam
) = Standard_Standard
8413 and then Base_Type
(It
.Typ
) =
8414 Base_Type
(Etype
(Abstract_Op
))
8419 Get_Next_Interp
(I
, It
);
8422 elsif Is_Overloaded
(N
)
8423 and then Present
(Univ_Type
)
8425 -- If both operands have a universal interpretation,
8426 -- it is still necessary to remove interpretations that
8427 -- yield Address. Any remaining ambiguities will be
8428 -- removed in Disambiguate.
8430 Get_First_Interp
(N
, I
, It
);
8431 while Present
(It
.Nam
) loop
8432 if Is_Descendant_Of_Address
(It
.Typ
) then
8435 elsif not Is_Type
(It
.Nam
) then
8436 Set_Entity
(N
, It
.Nam
);
8439 Get_Next_Interp
(I
, It
);
8445 elsif Nkind
(N
) = N_Function_Call
8447 (Nkind
(Name
(N
)) = N_Operator_Symbol
8449 (Nkind
(Name
(N
)) = N_Expanded_Name
8451 Nkind
(Selector_Name
(Name
(N
))) = N_Operator_Symbol
))
8455 Arg1
: constant Node_Id
:= First
(Parameter_Associations
(N
));
8456 U1
: constant Boolean :=
8457 Present
(Universal_Interpretation
(Arg1
));
8458 U2
: constant Boolean :=
8459 Present
(Next
(Arg1
)) and then
8460 Present
(Universal_Interpretation
(Next
(Arg1
)));
8464 Remove_Address_Interpretations
(First_Op
);
8468 Remove_Address_Interpretations
(Second_Op
);
8471 if not (U1
and U2
) then
8472 Get_First_Interp
(N
, I
, It
);
8473 while Present
(It
.Nam
) loop
8474 if Scope
(It
.Nam
) = Standard_Standard
8475 and then It
.Typ
= Base_Type
(Etype
(Abstract_Op
))
8480 Get_Next_Interp
(I
, It
);
8486 -- If the removal has left no valid interpretations, emit an error
8487 -- message now and label node as illegal.
8489 if Present
(Abstract_Op
) then
8490 Get_First_Interp
(N
, I
, It
);
8494 -- Removal of abstract operation left no viable candidate
8496 Nondispatching_Call_To_Abstract_Operation
(N
, Abstract_Op
);
8498 -- In Ada 2005, an abstract operation may disable predefined
8499 -- operators. Since the context is not yet known, we mark the
8500 -- predefined operators as potentially hidden. Do not include
8501 -- predefined operators when addresses are involved since this
8502 -- case is handled separately.
8504 elsif Ada_Version
>= Ada_2005
and then not Address_Descendant
then
8505 while Present
(It
.Nam
) loop
8506 if Is_Numeric_Type
(It
.Typ
)
8507 and then Scope
(It
.Typ
) = Standard_Standard
8508 and then Ekind
(It
.Nam
) = E_Operator
8510 Set_Abstract_Op
(I
, Abstract_Op
);
8513 Get_Next_Interp
(I
, It
);
8518 if Debug_Flag_V
then
8519 Write_Line
("Remove_Abstract_Operations done: ");
8520 Write_Overloads
(N
);
8523 end Remove_Abstract_Operations
;
8525 ----------------------------
8526 -- Try_Container_Indexing --
8527 ----------------------------
8529 function Try_Container_Indexing
8532 Exprs
: List_Id
) return Boolean
8534 Pref_Typ
: Entity_Id
:= Etype
(Prefix
);
8536 function Constant_Indexing_OK
return Boolean;
8537 -- Constant_Indexing is legal if there is no Variable_Indexing defined
8538 -- for the type, or else node not a target of assignment, or an actual
8539 -- for an IN OUT or OUT formal (RM 4.1.6 (11)).
8541 function Expr_Matches_In_Formal
8543 Par
: Node_Id
) return Boolean;
8544 -- Find formal corresponding to given indexed component that is an
8545 -- actual in a call. Note that the enclosing subprogram call has not
8546 -- been analyzed yet, and the parameter list is not normalized, so
8547 -- that if the argument is a parameter association we must match it
8548 -- by name and not by position.
8550 function Find_Indexing_Operations
8553 Is_Constant
: Boolean) return Node_Id
;
8554 -- Return a reference to the primitive operation of type T denoted by
8555 -- name Nam. If the operation is overloaded, the reference carries all
8556 -- interpretations. Flag Is_Constant should be set when the context is
8557 -- constant indexing.
8559 --------------------------
8560 -- Constant_Indexing_OK --
8561 --------------------------
8563 function Constant_Indexing_OK
return Boolean is
8567 if No
(Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Variable_Indexing
)) then
8570 elsif not Is_Variable
(Prefix
) then
8575 while Present
(Par
) loop
8576 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
8577 and then Par
= Name
(Parent
(Par
))
8581 -- The call may be overloaded, in which case we assume that its
8582 -- resolution does not depend on the type of the parameter that
8583 -- includes the indexing operation.
8585 elsif Nkind
(Parent
(Par
)) in N_Subprogram_Call
then
8587 if not Is_Entity_Name
(Name
(Parent
(Par
))) then
8589 -- ??? We don't know what to do with an N_Selected_Component
8590 -- node for a prefixed-notation call to AA.BB where AA's
8591 -- type is known, but BB has not yet been resolved. In that
8592 -- case, the preceding Is_Entity_Name call returns False.
8593 -- Incorrectly returning False here will usually work
8594 -- better than incorrectly returning True, so that's what
8604 -- We should look for an interpretation with the proper
8605 -- number of formals, and determine whether it is an
8606 -- In_Parameter, but for now we examine the formal that
8607 -- corresponds to the indexing, and assume that variable
8608 -- indexing is required if some interpretation has an
8609 -- assignable formal at that position. Still does not
8610 -- cover the most complex cases ???
8612 if Is_Overloaded
(Name
(Parent
(Par
))) then
8614 Proc
: constant Node_Id
:= Name
(Parent
(Par
));
8619 Get_First_Interp
(Proc
, I
, It
);
8620 while Present
(It
.Nam
) loop
8621 if not Expr_Matches_In_Formal
(It
.Nam
, Par
) then
8625 Get_Next_Interp
(I
, It
);
8629 -- All interpretations have a matching in-mode formal
8634 Proc
:= Entity
(Name
(Parent
(Par
)));
8636 -- If this is an indirect call, get formals from
8639 if Is_Access_Subprogram_Type
(Etype
(Proc
)) then
8640 Proc
:= Designated_Type
(Etype
(Proc
));
8644 return Expr_Matches_In_Formal
(Proc
, Par
);
8647 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
8650 -- If the indexed component is a prefix it may be the first actual
8651 -- of a prefixed call. Retrieve the called entity, if any, and
8652 -- check its first formal. Determine if the context is a procedure
8653 -- or function call.
8655 elsif Nkind
(Parent
(Par
)) = N_Selected_Component
then
8657 Sel
: constant Node_Id
:= Selector_Name
(Parent
(Par
));
8658 Nam
: constant Entity_Id
:= Current_Entity
(Sel
);
8661 if Present
(Nam
) and then Is_Overloadable
(Nam
) then
8662 if Nkind
(Parent
(Parent
(Par
))) =
8663 N_Procedure_Call_Statement
8667 elsif Ekind
(Nam
) = E_Function
8668 and then Present
(First_Formal
(Nam
))
8670 return Ekind
(First_Formal
(Nam
)) = E_In_Parameter
;
8675 elsif Nkind
(Par
) in N_Op
then
8679 Par
:= Parent
(Par
);
8682 -- In all other cases, constant indexing is legal
8685 end Constant_Indexing_OK
;
8687 ----------------------------
8688 -- Expr_Matches_In_Formal --
8689 ----------------------------
8691 function Expr_Matches_In_Formal
8693 Par
: Node_Id
) return Boolean
8699 Formal
:= First_Formal
(Subp
);
8700 Actual
:= First
(Parameter_Associations
((Parent
(Par
))));
8702 if Nkind
(Par
) /= N_Parameter_Association
then
8704 -- Match by position
8706 while Present
(Actual
) and then Present
(Formal
) loop
8707 exit when Actual
= Par
;
8710 if Present
(Formal
) then
8711 Next_Formal
(Formal
);
8713 -- Otherwise this is a parameter mismatch, the error is
8714 -- reported elsewhere, or else variable indexing is implied.
8724 while Present
(Formal
) loop
8725 exit when Chars
(Formal
) = Chars
(Selector_Name
(Par
));
8726 Next_Formal
(Formal
);
8734 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Parameter
;
8735 end Expr_Matches_In_Formal
;
8737 ------------------------------
8738 -- Find_Indexing_Operations --
8739 ------------------------------
8741 function Find_Indexing_Operations
8744 Is_Constant
: Boolean) return Node_Id
8746 procedure Inspect_Declarations
8748 Ref
: in out Node_Id
);
8749 -- Traverse the declarative list where type Typ resides and collect
8750 -- all suitable interpretations in node Ref.
8752 procedure Inspect_Primitives
8754 Ref
: in out Node_Id
);
8755 -- Traverse the list of primitive operations of type Typ and collect
8756 -- all suitable interpretations in node Ref.
8758 function Is_OK_Candidate
8759 (Subp_Id
: Entity_Id
;
8760 Typ
: Entity_Id
) return Boolean;
8761 -- Determine whether subprogram Subp_Id is a suitable indexing
8762 -- operation for type Typ. To qualify as such, the subprogram must
8763 -- be a function, have at least two parameters, and the type of the
8764 -- first parameter must be either Typ, or Typ'Class, or access [to
8765 -- constant] with designated type Typ or Typ'Class.
8767 procedure Record_Interp
(Subp_Id
: Entity_Id
; Ref
: in out Node_Id
);
8768 -- Store subprogram Subp_Id as an interpretation in node Ref
8770 --------------------------
8771 -- Inspect_Declarations --
8772 --------------------------
8774 procedure Inspect_Declarations
8776 Ref
: in out Node_Id
)
8778 Typ_Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
8780 Subp_Id
: Entity_Id
;
8783 -- Ensure that the routine is not called with itypes, which lack a
8784 -- declarative node.
8786 pragma Assert
(Present
(Typ_Decl
));
8787 pragma Assert
(Is_List_Member
(Typ_Decl
));
8789 Decl
:= First
(List_Containing
(Typ_Decl
));
8790 while Present
(Decl
) loop
8791 if Nkind
(Decl
) = N_Subprogram_Declaration
then
8792 Subp_Id
:= Defining_Entity
(Decl
);
8794 if Is_OK_Candidate
(Subp_Id
, Typ
) then
8795 Record_Interp
(Subp_Id
, Ref
);
8801 end Inspect_Declarations
;
8803 ------------------------
8804 -- Inspect_Primitives --
8805 ------------------------
8807 procedure Inspect_Primitives
8809 Ref
: in out Node_Id
)
8811 Prim_Elmt
: Elmt_Id
;
8812 Prim_Id
: Entity_Id
;
8815 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8816 while Present
(Prim_Elmt
) loop
8817 Prim_Id
:= Node
(Prim_Elmt
);
8819 if Is_OK_Candidate
(Prim_Id
, Typ
) then
8820 Record_Interp
(Prim_Id
, Ref
);
8823 Next_Elmt
(Prim_Elmt
);
8825 end Inspect_Primitives
;
8827 ---------------------
8828 -- Is_OK_Candidate --
8829 ---------------------
8831 function Is_OK_Candidate
8832 (Subp_Id
: Entity_Id
;
8833 Typ
: Entity_Id
) return Boolean
8836 Formal_Typ
: Entity_Id
;
8837 Param_Typ
: Node_Id
;
8840 -- To classify as a suitable candidate, the subprogram must be a
8841 -- function whose name matches the argument of aspect Constant or
8842 -- Variable_Indexing.
8844 if Ekind
(Subp_Id
) = E_Function
and then Chars
(Subp_Id
) = Nam
then
8845 Formal
:= First_Formal
(Subp_Id
);
8847 -- The candidate requires at least two parameters
8849 if Present
(Formal
) and then Present
(Next_Formal
(Formal
)) then
8850 Formal_Typ
:= Empty
;
8851 Param_Typ
:= Parameter_Type
(Parent
(Formal
));
8853 -- Use the designated type when the first parameter is of an
8856 if Nkind
(Param_Typ
) = N_Access_Definition
8857 and then Present
(Subtype_Mark
(Param_Typ
))
8859 -- When the context is a constant indexing, the access
8860 -- definition must be access-to-constant. This does not
8861 -- apply to variable indexing.
8864 or else Constant_Present
(Param_Typ
)
8866 Formal_Typ
:= Etype
(Subtype_Mark
(Param_Typ
));
8869 -- Otherwise use the parameter type
8872 Formal_Typ
:= Etype
(Param_Typ
);
8875 if Present
(Formal_Typ
) then
8877 -- Use the specific type when the parameter type is
8880 if Is_Class_Wide_Type
(Formal_Typ
) then
8881 Formal_Typ
:= Etype
(Base_Type
(Formal_Typ
));
8884 -- Use the full view when the parameter type is private
8887 if Is_Incomplete_Or_Private_Type
(Formal_Typ
)
8888 and then Present
(Full_View
(Formal_Typ
))
8890 Formal_Typ
:= Full_View
(Formal_Typ
);
8893 -- The type of the first parameter must denote the type
8894 -- of the container or acts as its ancestor type.
8898 or else Is_Ancestor
(Formal_Typ
, Typ
);
8904 end Is_OK_Candidate
;
8910 procedure Record_Interp
(Subp_Id
: Entity_Id
; Ref
: in out Node_Id
) is
8912 if Present
(Ref
) then
8913 Add_One_Interp
(Ref
, Subp_Id
, Etype
(Subp_Id
));
8915 -- Otherwise this is the first interpretation. Create a reference
8916 -- where all remaining interpretations will be collected.
8919 Ref
:= New_Occurrence_Of
(Subp_Id
, Sloc
(T
));
8928 -- Start of processing for Find_Indexing_Operations
8933 -- Use the specific type when the parameter type is class-wide
8935 if Is_Class_Wide_Type
(Typ
) then
8936 Typ
:= Root_Type
(Typ
);
8940 Typ
:= Underlying_Type
(Base_Type
(Typ
));
8942 Inspect_Primitives
(Typ
, Ref
);
8944 -- Now look for explicit declarations of an indexing operation.
8945 -- If the type is private the operation may be declared in the
8946 -- visible part that contains the partial view.
8948 if Is_Private_Type
(T
) then
8949 Inspect_Declarations
(T
, Ref
);
8952 Inspect_Declarations
(Typ
, Ref
);
8955 end Find_Indexing_Operations
;
8959 Loc
: constant Source_Ptr
:= Sloc
(N
);
8963 Func_Name
: Node_Id
;
8966 Is_Constant_Indexing
: Boolean := False;
8967 -- This flag reflects the nature of the container indexing. Note that
8968 -- the context may be suited for constant indexing, but the type may
8969 -- lack a Constant_Indexing annotation.
8971 -- Start of processing for Try_Container_Indexing
8974 -- Node may have been analyzed already when testing for a prefixed
8975 -- call, in which case do not redo analysis.
8977 if Present
(Generalized_Indexing
(N
)) then
8981 -- An explicit dereference needs to be created in the case of a prefix
8982 -- that's an access.
8984 -- It seems that this should be done elsewhere, but not clear where that
8985 -- should happen. Normally Insert_Explicit_Dereference is called via
8986 -- Resolve_Implicit_Dereference, called from Resolve_Indexed_Component,
8987 -- but that won't be called in this case because we transform the
8988 -- indexing to a call. Resolve_Call.Check_Prefixed_Call takes care of
8989 -- implicit dereferencing and referencing on prefixed calls, but that
8990 -- would be too late, even if we expanded to a prefix call, because
8991 -- Process_Indexed_Component will flag an error before the resolution
8994 if Is_Access_Type
(Pref_Typ
) then
8995 Pref_Typ
:= Implicitly_Designated_Type
(Pref_Typ
);
8996 Insert_Explicit_Dereference
(Prefix
);
8997 Error_Msg_NW
(Warn_On_Dereference
, "?d?implicit dereference", N
);
9002 -- If indexing a class-wide container, obtain indexing primitive from
9005 if Is_Class_Wide_Type
(C_Type
) then
9006 C_Type
:= Etype
(Base_Type
(C_Type
));
9009 -- Check whether the type has a specified indexing aspect
9013 -- The context is suitable for constant indexing, so obtain the name of
9014 -- the indexing function from aspect Constant_Indexing.
9016 if Constant_Indexing_OK
then
9018 Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Constant_Indexing
);
9021 if Present
(Func_Name
) then
9022 Is_Constant_Indexing
:= True;
9024 -- Otherwise attempt variable indexing
9028 Find_Value_Of_Aspect
(Pref_Typ
, Aspect_Variable_Indexing
);
9031 -- The type is not subject to either form of indexing, therefore the
9032 -- indexed component does not denote container indexing. If this is a
9033 -- true error, it is diagnosed by the caller.
9035 if No
(Func_Name
) then
9037 -- The prefix itself may be an indexing of a container. Rewrite it
9038 -- as such and retry.
9040 if Has_Implicit_Dereference
(Pref_Typ
) then
9041 Build_Explicit_Dereference
9042 (Prefix
, Get_Reference_Discriminant
(Pref_Typ
));
9043 return Try_Container_Indexing
(N
, Prefix
, Exprs
);
9045 -- Otherwise this is definitely not container indexing
9051 -- If the container type is derived from another container type, the
9052 -- value of the inherited aspect is the Reference operation declared
9053 -- for the parent type.
9055 -- However, Reference is also a primitive operation of the type, and the
9056 -- inherited operation has a different signature. We retrieve the right
9057 -- ones (the function may be overloaded) from the list of primitive
9058 -- operations of the derived type.
9060 -- Note that predefined containers are typically all derived from one of
9061 -- the Controlled types. The code below is motivated by containers that
9062 -- are derived from other types with a Reference aspect.
9063 -- Note as well that we need to examine the base type, given that
9064 -- the container object may be a constrained subtype or itype that
9065 -- does not have an explicit declaration.
9067 elsif Is_Derived_Type
(C_Type
)
9068 and then Etype
(First_Formal
(Entity
(Func_Name
))) /= Pref_Typ
9071 Find_Indexing_Operations
9072 (T
=> Base_Type
(C_Type
),
9073 Nam
=> Chars
(Func_Name
),
9074 Is_Constant
=> Is_Constant_Indexing
);
9077 Assoc
:= New_List
(Relocate_Node
(Prefix
));
9079 -- A generalized indexing may have nore than one index expression, so
9080 -- transfer all of them to the argument list to be used in the call.
9081 -- Note that there may be named associations, in which case the node
9082 -- was rewritten earlier as a call, and has been transformed back into
9083 -- an indexed expression to share the following processing.
9085 -- The generalized indexing node is the one on which analysis and
9086 -- resolution take place. Before expansion the original node is replaced
9087 -- with the generalized indexing node, which is a call, possibly with a
9088 -- dereference operation.
9090 -- Create argument list for function call that represents generalized
9091 -- indexing. Note that indices (i.e. actuals) may themselves be
9099 Arg
:= First
(Exprs
);
9100 while Present
(Arg
) loop
9101 New_Arg
:= Relocate_Node
(Arg
);
9103 -- The arguments can be parameter associations, in which case the
9104 -- explicit actual parameter carries the overloadings.
9106 if Nkind
(New_Arg
) /= N_Parameter_Association
then
9107 Save_Interps
(Arg
, New_Arg
);
9110 Append
(New_Arg
, Assoc
);
9115 if not Is_Overloaded
(Func_Name
) then
9116 Func
:= Entity
(Func_Name
);
9118 -- Can happen in case of e.g. cascaded errors
9125 Make_Function_Call
(Loc
,
9126 Name
=> New_Occurrence_Of
(Func
, Loc
),
9127 Parameter_Associations
=> Assoc
);
9129 Set_Parent
(Indexing
, Parent
(N
));
9130 Set_Generalized_Indexing
(N
, Indexing
);
9132 Set_Etype
(N
, Etype
(Indexing
));
9134 -- If the return type of the indexing function is a reference type,
9135 -- add the dereference as a possible interpretation. Note that the
9136 -- indexing aspect may be a function that returns the element type
9137 -- with no intervening implicit dereference, and that the reference
9138 -- discriminant is not the first discriminant.
9140 if Has_Discriminants
(Etype
(Func
)) then
9141 Check_Implicit_Dereference
(N
, Etype
(Func
));
9145 -- If there are multiple indexing functions, build a function call
9146 -- and analyze it for each of the possible interpretations.
9149 Make_Function_Call
(Loc
,
9151 Make_Identifier
(Loc
, Chars
(Func_Name
)),
9152 Parameter_Associations
=> Assoc
);
9153 Set_Parent
(Indexing
, Parent
(N
));
9154 Set_Generalized_Indexing
(N
, Indexing
);
9155 Set_Etype
(N
, Any_Type
);
9156 Set_Etype
(Name
(Indexing
), Any_Type
);
9164 Get_First_Interp
(Func_Name
, I
, It
);
9165 Set_Etype
(Indexing
, Any_Type
);
9167 -- Analyze each candidate function with the given actuals
9169 while Present
(It
.Nam
) loop
9170 Analyze_One_Call
(Indexing
, It
.Nam
, False, Success
);
9171 Get_Next_Interp
(I
, It
);
9174 -- If there are several successful candidates, resolution will
9175 -- be by result. Mark the interpretations of the function name
9178 if Is_Overloaded
(Indexing
) then
9179 Get_First_Interp
(Indexing
, I
, It
);
9181 while Present
(It
.Nam
) loop
9182 Add_One_Interp
(Name
(Indexing
), It
.Nam
, It
.Typ
);
9183 Get_Next_Interp
(I
, It
);
9187 Set_Etype
(Name
(Indexing
), Etype
(Indexing
));
9190 -- Now add the candidate interpretations to the indexing node
9191 -- itself, to be replaced later by the function call.
9193 if Is_Overloaded
(Name
(Indexing
)) then
9194 Get_First_Interp
(Name
(Indexing
), I
, It
);
9196 while Present
(It
.Nam
) loop
9197 Add_One_Interp
(N
, It
.Nam
, It
.Typ
);
9199 -- Add dereference interpretation if the result type has
9200 -- implicit reference discriminants.
9202 if Has_Discriminants
(Etype
(It
.Nam
)) then
9203 Check_Implicit_Dereference
(N
, Etype
(It
.Nam
));
9206 Get_Next_Interp
(I
, It
);
9210 Set_Etype
(N
, Etype
(Name
(Indexing
)));
9211 if Has_Discriminants
(Etype
(N
)) then
9212 Check_Implicit_Dereference
(N
, Etype
(N
));
9218 if Etype
(Indexing
) = Any_Type
then
9220 ("container cannot be indexed with&", N
, Etype
(First
(Exprs
)));
9221 Rewrite
(N
, New_Occurrence_Of
(Any_Id
, Loc
));
9225 end Try_Container_Indexing
;
9227 -----------------------
9228 -- Try_Indirect_Call --
9229 -----------------------
9231 function Try_Indirect_Call
9234 Typ
: Entity_Id
) return Boolean
9240 pragma Warnings
(Off
, Call_OK
);
9243 Normalize_Actuals
(N
, Designated_Type
(Typ
), False, Call_OK
);
9245 Actual
:= First_Actual
(N
);
9246 Formal
:= First_Formal
(Designated_Type
(Typ
));
9247 while Present
(Actual
) and then Present
(Formal
) loop
9248 if not Has_Compatible_Type
(Actual
, Etype
(Formal
)) then
9253 Next_Formal
(Formal
);
9256 if No
(Actual
) and then No
(Formal
) then
9257 Add_One_Interp
(N
, Nam
, Etype
(Designated_Type
(Typ
)));
9259 -- Nam is a candidate interpretation for the name in the call,
9260 -- if it is not an indirect call.
9262 if not Is_Type
(Nam
)
9263 and then Is_Entity_Name
(Name
(N
))
9265 Set_Entity
(Name
(N
), Nam
);
9273 end Try_Indirect_Call
;
9275 ----------------------
9276 -- Try_Indexed_Call --
9277 ----------------------
9279 function Try_Indexed_Call
9283 Skip_First
: Boolean) return Boolean
9285 Loc
: constant Source_Ptr
:= Sloc
(N
);
9286 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
9291 Actual
:= First
(Actuals
);
9293 -- If the call was originally written in prefix form, skip the first
9294 -- actual, which is obviously not defaulted.
9300 Index
:= First_Index
(Typ
);
9301 while Present
(Actual
) and then Present
(Index
) loop
9303 -- If the parameter list has a named association, the expression
9304 -- is definitely a call and not an indexed component.
9306 if Nkind
(Actual
) = N_Parameter_Association
then
9310 if Is_Entity_Name
(Actual
)
9311 and then Is_Type
(Entity
(Actual
))
9312 and then No
(Next
(Actual
))
9314 -- A single actual that is a type name indicates a slice if the
9315 -- type is discrete, and an error otherwise.
9317 if Is_Discrete_Type
(Entity
(Actual
)) then
9321 Make_Function_Call
(Loc
,
9322 Name
=> Relocate_Node
(Name
(N
))),
9324 New_Occurrence_Of
(Entity
(Actual
), Sloc
(Actual
))));
9329 Error_Msg_N
("invalid use of type in expression", Actual
);
9330 Set_Etype
(N
, Any_Type
);
9335 elsif not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
9343 if No
(Actual
) and then No
(Index
) then
9344 Add_One_Interp
(N
, Nam
, Component_Type
(Typ
));
9346 -- Nam is a candidate interpretation for the name in the call,
9347 -- if it is not an indirect call.
9349 if not Is_Type
(Nam
)
9350 and then Is_Entity_Name
(Name
(N
))
9352 Set_Entity
(Name
(N
), Nam
);
9359 end Try_Indexed_Call
;
9361 --------------------------
9362 -- Try_Object_Operation --
9363 --------------------------
9365 function Try_Object_Operation
9367 CW_Test_Only
: Boolean := False;
9368 Allow_Extensions
: Boolean := False) return Boolean
9370 K
: constant Node_Kind
:= Nkind
(Parent
(N
));
9371 Is_Subprg_Call
: constant Boolean := K
in N_Subprogram_Call
;
9372 Loc
: constant Source_Ptr
:= Sloc
(N
);
9373 Obj
: constant Node_Id
:= Prefix
(N
);
9375 Subprog
: constant Node_Id
:=
9376 Make_Identifier
(Sloc
(Selector_Name
(N
)),
9377 Chars
=> Chars
(Selector_Name
(N
)));
9378 -- Identifier on which possible interpretations will be collected
9380 Report_Error
: Boolean := False;
9381 -- If no candidate interpretation matches the context, redo analysis
9382 -- with Report_Error True to provide additional information.
9385 Candidate
: Entity_Id
:= Empty
;
9386 New_Call_Node
: Node_Id
:= Empty
;
9387 Node_To_Replace
: Node_Id
;
9388 Obj_Type
: Entity_Id
:= Etype
(Obj
);
9389 Success
: Boolean := False;
9391 procedure Complete_Object_Operation
9392 (Call_Node
: Node_Id
;
9393 Node_To_Replace
: Node_Id
);
9394 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
9395 -- Call_Node, insert the object (or its dereference) as the first actual
9396 -- in the call, and complete the analysis of the call.
9398 procedure Report_Ambiguity
(Op
: Entity_Id
);
9399 -- If a prefixed procedure call is ambiguous, indicate whether the call
9400 -- includes an implicit dereference or an implicit 'Access.
9402 procedure Transform_Object_Operation
9403 (Call_Node
: out Node_Id
;
9404 Node_To_Replace
: out Node_Id
);
9405 -- Transform Obj.Operation (X, Y, ...) into Operation (Obj, X, Y ...).
9406 -- Call_Node is the resulting subprogram call, Node_To_Replace is
9407 -- either N or the parent of N, and Subprog is a reference to the
9408 -- subprogram we are trying to match. Note that the transformation
9409 -- may be partially destructive for the parent of N, so it needs to
9410 -- be undone in the case where Try_Object_Operation returns false.
9412 function Try_Class_Wide_Operation
9413 (Call_Node
: Node_Id
;
9414 Node_To_Replace
: Node_Id
) return Boolean;
9415 -- Traverse all ancestor types looking for a class-wide subprogram for
9416 -- which the current operation is a valid non-dispatching call.
9418 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
);
9419 -- If prefix is overloaded, its interpretation may include different
9420 -- tagged types, and we must examine the primitive operations and the
9421 -- class-wide operations of each in order to find candidate
9422 -- interpretations for the call as a whole.
9424 function Try_Primitive_Operation
9425 (Call_Node
: Node_Id
;
9426 Node_To_Replace
: Node_Id
) return Boolean;
9427 -- Traverse the list of primitive subprograms looking for a dispatching
9428 -- operation for which the current node is a valid call.
9430 function Valid_Candidate
9433 Subp
: Entity_Id
) return Entity_Id
;
9434 -- If the subprogram is a valid interpretation, record it, and add to
9435 -- the list of interpretations of Subprog. Otherwise return Empty.
9437 -------------------------------
9438 -- Complete_Object_Operation --
9439 -------------------------------
9441 procedure Complete_Object_Operation
9442 (Call_Node
: Node_Id
;
9443 Node_To_Replace
: Node_Id
)
9445 Control
: constant Entity_Id
:= First_Formal
(Entity
(Subprog
));
9446 Formal_Type
: constant Entity_Id
:= Etype
(Control
);
9447 First_Actual
: Node_Id
;
9450 -- Place the name of the operation, with its interpretations,
9451 -- on the rewritten call.
9453 Set_Name
(Call_Node
, Subprog
);
9455 First_Actual
:= First
(Parameter_Associations
(Call_Node
));
9457 -- For cross-reference purposes, treat the new node as being in the
9458 -- source if the original one is. Set entity and type, even though
9459 -- they may be overwritten during resolution if overloaded.
9461 Set_Comes_From_Source
(Subprog
, Comes_From_Source
(N
));
9462 Set_Comes_From_Source
(Call_Node
, Comes_From_Source
(N
));
9464 if Nkind
(N
) = N_Selected_Component
9465 and then not Inside_A_Generic
9467 Set_Entity
(Selector_Name
(N
), Entity
(Subprog
));
9468 Set_Etype
(Selector_Name
(N
), Etype
(Entity
(Subprog
)));
9471 -- If need be, rewrite first actual as an explicit dereference. If
9472 -- the call is overloaded, the rewriting can only be done once the
9473 -- primitive operation is identified.
9475 if Is_Overloaded
(Subprog
) then
9477 -- The prefix itself may be overloaded, and its interpretations
9478 -- must be propagated to the new actual in the call.
9480 if Is_Overloaded
(Obj
) then
9481 Save_Interps
(Obj
, First_Actual
);
9484 Rewrite
(First_Actual
, Obj
);
9486 elsif not Is_Access_Type
(Formal_Type
)
9487 and then Is_Access_Type
(Etype
(Obj
))
9489 Rewrite
(First_Actual
,
9490 Make_Explicit_Dereference
(Sloc
(Obj
), Obj
));
9491 Analyze
(First_Actual
);
9493 -- If we need to introduce an explicit dereference, verify that
9494 -- the resulting actual is compatible with the mode of the formal.
9496 if Ekind
(First_Formal
(Entity
(Subprog
))) /= E_In_Parameter
9497 and then Is_Access_Constant
(Etype
(Obj
))
9500 ("expect variable in call to&", Prefix
(N
), Entity
(Subprog
));
9503 -- Conversely, if the formal is an access parameter and the object is
9504 -- not an access type or a reference type (i.e. a type with the
9505 -- Implicit_Dereference aspect specified), replace the actual with a
9506 -- 'Access reference. Its analysis will check that the object is
9509 elsif Is_Access_Type
(Formal_Type
)
9510 and then not Is_Access_Type
(Etype
(Obj
))
9512 (not Has_Implicit_Dereference
(Etype
(Obj
))
9514 not Is_Access_Type
(Designated_Type
(Etype
9515 (Get_Reference_Discriminant
(Etype
(Obj
))))))
9517 -- A special case: A.all'Access is illegal if A is an access to a
9518 -- constant and the context requires an access to a variable.
9520 if not Is_Access_Constant
(Formal_Type
) then
9521 if (Nkind
(Obj
) = N_Explicit_Dereference
9522 and then Is_Access_Constant
(Etype
(Prefix
(Obj
))))
9523 or else not Is_Variable
(Obj
)
9526 ("actual for & must be a variable", Obj
, Control
);
9530 Rewrite
(First_Actual
,
9531 Make_Attribute_Reference
(Loc
,
9532 Attribute_Name
=> Name_Access
,
9533 Prefix
=> Relocate_Node
(Obj
)));
9535 -- If the object is not overloaded verify that taking access of
9536 -- it is legal. Otherwise check is made during resolution.
9538 if not Is_Overloaded
(Obj
)
9539 and then not Is_Aliased_View
(Obj
)
9542 ("object in prefixed call to & must be aliased "
9543 & "(RM 4.1.3 (13 1/2))", Prefix
(First_Actual
), Subprog
);
9546 Analyze
(First_Actual
);
9549 if Is_Overloaded
(Obj
) then
9550 Save_Interps
(Obj
, First_Actual
);
9553 Rewrite
(First_Actual
, Obj
);
9556 if In_Extended_Main_Source_Unit
(Current_Scope
) then
9557 -- The operation is obtained from the dispatch table and not by
9558 -- visibility, and may be declared in a unit that is not
9559 -- explicitly referenced in the source, but is nevertheless
9560 -- required in the context of the current unit. Indicate that
9561 -- operation and its scope are referenced, to prevent spurious and
9562 -- misleading warnings. If the operation is overloaded, all
9563 -- primitives are in the same scope and we can use any of them.
9564 -- Don't do that outside the main unit since otherwise this will
9565 -- e.g. prevent the detection of some unused with clauses.
9567 Set_Referenced
(Entity
(Subprog
), True);
9568 Set_Referenced
(Scope
(Entity
(Subprog
)), True);
9571 Rewrite
(Node_To_Replace
, Call_Node
);
9573 -- Propagate the interpretations collected in subprog to the new
9574 -- function call node, to be resolved from context.
9576 if Is_Overloaded
(Subprog
) then
9577 Save_Interps
(Subprog
, Node_To_Replace
);
9580 Analyze
(Node_To_Replace
);
9582 -- If the operation has been rewritten into a call, which may get
9583 -- subsequently an explicit dereference, preserve the type on the
9584 -- original node (selected component or indexed component) for
9585 -- subsequent legality tests, e.g. Is_Variable. which examines
9586 -- the original node.
9588 if Nkind
(Node_To_Replace
) = N_Function_Call
then
9590 (Original_Node
(Node_To_Replace
), Etype
(Node_To_Replace
));
9593 end Complete_Object_Operation
;
9595 ----------------------
9596 -- Report_Ambiguity --
9597 ----------------------
9599 procedure Report_Ambiguity
(Op
: Entity_Id
) is
9600 Access_Actual
: constant Boolean :=
9601 Is_Access_Type
(Etype
(Prefix
(N
)));
9602 Access_Formal
: Boolean := False;
9605 Error_Msg_Sloc
:= Sloc
(Op
);
9607 if Present
(First_Formal
(Op
)) then
9608 Access_Formal
:= Is_Access_Type
(Etype
(First_Formal
(Op
)));
9611 if Access_Formal
and then not Access_Actual
then
9612 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
9614 ("\possible interpretation "
9615 & "(inherited, with implicit 'Access) #", N
);
9618 ("\possible interpretation (with implicit 'Access) #", N
);
9621 elsif not Access_Formal
and then Access_Actual
then
9622 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
9624 ("\possible interpretation "
9625 & "(inherited, with implicit dereference) #", N
);
9628 ("\possible interpretation (with implicit dereference) #", N
);
9632 if Nkind
(Parent
(Op
)) = N_Full_Type_Declaration
then
9633 Error_Msg_N
("\possible interpretation (inherited)#", N
);
9635 Error_Msg_N
-- CODEFIX
9636 ("\possible interpretation#", N
);
9639 end Report_Ambiguity
;
9641 --------------------------------
9642 -- Transform_Object_Operation --
9643 --------------------------------
9645 procedure Transform_Object_Operation
9646 (Call_Node
: out Node_Id
;
9647 Node_To_Replace
: out Node_Id
)
9649 Dummy
: constant Node_Id
:= New_Copy
(Obj
);
9650 -- Placeholder used as a first parameter in the call, replaced
9651 -- eventually by the proper object.
9653 Parent_Node
: constant Node_Id
:= Parent
(N
);
9659 -- Common case covering 1) Call to a procedure and 2) Call to a
9660 -- function that has some additional actuals.
9662 if Nkind
(Parent_Node
) in N_Subprogram_Call
9664 -- N is a selected component node containing the name of the
9665 -- subprogram. If N is not the name of the parent node we must
9666 -- not replace the parent node by the new construct. This case
9667 -- occurs when N is a parameterless call to a subprogram that
9668 -- is an actual parameter of a call to another subprogram. For
9670 -- Some_Subprogram (..., Obj.Operation, ...)
9672 and then N
= Name
(Parent_Node
)
9674 Node_To_Replace
:= Parent_Node
;
9676 Actuals
:= Parameter_Associations
(Parent_Node
);
9678 if Present
(Actuals
) then
9679 Prepend
(Dummy
, Actuals
);
9681 Actuals
:= New_List
(Dummy
);
9684 if Nkind
(Parent_Node
) = N_Procedure_Call_Statement
then
9686 Make_Procedure_Call_Statement
(Loc
,
9687 Name
=> New_Copy
(Subprog
),
9688 Parameter_Associations
=> Actuals
);
9692 Make_Function_Call
(Loc
,
9693 Name
=> New_Copy
(Subprog
),
9694 Parameter_Associations
=> Actuals
);
9697 -- Before analysis, a function call appears as an indexed component
9698 -- if there are no named associations.
9700 elsif Nkind
(Parent_Node
) = N_Indexed_Component
9701 and then N
= Prefix
(Parent_Node
)
9703 Node_To_Replace
:= Parent_Node
;
9704 Actuals
:= Expressions
(Parent_Node
);
9706 Actual
:= First
(Actuals
);
9707 while Present
(Actual
) loop
9712 Prepend
(Dummy
, Actuals
);
9715 Make_Function_Call
(Loc
,
9716 Name
=> New_Copy
(Subprog
),
9717 Parameter_Associations
=> Actuals
);
9719 -- Parameterless call: Obj.F is rewritten as F (Obj)
9722 Node_To_Replace
:= N
;
9725 Make_Function_Call
(Loc
,
9726 Name
=> New_Copy
(Subprog
),
9727 Parameter_Associations
=> New_List
(Dummy
));
9729 end Transform_Object_Operation
;
9731 ------------------------------
9732 -- Try_Class_Wide_Operation --
9733 ------------------------------
9735 function Try_Class_Wide_Operation
9736 (Call_Node
: Node_Id
;
9737 Node_To_Replace
: Node_Id
) return Boolean
9739 Anc_Type
: Entity_Id
;
9740 Matching_Op
: Entity_Id
:= Empty
;
9743 procedure Traverse_Homonyms
9744 (Anc_Type
: Entity_Id
;
9745 Error
: out Boolean);
9746 -- Traverse the homonym chain of the subprogram searching for those
9747 -- homonyms whose first formal has the Anc_Type's class-wide type,
9748 -- or an anonymous access type designating the class-wide type. If
9749 -- an ambiguity is detected, then Error is set to True.
9751 procedure Traverse_Interfaces
9752 (Anc_Type
: Entity_Id
;
9753 Error
: out Boolean);
9754 -- Traverse the list of interfaces, if any, associated with Anc_Type
9755 -- and search for acceptable class-wide homonyms associated with each
9756 -- interface. If an ambiguity is detected, then Error is set to True.
9758 -----------------------
9759 -- Traverse_Homonyms --
9760 -----------------------
9762 procedure Traverse_Homonyms
9763 (Anc_Type
: Entity_Id
;
9764 Error
: out Boolean)
9766 function First_Formal_Match
9767 (Subp_Id
: Entity_Id
;
9768 Typ
: Entity_Id
) return Boolean;
9769 -- Predicate to verify that the first foramal of class-wide
9770 -- subprogram Subp_Id matches type Typ of the prefix.
9772 ------------------------
9773 -- First_Formal_Match --
9774 ------------------------
9776 function First_Formal_Match
9777 (Subp_Id
: Entity_Id
;
9778 Typ
: Entity_Id
) return Boolean
9780 Ctrl
: constant Entity_Id
:= First_Formal
(Subp_Id
);
9786 (Base_Type
(Etype
(Ctrl
)) = Typ
9788 (Ekind
(Etype
(Ctrl
)) = E_Anonymous_Access_Type
9790 Base_Type
(Designated_Type
(Etype
(Ctrl
))) =
9792 end First_Formal_Match
;
9796 CW_Typ
: constant Entity_Id
:= Class_Wide_Type
(Anc_Type
);
9798 Candidate
: Entity_Id
;
9799 -- If homonym is a renaming, examine the renamed program
9805 -- Start of processing for Traverse_Homonyms
9810 -- Find a non-hidden operation whose first parameter is of the
9811 -- class-wide type, a subtype thereof, or an anonymous access
9812 -- to same. If in an instance, the operation can be considered
9813 -- even if hidden (it may be hidden because the instantiation
9814 -- is expanded after the containing package has been analyzed).
9815 -- If the subprogram is a generic actual in an enclosing instance,
9816 -- it appears as a renaming that is a candidate interpretation as
9819 Hom
:= Current_Entity
(Subprog
);
9820 while Present
(Hom
) loop
9821 if Ekind
(Hom
) in E_Procedure | E_Function
9822 and then Present
(Renamed_Entity
(Hom
))
9823 and then Is_Generic_Actual_Subprogram
(Hom
)
9824 and then In_Open_Scopes
(Scope
(Hom
))
9826 Candidate
:= Renamed_Entity
(Hom
);
9831 if Ekind
(Candidate
) in E_Function | E_Procedure
9832 and then (not Is_Hidden
(Candidate
) or else In_Instance
)
9833 and then Scope
(Candidate
) = Scope
(Base_Type
(Anc_Type
))
9834 and then First_Formal_Match
(Candidate
, CW_Typ
)
9836 -- If the context is a procedure call, ignore functions
9837 -- in the name of the call.
9839 if Ekind
(Candidate
) = E_Function
9840 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
9841 and then N
= Name
(Parent
(N
))
9845 -- If the context is a function call, ignore procedures
9846 -- in the name of the call.
9848 elsif Ekind
(Candidate
) = E_Procedure
9849 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
9854 Set_Etype
(Call_Node
, Any_Type
);
9855 Set_Is_Overloaded
(Call_Node
, False);
9858 if No
(Matching_Op
) then
9859 Hom_Ref
:= New_Occurrence_Of
(Candidate
, Sloc
(Subprog
));
9861 Set_Etype
(Call_Node
, Any_Type
);
9862 Set_Name
(Call_Node
, Hom_Ref
);
9863 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
9868 Report
=> Report_Error
,
9870 Skip_First
=> True);
9873 Valid_Candidate
(Success
, Call_Node
, Candidate
);
9879 Report
=> Report_Error
,
9881 Skip_First
=> True);
9883 -- The same operation may be encountered on two homonym
9884 -- traversals, before and after looking at interfaces.
9885 -- Check for this case before reporting a real ambiguity.
9888 (Valid_Candidate
(Success
, Call_Node
, Candidate
))
9889 and then Nkind
(Call_Node
) /= N_Function_Call
9890 and then Candidate
/= Matching_Op
9892 Error_Msg_NE
("ambiguous call to&", N
, Hom
);
9893 Report_Ambiguity
(Matching_Op
);
9894 Report_Ambiguity
(Hom
);
9895 Check_Ambiguous_Aggregate
(New_Call_Node
);
9903 Hom
:= Homonym
(Hom
);
9905 end Traverse_Homonyms
;
9907 -------------------------
9908 -- Traverse_Interfaces --
9909 -------------------------
9911 procedure Traverse_Interfaces
9912 (Anc_Type
: Entity_Id
;
9913 Error
: out Boolean)
9915 Intface_List
: constant List_Id
:=
9916 Abstract_Interface_List
(Anc_Type
);
9922 -- When climbing through the parents of an interface type,
9923 -- look for acceptable class-wide homonyms associated with
9924 -- the interface type.
9926 if Is_Interface
(Anc_Type
) then
9927 Traverse_Homonyms
(Anc_Type
, Error
);
9934 Intface
:= First
(Intface_List
);
9935 while Present
(Intface
) loop
9937 -- Look for acceptable class-wide homonyms associated with the
9940 Traverse_Homonyms
(Etype
(Intface
), Error
);
9946 -- Continue the search by looking at each of the interface's
9947 -- associated interface ancestors.
9949 Traverse_Interfaces
(Etype
(Intface
), Error
);
9958 -- For derived interface types continue the search climbing to
9961 if Is_Interface
(Anc_Type
)
9962 and then Etype
(Anc_Type
) /= Anc_Type
9964 Traverse_Interfaces
(Etype
(Anc_Type
), Error
);
9966 end Traverse_Interfaces
;
9968 -- Start of processing for Try_Class_Wide_Operation
9971 -- If we are searching only for conflicting class-wide subprograms
9972 -- then initialize directly Matching_Op with the target entity.
9974 if CW_Test_Only
then
9975 Matching_Op
:= Entity
(Selector_Name
(N
));
9978 -- Loop through ancestor types (including interfaces), traversing
9979 -- the homonym chain of the subprogram, trying out those homonyms
9980 -- whose first formal has the class-wide type of the ancestor, or
9981 -- an anonymous access type designating the class-wide type.
9983 Anc_Type
:= Obj_Type
;
9985 -- Look for a match among homonyms associated with the ancestor
9987 Traverse_Homonyms
(Anc_Type
, Error
);
9993 -- Continue the search for matches among homonyms associated with
9994 -- any interfaces implemented by the ancestor.
9996 Traverse_Interfaces
(Anc_Type
, Error
);
10002 exit when Etype
(Anc_Type
) = Anc_Type
;
10003 Anc_Type
:= Etype
(Anc_Type
);
10006 if Present
(Matching_Op
) then
10007 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
10010 return Present
(Matching_Op
);
10011 end Try_Class_Wide_Operation
;
10013 -----------------------------------
10014 -- Try_One_Prefix_Interpretation --
10015 -----------------------------------
10017 procedure Try_One_Prefix_Interpretation
(T
: Entity_Id
) is
10018 Prev_Obj_Type
: constant Entity_Id
:= Obj_Type
;
10019 -- If the interpretation does not have a valid candidate type,
10020 -- preserve current value of Obj_Type for subsequent errors.
10025 if Is_Access_Type
(Obj_Type
) then
10026 Obj_Type
:= Designated_Type
(Obj_Type
);
10029 if Ekind
(Obj_Type
)
10030 in E_Private_Subtype | E_Record_Subtype_With_Private
10032 Obj_Type
:= Base_Type
(Obj_Type
);
10035 if Is_Class_Wide_Type
(Obj_Type
) then
10036 Obj_Type
:= Etype
(Class_Wide_Type
(Obj_Type
));
10039 -- The type may have be obtained through a limited_with clause,
10040 -- in which case the primitive operations are available on its
10041 -- nonlimited view. If still incomplete, retrieve full view.
10043 if Ekind
(Obj_Type
) = E_Incomplete_Type
10044 and then From_Limited_With
(Obj_Type
)
10045 and then Has_Non_Limited_View
(Obj_Type
)
10047 Obj_Type
:= Get_Full_View
(Non_Limited_View
(Obj_Type
));
10050 -- If the object is not tagged, or the type is still an incomplete
10051 -- type, this is not a prefixed call. Restore the previous type as
10052 -- the current one is not a legal candidate.
10054 -- Extension feature: Calls with prefixed views are also supported
10055 -- for untagged types, so skip the early return when extensions are
10056 -- enabled, unless the type doesn't have a primitive operations list
10057 -- (such as in the case of predefined types).
10059 if (not Is_Tagged_Type
(Obj_Type
)
10061 (not (Core_Extensions_Allowed
or Allow_Extensions
)
10062 or else No
(Primitive_Operations
(Obj_Type
))))
10063 or else Is_Incomplete_Type
(Obj_Type
)
10065 Obj_Type
:= Prev_Obj_Type
;
10070 Dup_Call_Node
: constant Node_Id
:= New_Copy
(New_Call_Node
);
10072 Prim_Result
: Boolean := False;
10075 if not CW_Test_Only
then
10077 Try_Primitive_Operation
10078 (Call_Node
=> New_Call_Node
,
10079 Node_To_Replace
=> Node_To_Replace
);
10081 -- Extension feature: In the case where the prefix is of an
10082 -- access type, and a primitive wasn't found for the designated
10083 -- type, then if the access type has primitives we attempt a
10084 -- prefixed call using one of its primitives. (It seems that
10085 -- this isn't quite right to give preference to the designated
10086 -- type in the case where both the access and designated types
10087 -- have homographic prefixed-view operations that could result
10088 -- in an ambiguity, but handling properly may be tricky. ???)
10090 if (Core_Extensions_Allowed
or Allow_Extensions
)
10091 and then not Prim_Result
10092 and then Is_Named_Access_Type
(Prev_Obj_Type
)
10093 and then Present
(Direct_Primitive_Operations
(Prev_Obj_Type
))
10095 -- Temporarily reset Obj_Type to the original access type
10097 Obj_Type
:= Prev_Obj_Type
;
10100 Try_Primitive_Operation
10101 (Call_Node
=> New_Call_Node
,
10102 Node_To_Replace
=> Node_To_Replace
);
10104 -- Restore Obj_Type to the designated type (is this really
10105 -- necessary, or should it only be done when Prim_Result is
10108 Obj_Type
:= Designated_Type
(Obj_Type
);
10112 -- Check if there is a class-wide subprogram covering the
10113 -- primitive. This check must be done even if a candidate
10114 -- was found in order to report ambiguous calls.
10116 if not Prim_Result
then
10118 Try_Class_Wide_Operation
10119 (Call_Node
=> New_Call_Node
,
10120 Node_To_Replace
=> Node_To_Replace
);
10122 -- If we found a primitive we search for class-wide subprograms
10123 -- using a duplicate of the call node (done to avoid missing its
10124 -- decoration if there is no ambiguity).
10128 Try_Class_Wide_Operation
10129 (Call_Node
=> Dup_Call_Node
,
10130 Node_To_Replace
=> Node_To_Replace
);
10133 end Try_One_Prefix_Interpretation
;
10135 -----------------------------
10136 -- Try_Primitive_Operation --
10137 -----------------------------
10139 function Try_Primitive_Operation
10140 (Call_Node
: Node_Id
;
10141 Node_To_Replace
: Node_Id
) return Boolean
10144 Prim_Op
: Entity_Id
;
10145 Matching_Op
: Entity_Id
:= Empty
;
10146 Prim_Op_Ref
: Node_Id
:= Empty
;
10148 Corr_Type
: Entity_Id
:= Empty
;
10149 -- If the prefix is a synchronized type, the controlling type of
10150 -- the primitive operation is the corresponding record type, else
10151 -- this is the object type itself.
10153 Success
: Boolean := False;
10155 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
;
10156 -- For tagged types the candidate interpretations are found in
10157 -- the list of primitive operations of the type and its ancestors.
10158 -- For formal tagged types we have to find the operations declared
10159 -- in the same scope as the type (including in the generic formal
10160 -- part) because the type itself carries no primitive operations,
10161 -- except for formal derived types that inherit the operations of
10162 -- the parent and progenitors.
10164 -- If the context is a generic subprogram body, the generic formals
10165 -- are visible by name, but are not in the entity list of the
10166 -- subprogram because that list starts with the subprogram formals.
10167 -- We retrieve the candidate operations from the generic declaration.
10169 function Extended_Primitive_Ops
(T
: Entity_Id
) return Elist_Id
;
10170 -- Prefix notation can also be used on operations that are not
10171 -- primitives of the type, but are declared in the same immediate
10172 -- declarative part, which can only mean the corresponding package
10173 -- body (see RM 4.1.3 (9.2/3)). If we are in that body we extend the
10174 -- list of primitives with body operations with the same name that
10175 -- may be candidates, so that Try_Primitive_Operations can examine
10176 -- them if no real primitive is found.
10178 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean;
10179 -- An operation that overrides an inherited operation in the private
10180 -- part of its package may be hidden, but if the inherited operation
10181 -- is visible a direct call to it will dispatch to the private one,
10182 -- which is therefore a valid candidate.
10184 function Names_Match
10185 (Obj_Type
: Entity_Id
;
10186 Prim_Op
: Entity_Id
;
10187 Subprog
: Entity_Id
) return Boolean;
10188 -- Return True if the names of Prim_Op and Subprog match. If Obj_Type
10189 -- is a protected type then compare also the original name of Prim_Op
10190 -- with the name of Subprog (since the expander may have added a
10191 -- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
10193 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean;
10194 -- Verify that the prefix, dereferenced if need be, is a valid
10195 -- controlling argument in a call to Op. The remaining actuals
10196 -- are checked in the subsequent call to Analyze_One_Call.
10198 ------------------------------
10199 -- Collect_Generic_Type_Ops --
10200 ------------------------------
10202 function Collect_Generic_Type_Ops
(T
: Entity_Id
) return Elist_Id
is
10203 Bas
: constant Entity_Id
:= Base_Type
(T
);
10204 Candidates
: constant Elist_Id
:= New_Elmt_List
;
10206 Formal
: Entity_Id
;
10208 procedure Check_Candidate
;
10209 -- The operation is a candidate if its first parameter is a
10210 -- controlling operand of the desired type.
10212 -----------------------
10213 -- Check_Candidate; --
10214 -----------------------
10216 procedure Check_Candidate
is
10218 Formal
:= First_Formal
(Subp
);
10220 if Present
(Formal
)
10221 and then Is_Controlling_Formal
(Formal
)
10223 (Base_Type
(Etype
(Formal
)) = Bas
10225 (Is_Access_Type
(Etype
(Formal
))
10226 and then Designated_Type
(Etype
(Formal
)) = Bas
))
10228 Append_Elmt
(Subp
, Candidates
);
10230 end Check_Candidate
;
10232 -- Start of processing for Collect_Generic_Type_Ops
10235 if Is_Derived_Type
(T
) then
10236 return Primitive_Operations
(T
);
10238 elsif Ekind
(Scope
(T
)) in E_Procedure | E_Function
then
10240 -- Scan the list of generic formals to find subprograms
10241 -- that may have a first controlling formal of the type.
10243 if Nkind
(Unit_Declaration_Node
(Scope
(T
))) =
10244 N_Generic_Subprogram_Declaration
10251 First
(Generic_Formal_Declarations
10252 (Unit_Declaration_Node
(Scope
(T
))));
10253 while Present
(Decl
) loop
10254 if Nkind
(Decl
) in N_Formal_Subprogram_Declaration
then
10255 Subp
:= Defining_Entity
(Decl
);
10266 -- Scan the list of entities declared in the same scope as
10267 -- the type. In general this will be an open scope, given that
10268 -- the call we are analyzing can only appear within a generic
10269 -- declaration or body (either the one that declares T, or a
10272 -- For a subtype representing a generic actual type, go to the
10275 if Is_Generic_Actual_Type
(T
) then
10276 Subp
:= First_Entity
(Scope
(Base_Type
(T
)));
10278 Subp
:= First_Entity
(Scope
(T
));
10281 while Present
(Subp
) loop
10282 if Is_Overloadable
(Subp
) then
10286 Next_Entity
(Subp
);
10291 end Collect_Generic_Type_Ops
;
10293 ----------------------------
10294 -- Extended_Primitive_Ops --
10295 ----------------------------
10297 function Extended_Primitive_Ops
(T
: Entity_Id
) return Elist_Id
is
10298 Type_Scope
: constant Entity_Id
:= Scope
(T
);
10299 Op_List
: Elist_Id
:= Primitive_Operations
(T
);
10301 if Is_Package_Or_Generic_Package
(Type_Scope
)
10302 and then ((In_Package_Body
(Type_Scope
)
10303 and then In_Open_Scopes
(Type_Scope
)) or else In_Instance_Body
)
10305 -- Retrieve list of declarations of package body if possible
10308 The_Body
: constant Node_Id
:=
10309 Corresponding_Body
(Unit_Declaration_Node
(Type_Scope
));
10311 if Present
(The_Body
) then
10313 Body_Decls
: constant List_Id
:=
10314 Declarations
(Unit_Declaration_Node
(The_Body
));
10315 Op_Found
: Boolean := False;
10316 Op
: Entity_Id
:= Current_Entity
(Subprog
);
10318 while Present
(Op
) loop
10319 if Comes_From_Source
(Op
)
10320 and then Is_Overloadable
(Op
)
10322 -- Exclude overriding primitive operations of a
10323 -- type extension declared in the package body,
10324 -- to prevent duplicates in extended list.
10326 and then not Is_Primitive
(Op
)
10327 and then Is_List_Member
10328 (Unit_Declaration_Node
(Op
))
10329 and then List_Containing
10330 (Unit_Declaration_Node
(Op
)) = Body_Decls
10332 if not Op_Found
then
10333 -- Copy list of primitives so it is not
10334 -- affected for other uses.
10336 Op_List
:= New_Copy_Elist
(Op_List
);
10340 Append_Elmt
(Op
, Op_List
);
10343 Op
:= Homonym
(Op
);
10351 end Extended_Primitive_Ops
;
10353 ---------------------------
10354 -- Is_Private_Overriding --
10355 ---------------------------
10357 function Is_Private_Overriding
(Op
: Entity_Id
) return Boolean is
10358 Visible_Op
: Entity_Id
;
10361 -- The subprogram may be overloaded with both visible and private
10362 -- entities with the same name. We have to scan the chain of
10363 -- homonyms to determine whether there is a previous implicit
10364 -- declaration in the same scope that is overridden by the
10365 -- private candidate.
10367 Visible_Op
:= Homonym
(Op
);
10368 while Present
(Visible_Op
) loop
10369 if Scope
(Op
) /= Scope
(Visible_Op
) then
10372 elsif not Comes_From_Source
(Visible_Op
)
10373 and then Alias
(Visible_Op
) = Op
10375 -- If Visible_Op or what it overrides is not hidden, then we
10376 -- have found what we're looking for.
10378 if not Is_Hidden
(Visible_Op
)
10379 or else not Is_Hidden
(Overridden_Operation
(Op
))
10385 Visible_Op
:= Homonym
(Visible_Op
);
10389 end Is_Private_Overriding
;
10395 function Names_Match
10396 (Obj_Type
: Entity_Id
;
10397 Prim_Op
: Entity_Id
;
10398 Subprog
: Entity_Id
) return Boolean is
10400 -- Common case: exact match
10402 if Chars
(Prim_Op
) = Chars
(Subprog
) then
10405 -- For protected type primitives the expander may have built the
10406 -- name of the dispatching primitive prepending the type name to
10407 -- avoid conflicts with the name of the protected subprogram (see
10408 -- Exp_Ch9.Build_Selected_Name).
10410 elsif Is_Protected_Type
(Obj_Type
) then
10412 Present
(Original_Protected_Subprogram
(Prim_Op
))
10413 and then Chars
(Original_Protected_Subprogram
(Prim_Op
)) =
10416 -- In an instance, the selector name may be a generic actual that
10417 -- renames a primitive operation of the type of the prefix.
10419 elsif In_Instance
and then Present
(Current_Entity
(Subprog
)) then
10421 Subp
: constant Entity_Id
:= Current_Entity
(Subprog
);
10424 and then Is_Subprogram
(Subp
)
10425 and then Present
(Renamed_Entity
(Subp
))
10426 and then Is_Generic_Actual_Subprogram
(Subp
)
10427 and then Chars
(Renamed_Entity
(Subp
)) = Chars
(Prim_Op
)
10437 -----------------------------
10438 -- Valid_First_Argument_Of --
10439 -----------------------------
10441 function Valid_First_Argument_Of
(Op
: Entity_Id
) return Boolean is
10442 Typ
: Entity_Id
:= Etype
(First_Formal
(Op
));
10445 if Is_Concurrent_Type
(Typ
)
10446 and then Present
(Corresponding_Record_Type
(Typ
))
10448 Typ
:= Corresponding_Record_Type
(Typ
);
10451 -- Simple case. Object may be a subtype of the tagged type or may
10452 -- be the corresponding record of a synchronized type.
10454 return Obj_Type
= Typ
10455 or else Base_Type
(Obj_Type
) = Base_Type
(Typ
)
10456 or else Corr_Type
= Typ
10458 -- Object may be of a derived type whose parent has unknown
10459 -- discriminants, in which case the type matches the underlying
10460 -- record view of its base.
10463 (Has_Unknown_Discriminants
(Typ
)
10464 and then Typ
= Underlying_Record_View
(Base_Type
(Obj_Type
)))
10466 -- Prefix can be dereferenced
10469 (Is_Access_Type
(Corr_Type
)
10470 and then Designated_Type
(Corr_Type
) = Typ
)
10472 -- Formal is an access parameter, for which the object can
10473 -- provide an access.
10476 (Ekind
(Typ
) = E_Anonymous_Access_Type
10478 Base_Type
(Designated_Type
(Typ
)) = Base_Type
(Corr_Type
));
10479 end Valid_First_Argument_Of
;
10481 -- Start of processing for Try_Primitive_Operation
10484 -- Look for subprograms in the list of primitive operations. The name
10485 -- must be identical, and the kind of call indicates the expected
10486 -- kind of operation (function or procedure). If the type is a
10487 -- (tagged) synchronized type, the primitive ops are attached to the
10488 -- corresponding record (base) type.
10490 if Is_Concurrent_Type
(Obj_Type
) then
10491 if Present
(Corresponding_Record_Type
(Obj_Type
)) then
10492 Corr_Type
:= Base_Type
(Corresponding_Record_Type
(Obj_Type
));
10493 Elmt
:= First_Elmt
(Primitive_Operations
(Corr_Type
));
10495 Corr_Type
:= Obj_Type
;
10496 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
10499 elsif not Is_Generic_Type
(Obj_Type
) then
10500 Corr_Type
:= Obj_Type
;
10501 Elmt
:= First_Elmt
(Extended_Primitive_Ops
(Obj_Type
));
10504 Corr_Type
:= Obj_Type
;
10505 Elmt
:= First_Elmt
(Collect_Generic_Type_Ops
(Obj_Type
));
10508 while Present
(Elmt
) loop
10509 Prim_Op
:= Node
(Elmt
);
10511 if Names_Match
(Obj_Type
, Prim_Op
, Subprog
)
10512 and then Present
(First_Formal
(Prim_Op
))
10513 and then Valid_First_Argument_Of
(Prim_Op
)
10515 (Nkind
(Call_Node
) = N_Function_Call
)
10517 (Ekind
(Prim_Op
) = E_Function
)
10519 -- Ada 2005 (AI-251): If this primitive operation corresponds
10520 -- to an immediate ancestor interface there is no need to add
10521 -- it to the list of interpretations; the corresponding aliased
10522 -- primitive is also in this list of primitive operations and
10523 -- will be used instead.
10525 if (Present
(Interface_Alias
(Prim_Op
))
10526 and then Is_Ancestor
(Find_Dispatching_Type
10527 (Alias
(Prim_Op
)), Corr_Type
))
10529 -- Do not consider hidden primitives unless the type is in an
10530 -- open scope or we are within an instance, where visibility
10531 -- is known to be correct, or else if this is an overriding
10532 -- operation in the private part for an inherited operation.
10534 or else (Is_Hidden
(Prim_Op
)
10535 and then not Is_Immediately_Visible
(Obj_Type
)
10536 and then not In_Instance
10537 and then not Is_Private_Overriding
(Prim_Op
))
10542 Set_Etype
(Call_Node
, Any_Type
);
10543 Set_Is_Overloaded
(Call_Node
, False);
10545 if No
(Matching_Op
) then
10546 Prim_Op_Ref
:= New_Occurrence_Of
(Prim_Op
, Sloc
(Subprog
));
10547 Candidate
:= Prim_Op
;
10549 Set_Parent
(Call_Node
, Parent
(Node_To_Replace
));
10551 Set_Name
(Call_Node
, Prim_Op_Ref
);
10557 Report
=> Report_Error
,
10558 Success
=> Success
,
10559 Skip_First
=> True);
10561 Matching_Op
:= Valid_Candidate
(Success
, Call_Node
, Prim_Op
);
10563 -- More than one interpretation, collect for subsequent
10564 -- disambiguation. If this is a procedure call and there
10565 -- is another match, report ambiguity now.
10571 Report
=> Report_Error
,
10572 Success
=> Success
,
10573 Skip_First
=> True);
10575 if Present
(Valid_Candidate
(Success
, Call_Node
, Prim_Op
))
10576 and then Nkind
(Call_Node
) /= N_Function_Call
10578 Error_Msg_NE
("ambiguous call to&", N
, Prim_Op
);
10579 Report_Ambiguity
(Matching_Op
);
10580 Report_Ambiguity
(Prim_Op
);
10581 Check_Ambiguous_Aggregate
(Call_Node
);
10591 if Present
(Matching_Op
) then
10592 Set_Etype
(Call_Node
, Etype
(Matching_Op
));
10595 return Present
(Matching_Op
);
10596 end Try_Primitive_Operation
;
10598 ---------------------
10599 -- Valid_Candidate --
10600 ---------------------
10602 function Valid_Candidate
10603 (Success
: Boolean;
10605 Subp
: Entity_Id
) return Entity_Id
10607 Arr_Type
: Entity_Id
;
10608 Comp_Type
: Entity_Id
;
10611 -- If the subprogram is a valid interpretation, record it in global
10612 -- variable Subprog, to collect all possible overloadings.
10615 if Subp
/= Entity
(Subprog
) then
10616 Add_One_Interp
(Subprog
, Subp
, Etype
(Subp
));
10620 -- If the call may be an indexed call, retrieve component type of
10621 -- resulting expression, and add possible interpretation.
10624 Comp_Type
:= Empty
;
10626 if Nkind
(Call
) = N_Function_Call
10627 and then Nkind
(Parent
(N
)) = N_Indexed_Component
10628 and then Needs_One_Actual
(Subp
)
10630 if Is_Array_Type
(Etype
(Subp
)) then
10631 Arr_Type
:= Etype
(Subp
);
10633 elsif Is_Access_Type
(Etype
(Subp
))
10634 and then Is_Array_Type
(Designated_Type
(Etype
(Subp
)))
10636 Arr_Type
:= Designated_Type
(Etype
(Subp
));
10640 if Present
(Arr_Type
) then
10642 -- Verify that the actuals (excluding the object) match the types
10650 Actual
:= Next
(First_Actual
(Call
));
10651 Index
:= First_Index
(Arr_Type
);
10652 while Present
(Actual
) and then Present
(Index
) loop
10653 if not Has_Compatible_Type
(Actual
, Etype
(Index
)) then
10658 Next_Actual
(Actual
);
10659 Next_Index
(Index
);
10663 and then No
(Index
)
10664 and then Present
(Arr_Type
)
10666 Comp_Type
:= Component_Type
(Arr_Type
);
10670 if Present
(Comp_Type
)
10671 and then Etype
(Subprog
) /= Comp_Type
10673 Add_One_Interp
(Subprog
, Subp
, Comp_Type
);
10677 if Etype
(Call
) /= Any_Type
then
10682 end Valid_Candidate
;
10684 -- Start of processing for Try_Object_Operation
10687 Analyze_Expression
(Obj
);
10689 -- Analyze the actuals if node is known to be a subprogram call
10691 if Is_Subprg_Call
and then N
= Name
(Parent
(N
)) then
10692 Actual
:= First
(Parameter_Associations
(Parent
(N
)));
10693 while Present
(Actual
) loop
10694 Analyze_Expression
(Actual
);
10699 -- Build a subprogram call node, using a copy of Obj as its first
10700 -- actual. This is a placeholder, to be replaced by an explicit
10701 -- dereference when needed.
10703 Transform_Object_Operation
10704 (Call_Node
=> New_Call_Node
,
10705 Node_To_Replace
=> Node_To_Replace
);
10707 Set_Etype
(New_Call_Node
, Any_Type
);
10708 Set_Etype
(Subprog
, Any_Type
);
10709 Set_Parent
(New_Call_Node
, Parent
(Node_To_Replace
));
10711 if not Is_Overloaded
(Obj
) then
10712 Try_One_Prefix_Interpretation
(Obj_Type
);
10719 Get_First_Interp
(Obj
, I
, It
);
10720 while Present
(It
.Nam
) loop
10721 Try_One_Prefix_Interpretation
(It
.Typ
);
10722 Get_Next_Interp
(I
, It
);
10727 if Etype
(New_Call_Node
) /= Any_Type
then
10729 -- No need to complete the tree transformations if we are only
10730 -- searching for conflicting class-wide subprograms
10732 if CW_Test_Only
then
10735 Complete_Object_Operation
10736 (Call_Node
=> New_Call_Node
,
10737 Node_To_Replace
=> Node_To_Replace
);
10741 elsif Present
(Candidate
) then
10743 -- The argument list is not type correct. Re-analyze with error
10744 -- reporting enabled, and use one of the possible candidates.
10745 -- In All_Errors_Mode, re-analyze all failed interpretations.
10747 if All_Errors_Mode
then
10748 Report_Error
:= True;
10749 if Try_Primitive_Operation
10750 (Call_Node
=> New_Call_Node
,
10751 Node_To_Replace
=> Node_To_Replace
)
10754 Try_Class_Wide_Operation
10755 (Call_Node
=> New_Call_Node
,
10756 Node_To_Replace
=> Node_To_Replace
)
10763 (N
=> New_Call_Node
,
10766 Success
=> Success
,
10767 Skip_First
=> True);
10769 -- The error may hot have been reported yet for overloaded
10770 -- prefixed calls, depending on the non-matching candidate,
10771 -- in which case provide a concise error now.
10773 if Serious_Errors_Detected
= 0 then
10775 ("cannot resolve prefixed call to primitive operation of&",
10780 -- No need for further errors
10785 -- There was no candidate operation, but Analyze_Selected_Component
10786 -- may continue the analysis so we need to undo the change possibly
10787 -- made to the Parent of N earlier by Transform_Object_Operation.
10790 Parent_Node
: constant Node_Id
:= Parent
(N
);
10793 if Node_To_Replace
= Parent_Node
then
10794 Remove
(First
(Parameter_Associations
(New_Call_Node
)));
10796 (Parameter_Associations
(New_Call_Node
), Parent_Node
);
10802 end Try_Object_Operation
;
10804 -------------------------
10805 -- Unresolved_Operator --
10806 -------------------------
10808 procedure Unresolved_Operator
(N
: Node_Id
) is
10809 L
: constant Node_Id
:=
10810 (if Nkind
(N
) in N_Binary_Op
then Left_Opnd
(N
) else Empty
);
10811 R
: constant Node_Id
:= Right_Opnd
(N
);
10816 -- Note that in the following messages, if the operand is overloaded we
10817 -- choose an arbitrary type to complain about, but that is probably more
10818 -- useful than not giving a type at all.
10820 if Nkind
(N
) in N_Unary_Op
then
10821 Error_Msg_Node_2
:= Etype
(R
);
10822 Error_Msg_N
("operator& not defined for}", N
);
10824 elsif Nkind
(N
) in N_Binary_Op
then
10825 if not Is_Overloaded
(L
)
10826 and then not Is_Overloaded
(R
)
10827 and then Base_Type
(Etype
(L
)) = Base_Type
(Etype
(R
))
10829 Error_Msg_Node_2
:= First_Subtype
(Etype
(R
));
10830 Error_Msg_N
("there is no applicable operator& for}", N
);
10833 -- Another attempt to find a fix: one of the candidate
10834 -- interpretations may not be use-visible. This has
10835 -- already been checked for predefined operators, so
10836 -- we examine only user-defined functions.
10838 Op_Id
:= Get_Name_Entity_Id
(Chars
(N
));
10840 while Present
(Op_Id
) loop
10841 if Ekind
(Op_Id
) /= E_Operator
10842 and then Is_Overloadable
(Op_Id
)
10843 and then not Is_Immediately_Visible
(Op_Id
)
10844 and then not In_Use
(Scope
(Op_Id
))
10845 and then not Is_Abstract_Subprogram
(Op_Id
)
10846 and then not Is_Hidden
(Op_Id
)
10847 and then Ekind
(Scope
(Op_Id
)) = E_Package
10848 and then Has_Compatible_Type
(L
, Etype
(First_Formal
(Op_Id
)))
10849 and then Present
(Next_Formal
(First_Formal
(Op_Id
)))
10851 Has_Compatible_Type
10852 (R
, Etype
(Next_Formal
(First_Formal
(Op_Id
))))
10854 Error_Msg_N
("no legal interpretation for operator&", N
);
10855 Error_Msg_NE
("\use clause on& would make operation legal",
10860 Op_Id
:= Homonym
(Op_Id
);
10864 Error_Msg_N
("invalid operand types for operator&", N
);
10866 if Nkind
(N
) /= N_Op_Concat
then
10867 Error_Msg_NE
("\left operand has}!", N
, Etype
(L
));
10868 Error_Msg_NE
("\right operand has}!", N
, Etype
(R
));
10870 -- For multiplication and division operators with
10871 -- a fixed-point operand and an integer operand,
10872 -- indicate that the integer operand should be of
10875 if Nkind
(N
) in N_Op_Multiply | N_Op_Divide
10876 and then Is_Fixed_Point_Type
(Etype
(L
))
10877 and then Is_Integer_Type
(Etype
(R
))
10879 Error_Msg_N
("\convert right operand to `Integer`", N
);
10881 elsif Nkind
(N
) = N_Op_Multiply
10882 and then Is_Fixed_Point_Type
(Etype
(R
))
10883 and then Is_Integer_Type
(Etype
(L
))
10885 Error_Msg_N
("\convert left operand to `Integer`", N
);
10888 -- For concatenation operators it is more difficult to
10889 -- determine which is the wrong operand. It is worth
10890 -- flagging explicitly an access type, for those who
10891 -- might think that a dereference happens here.
10893 elsif Is_Access_Type
(Etype
(L
)) then
10894 Error_Msg_N
("\left operand is access type", N
);
10896 elsif Is_Access_Type
(Etype
(R
)) then
10897 Error_Msg_N
("\right operand is access type", N
);
10902 end Unresolved_Operator
;
10908 procedure wpo
(T
: Entity_Id
) is
10913 if not Is_Tagged_Type
(T
) then
10917 E
:= First_Elmt
(Primitive_Operations
(Base_Type
(T
)));
10918 while Present
(E
) loop
10920 Write_Int
(Int
(Op
));
10921 Write_Str
(" === ");
10922 Write_Name
(Chars
(Op
));
10923 Write_Str
(" in ");
10924 Write_Name
(Chars
(Scope
(Op
)));