1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Elists
; use Elists
;
29 with Einfo
; use Einfo
;
30 with Exp_Disp
; use Exp_Disp
;
31 with Exp_Util
; use Exp_Util
;
32 with Exp_Ch7
; use Exp_Ch7
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Errout
; use Errout
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Namet
; use Namet
;
37 with Nlists
; use Nlists
;
38 with Nmake
; use Nmake
;
40 with Output
; use Output
;
41 with Restrict
; use Restrict
;
42 with Rident
; use Rident
;
44 with Sem_Aux
; use Sem_Aux
;
45 with Sem_Ch3
; use Sem_Ch3
;
46 with Sem_Ch6
; use Sem_Ch6
;
47 with Sem_Eval
; use Sem_Eval
;
48 with Sem_Type
; use Sem_Type
;
49 with Sem_Util
; use Sem_Util
;
50 with Snames
; use Snames
;
51 with Sinfo
; use Sinfo
;
52 with Targparm
; use Targparm
;
53 with Tbuild
; use Tbuild
;
54 with Uintp
; use Uintp
;
56 package body Sem_Disp
is
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Add_Dispatching_Operation
63 (Tagged_Type
: Entity_Id
;
65 -- Add New_Op in the list of primitive operations of Tagged_Type
67 function Check_Controlling_Type
69 Subp
: Entity_Id
) return Entity_Id
;
70 -- T is the tagged type of a formal parameter or the result of Subp.
71 -- If the subprogram has a controlling parameter or result that matches
72 -- the type, then returns the tagged type of that parameter or result
73 -- (returning the designated tagged type in the case of an access
74 -- parameter); otherwise returns empty.
76 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
;
77 -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
78 -- type of S that has the same name of S, a type-conformant profile, an
79 -- original corresponding operation O that is a primitive of a visible
80 -- ancestor of the dispatching type of S and O is visible at the point of
81 -- of declaration of S. If the entity is found the Alias of S is set to the
82 -- original corresponding operation S and its Overridden_Operation is set
83 -- to the found entity; otherwise return Empty.
85 -- This routine does not search for non-hidden primitives since they are
86 -- covered by the normal Ada 2005 rules.
88 -------------------------------
89 -- Add_Dispatching_Operation --
90 -------------------------------
92 procedure Add_Dispatching_Operation
93 (Tagged_Type
: Entity_Id
;
96 List
: constant Elist_Id
:= Primitive_Operations
(Tagged_Type
);
99 -- The dispatching operation may already be on the list, if it is the
100 -- wrapper for an inherited function of a null extension (see Exp_Ch3
101 -- for the construction of function wrappers). The list of primitive
102 -- operations must not contain duplicates.
104 Append_Unique_Elmt
(New_Op
, List
);
105 end Add_Dispatching_Operation
;
107 ---------------------------
108 -- Covers_Some_Interface --
109 ---------------------------
111 function Covers_Some_Interface
(Prim
: Entity_Id
) return Boolean is
112 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
117 pragma Assert
(Is_Dispatching_Operation
(Prim
));
119 -- Although this is a dispatching primitive we must check if its
120 -- dispatching type is available because it may be the primitive
121 -- of a private type not defined as tagged in its partial view.
123 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
125 -- If the tagged type is frozen then the internal entities associated
126 -- with interfaces are available in the list of primitives of the
127 -- tagged type and can be used to speed up this search.
129 if Is_Frozen
(Tagged_Type
) then
130 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
131 while Present
(Elmt
) loop
134 if Present
(Interface_Alias
(E
))
135 and then Alias
(E
) = Prim
143 -- Otherwise we must collect all the interface primitives and check
144 -- if the Prim will override some interface primitive.
148 Ifaces_List
: Elist_Id
;
149 Iface_Elmt
: Elmt_Id
;
151 Iface_Prim
: Entity_Id
;
154 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
155 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
156 while Present
(Iface_Elmt
) loop
157 Iface
:= Node
(Iface_Elmt
);
159 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
160 while Present
(Elmt
) loop
161 Iface_Prim
:= Node
(Elmt
);
163 if Chars
(Iface
) = Chars
(Prim
)
164 and then Is_Interface_Conformant
165 (Tagged_Type
, Iface_Prim
, Prim
)
173 Next_Elmt
(Iface_Elmt
);
180 end Covers_Some_Interface
;
182 -------------------------------
183 -- Check_Controlling_Formals --
184 -------------------------------
186 procedure Check_Controlling_Formals
191 Ctrl_Type
: Entity_Id
;
194 Formal
:= First_Formal
(Subp
);
195 while Present
(Formal
) loop
196 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
198 if Present
(Ctrl_Type
) then
200 -- When controlling type is concurrent and declared within a
201 -- generic or inside an instance use corresponding record type.
203 if Is_Concurrent_Type
(Ctrl_Type
)
204 and then Present
(Corresponding_Record_Type
(Ctrl_Type
))
206 Ctrl_Type
:= Corresponding_Record_Type
(Ctrl_Type
);
209 if Ctrl_Type
= Typ
then
210 Set_Is_Controlling_Formal
(Formal
);
212 -- Ada 2005 (AI-231): Anonymous access types that are used in
213 -- controlling parameters exclude null because it is necessary
214 -- to read the tag to dispatch, and null has no tag.
216 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
217 Set_Can_Never_Be_Null
(Etype
(Formal
));
218 Set_Is_Known_Non_Null
(Etype
(Formal
));
221 -- Check that the parameter's nominal subtype statically
222 -- matches the first subtype.
224 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
225 if not Subtypes_Statically_Match
226 (Typ
, Designated_Type
(Etype
(Formal
)))
229 ("parameter subtype does not match controlling type",
233 elsif not Subtypes_Statically_Match
(Typ
, Etype
(Formal
)) then
235 ("parameter subtype does not match controlling type",
239 if Present
(Default_Value
(Formal
)) then
241 -- In Ada 2005, access parameters can have defaults
243 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
244 and then Ada_Version
< Ada_2005
247 ("default not allowed for controlling access parameter",
248 Default_Value
(Formal
));
250 elsif not Is_Tag_Indeterminate
(Default_Value
(Formal
)) then
252 ("default expression must be a tag indeterminate" &
253 " function call", Default_Value
(Formal
));
257 elsif Comes_From_Source
(Subp
) then
259 ("operation can be dispatching in only one type", Subp
);
263 Next_Formal
(Formal
);
266 if Ekind_In
(Subp
, E_Function
, E_Generic_Function
) then
267 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Subp
), Subp
);
269 if Present
(Ctrl_Type
) then
270 if Ctrl_Type
= Typ
then
271 Set_Has_Controlling_Result
(Subp
);
273 -- Check that result subtype statically matches first subtype
274 -- (Ada 2005): Subp may have a controlling access result.
276 if Subtypes_Statically_Match
(Typ
, Etype
(Subp
))
277 or else (Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
279 Subtypes_Statically_Match
280 (Typ
, Designated_Type
(Etype
(Subp
))))
286 ("result subtype does not match controlling type", Subp
);
289 elsif Comes_From_Source
(Subp
) then
291 ("operation can be dispatching in only one type", Subp
);
295 end Check_Controlling_Formals
;
297 ----------------------------
298 -- Check_Controlling_Type --
299 ----------------------------
301 function Check_Controlling_Type
303 Subp
: Entity_Id
) return Entity_Id
305 Tagged_Type
: Entity_Id
:= Empty
;
308 if Is_Tagged_Type
(T
) then
309 if Is_First_Subtype
(T
) then
312 Tagged_Type
:= Base_Type
(T
);
315 elsif Ekind
(T
) = E_Anonymous_Access_Type
316 and then Is_Tagged_Type
(Designated_Type
(T
))
318 if Ekind
(Designated_Type
(T
)) /= E_Incomplete_Type
then
319 if Is_First_Subtype
(Designated_Type
(T
)) then
320 Tagged_Type
:= Designated_Type
(T
);
322 Tagged_Type
:= Base_Type
(Designated_Type
(T
));
325 -- Ada 2005: an incomplete type can be tagged. An operation with an
326 -- access parameter of the type is dispatching.
328 elsif Scope
(Designated_Type
(T
)) = Current_Scope
then
329 Tagged_Type
:= Designated_Type
(T
);
331 -- Ada 2005 (AI-50217)
333 elsif From_With_Type
(Designated_Type
(T
))
334 and then Present
(Non_Limited_View
(Designated_Type
(T
)))
335 and then Scope
(Designated_Type
(T
)) = Scope
(Subp
)
337 if Is_First_Subtype
(Non_Limited_View
(Designated_Type
(T
))) then
338 Tagged_Type
:= Non_Limited_View
(Designated_Type
(T
));
340 Tagged_Type
:= Base_Type
(Non_Limited_View
341 (Designated_Type
(T
)));
346 if No
(Tagged_Type
) or else Is_Class_Wide_Type
(Tagged_Type
) then
349 -- The dispatching type and the primitive operation must be defined in
350 -- the same scope, except in the case of internal operations and formal
351 -- abstract subprograms.
353 elsif ((Scope
(Subp
) = Scope
(Tagged_Type
) or else Is_Internal
(Subp
))
354 and then (not Is_Generic_Type
(Tagged_Type
)
355 or else not Comes_From_Source
(Subp
)))
357 (Is_Formal_Subprogram
(Subp
) and then Is_Abstract_Subprogram
(Subp
))
359 (Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Renaming_Declaration
361 Present
(Corresponding_Formal_Spec
(Parent
(Parent
(Subp
))))
363 Is_Abstract_Subprogram
(Subp
))
370 end Check_Controlling_Type
;
372 ----------------------------
373 -- Check_Dispatching_Call --
374 ----------------------------
376 procedure Check_Dispatching_Call
(N
: Node_Id
) is
377 Loc
: constant Source_Ptr
:= Sloc
(N
);
380 Control
: Node_Id
:= Empty
;
382 Subp_Entity
: Entity_Id
;
383 Indeterm_Ancestor_Call
: Boolean := False;
384 Indeterm_Ctrl_Type
: Entity_Id
;
386 Static_Tag
: Node_Id
:= Empty
;
387 -- If a controlling formal has a statically tagged actual, the tag of
388 -- this actual is to be used for any tag-indeterminate actual.
390 procedure Check_Direct_Call
;
391 -- In the case when the controlling actual is a class-wide type whose
392 -- root type's completion is a task or protected type, the call is in
393 -- fact direct. This routine detects the above case and modifies the
396 procedure Check_Dispatching_Context
;
397 -- If the call is tag-indeterminate and the entity being called is
398 -- abstract, verify that the context is a call that will eventually
399 -- provide a tag for dispatching, or has provided one already.
401 -----------------------
402 -- Check_Direct_Call --
403 -----------------------
405 procedure Check_Direct_Call
is
406 Typ
: Entity_Id
:= Etype
(Control
);
408 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean;
409 -- Determine whether an entity denotes a user-defined equality
411 ------------------------------
412 -- Is_User_Defined_Equality --
413 ------------------------------
415 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
418 Ekind
(Id
) = E_Function
419 and then Chars
(Id
) = Name_Op_Eq
420 and then Comes_From_Source
(Id
)
422 -- Internally generated equalities have a full type declaration
425 and then Nkind
(Parent
(Id
)) = N_Function_Specification
;
426 end Is_User_Defined_Equality
;
428 -- Start of processing for Check_Direct_Call
431 -- Predefined primitives do not receive wrappers since they are built
432 -- from scratch for the corresponding record of synchronized types.
433 -- Equality is in general predefined, but is excluded from the check
434 -- when it is user-defined.
436 if Is_Predefined_Dispatching_Operation
(Subp_Entity
)
437 and then not Is_User_Defined_Equality
(Subp_Entity
)
442 if Is_Class_Wide_Type
(Typ
) then
443 Typ
:= Root_Type
(Typ
);
446 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
447 Typ
:= Full_View
(Typ
);
450 if Is_Concurrent_Type
(Typ
)
452 Present
(Corresponding_Record_Type
(Typ
))
454 Typ
:= Corresponding_Record_Type
(Typ
);
456 -- The concurrent record's list of primitives should contain a
457 -- wrapper for the entity of the call, retrieve it.
462 Wrapper_Found
: Boolean := False;
465 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
466 while Present
(Prim_Elmt
) loop
467 Prim
:= Node
(Prim_Elmt
);
469 if Is_Primitive_Wrapper
(Prim
)
470 and then Wrapped_Entity
(Prim
) = Subp_Entity
472 Wrapper_Found
:= True;
476 Next_Elmt
(Prim_Elmt
);
479 -- A primitive declared between two views should have a
480 -- corresponding wrapper.
482 pragma Assert
(Wrapper_Found
);
484 -- Modify the call by setting the proper entity
486 Set_Entity
(Name
(N
), Prim
);
489 end Check_Direct_Call
;
491 -------------------------------
492 -- Check_Dispatching_Context --
493 -------------------------------
495 procedure Check_Dispatching_Context
is
496 Subp
: constant Entity_Id
:= Entity
(Name
(N
));
497 Typ
: constant Entity_Id
:= Etype
(Subp
);
500 procedure Abstract_Context_Error
;
501 -- Error for abstract call dispatching on result is not dispatching
503 ----------------------------
504 -- Abstract_Context_Error --
505 ----------------------------
507 procedure Abstract_Context_Error
is
509 if Ekind
(Subp
) = E_Function
then
511 ("call to abstract function must be dispatching", N
);
513 -- This error can occur for a procedure in the case of a call to
514 -- an abstract formal procedure with a statically tagged operand.
518 ("call to abstract procedure must be dispatching",
521 end Abstract_Context_Error
;
523 -- Start of processing for Check_Dispatching_Context
526 if Is_Abstract_Subprogram
(Subp
)
527 and then No
(Controlling_Argument
(N
))
529 if Present
(Alias
(Subp
))
530 and then not Is_Abstract_Subprogram
(Alias
(Subp
))
531 and then No
(DTC_Entity
(Subp
))
533 -- Private overriding of inherited abstract operation, call is
536 Set_Entity
(Name
(N
), Alias
(Subp
));
540 -- We need to determine whether the context of the call
541 -- provides a tag to make the call dispatching. This requires
542 -- the call to be the actual in an enclosing call, and that
543 -- actual must be controlling. If the call is an operand of
544 -- equality, the other operand must not ve abstract.
546 if not Is_Tagged_Type
(Typ
)
548 (Ekind
(Typ
) = E_Anonymous_Access_Type
549 and then Is_Tagged_Type
(Designated_Type
(Typ
)))
551 Abstract_Context_Error
;
557 if Nkind
(Par
) = N_Parameter_Association
then
561 while Present
(Par
) loop
562 if Nkind_In
(Par
, N_Function_Call
,
563 N_Procedure_Call_Statement
)
564 and then Is_Entity_Name
(Name
(Par
))
571 -- Find formal for which call is the actual.
573 F
:= First_Formal
(Entity
(Name
(Par
)));
574 A
:= First_Actual
(Par
);
575 while Present
(F
) loop
576 if Is_Controlling_Formal
(F
)
577 and then (N
= A
or else Parent
(N
) = A
)
587 ("call to abstract function must be dispatching", N
);
591 -- For equalitiy operators, one of the operands must be
592 -- statically or dynamically tagged.
594 elsif Nkind_In
(Par
, N_Op_Eq
, N_Op_Ne
) then
595 if N
= Right_Opnd
(Par
)
596 and then Is_Tag_Indeterminate
(Left_Opnd
(Par
))
598 Abstract_Context_Error
;
600 elsif N
= Left_Opnd
(Par
)
601 and then Is_Tag_Indeterminate
(Right_Opnd
(Par
))
603 Abstract_Context_Error
;
608 elsif Nkind
(Par
) = N_Assignment_Statement
then
611 elsif Nkind
(Par
) = N_Qualified_Expression
612 or else Nkind
(Par
) = N_Unchecked_Type_Conversion
617 Abstract_Context_Error
;
623 end Check_Dispatching_Context
;
625 -- Start of processing for Check_Dispatching_Call
628 -- Find a controlling argument, if any
630 if Present
(Parameter_Associations
(N
)) then
631 Subp_Entity
:= Entity
(Name
(N
));
633 Actual
:= First_Actual
(N
);
634 Formal
:= First_Formal
(Subp_Entity
);
635 while Present
(Actual
) loop
636 Control
:= Find_Controlling_Arg
(Actual
);
637 exit when Present
(Control
);
639 -- Check for the case where the actual is a tag-indeterminate call
640 -- whose result type is different than the tagged type associated
641 -- with the containing call, but is an ancestor of the type.
643 if Is_Controlling_Formal
(Formal
)
644 and then Is_Tag_Indeterminate
(Actual
)
645 and then Base_Type
(Etype
(Actual
)) /= Base_Type
(Etype
(Formal
))
646 and then Is_Ancestor
(Etype
(Actual
), Etype
(Formal
))
648 Indeterm_Ancestor_Call
:= True;
649 Indeterm_Ctrl_Type
:= Etype
(Formal
);
651 -- If the formal is controlling but the actual is not, the type
652 -- of the actual is statically known, and may be used as the
653 -- controlling tag for some other tag-indeterminate actual.
655 elsif Is_Controlling_Formal
(Formal
)
656 and then Is_Entity_Name
(Actual
)
657 and then Is_Tagged_Type
(Etype
(Actual
))
659 Static_Tag
:= Actual
;
662 Next_Actual
(Actual
);
663 Next_Formal
(Formal
);
666 -- If the call doesn't have a controlling actual but does have an
667 -- indeterminate actual that requires dispatching treatment, then an
668 -- object is needed that will serve as the controlling argument for
669 -- a dispatching call on the indeterminate actual. This can only
670 -- occur in the unusual situation of a default actual given by
671 -- a tag-indeterminate call and where the type of the call is an
672 -- ancestor of the type associated with a containing call to an
673 -- inherited operation (see AI-239).
675 -- Rather than create an object of the tagged type, which would
676 -- be problematic for various reasons (default initialization,
677 -- discriminants), the tag of the containing call's associated
678 -- tagged type is directly used to control the dispatching.
681 and then Indeterm_Ancestor_Call
682 and then No
(Static_Tag
)
685 Make_Attribute_Reference
(Loc
,
686 Prefix
=> New_Occurrence_Of
(Indeterm_Ctrl_Type
, Loc
),
687 Attribute_Name
=> Name_Tag
);
692 if Present
(Control
) then
694 -- Verify that no controlling arguments are statically tagged
697 Write_Str
("Found Dispatching call");
702 Actual
:= First_Actual
(N
);
703 while Present
(Actual
) loop
704 if Actual
/= Control
then
706 if not Is_Controlling_Actual
(Actual
) then
707 null; -- Can be anything
709 elsif Is_Dynamically_Tagged
(Actual
) then
710 null; -- Valid parameter
712 elsif Is_Tag_Indeterminate
(Actual
) then
714 -- The tag is inherited from the enclosing call (the node
715 -- we are currently analyzing). Explicitly expand the
716 -- actual, since the previous call to Expand (from
717 -- Resolve_Call) had no way of knowing about the
718 -- required dispatching.
720 Propagate_Tag
(Control
, Actual
);
724 ("controlling argument is not dynamically tagged",
730 Next_Actual
(Actual
);
733 -- Mark call as a dispatching call
735 Set_Controlling_Argument
(N
, Control
);
736 Check_Restriction
(No_Dispatching_Calls
, N
);
738 -- The dispatching call may need to be converted into a direct
739 -- call in certain cases.
743 -- If there is a statically tagged actual and a tag-indeterminate
744 -- call to a function of the ancestor (such as that provided by a
745 -- default), then treat this as a dispatching call and propagate
746 -- the tag to the tag-indeterminate call(s).
748 elsif Present
(Static_Tag
) and then Indeterm_Ancestor_Call
then
750 Make_Attribute_Reference
(Loc
,
752 New_Occurrence_Of
(Etype
(Static_Tag
), Loc
),
753 Attribute_Name
=> Name_Tag
);
757 Actual
:= First_Actual
(N
);
758 Formal
:= First_Formal
(Subp_Entity
);
759 while Present
(Actual
) loop
760 if Is_Tag_Indeterminate
(Actual
)
761 and then Is_Controlling_Formal
(Formal
)
763 Propagate_Tag
(Control
, Actual
);
766 Next_Actual
(Actual
);
767 Next_Formal
(Formal
);
770 Check_Dispatching_Context
;
773 -- The call is not dispatching, so check that there aren't any
774 -- tag-indeterminate abstract calls left.
776 Actual
:= First_Actual
(N
);
777 while Present
(Actual
) loop
778 if Is_Tag_Indeterminate
(Actual
) then
780 -- Function call case
782 if Nkind
(Original_Node
(Actual
)) = N_Function_Call
then
783 Func
:= Entity
(Name
(Original_Node
(Actual
)));
785 -- If the actual is an attribute then it can't be abstract
786 -- (the only current case of a tag-indeterminate attribute
787 -- is the stream Input attribute).
790 Nkind
(Original_Node
(Actual
)) = N_Attribute_Reference
794 -- Only other possibility is a qualified expression whose
795 -- constituent expression is itself a call.
801 (Expression
(Original_Node
(Actual
)))));
804 if Present
(Func
) and then Is_Abstract_Subprogram
(Func
) then
806 ("call to abstract function must be dispatching", N
);
810 Next_Actual
(Actual
);
813 Check_Dispatching_Context
;
817 -- If dispatching on result, the enclosing call, if any, will
818 -- determine the controlling argument. Otherwise this is the
819 -- primitive operation of the root type.
821 Check_Dispatching_Context
;
823 end Check_Dispatching_Call
;
825 ---------------------------------
826 -- Check_Dispatching_Operation --
827 ---------------------------------
829 procedure Check_Dispatching_Operation
(Subp
, Old_Subp
: Entity_Id
) is
830 Tagged_Type
: Entity_Id
;
831 Has_Dispatching_Parent
: Boolean := False;
832 Body_Is_Last_Primitive
: Boolean := False;
833 Ovr_Subp
: Entity_Id
:= Empty
;
836 if not Ekind_In
(Subp
, E_Procedure
, E_Function
) then
840 Set_Is_Dispatching_Operation
(Subp
, False);
841 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
843 -- Ada 2005 (AI-345): Use the corresponding record (if available).
844 -- Required because primitives of concurrent types are attached
845 -- to the corresponding record (not to the concurrent type).
847 if Ada_Version
>= Ada_2005
848 and then Present
(Tagged_Type
)
849 and then Is_Concurrent_Type
(Tagged_Type
)
850 and then Present
(Corresponding_Record_Type
(Tagged_Type
))
852 Tagged_Type
:= Corresponding_Record_Type
(Tagged_Type
);
855 -- (AI-345): The task body procedure is not a primitive of the tagged
858 if Present
(Tagged_Type
)
859 and then Is_Concurrent_Record_Type
(Tagged_Type
)
860 and then Present
(Corresponding_Concurrent_Type
(Tagged_Type
))
861 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Tagged_Type
))
862 and then Subp
= Get_Task_Body_Procedure
863 (Corresponding_Concurrent_Type
(Tagged_Type
))
868 -- If Subp is derived from a dispatching operation then it should
869 -- always be treated as dispatching. In this case various checks
870 -- below will be bypassed. Makes sure that late declarations for
871 -- inherited private subprograms are treated as dispatching, even
872 -- if the associated tagged type is already frozen.
874 Has_Dispatching_Parent
:=
875 Present
(Alias
(Subp
))
876 and then Is_Dispatching_Operation
(Alias
(Subp
));
878 if No
(Tagged_Type
) then
880 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
881 -- with an abstract interface type unless the interface acts as a
882 -- parent type in a derivation. If the interface type is a formal
883 -- type then the operation is not primitive and therefore legal.
890 E
:= First_Entity
(Subp
);
891 while Present
(E
) loop
893 -- For an access parameter, check designated type
895 if Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
then
896 Typ
:= Designated_Type
(Etype
(E
));
901 if Comes_From_Source
(Subp
)
902 and then Is_Interface
(Typ
)
903 and then not Is_Class_Wide_Type
(Typ
)
904 and then not Is_Derived_Type
(Typ
)
905 and then not Is_Generic_Type
(Typ
)
906 and then not In_Instance
908 Error_Msg_N
("??declaration of& is too late!", Subp
);
909 Error_Msg_NE
-- CODEFIX??
910 ("\??spec should appear immediately after declaration "
911 & "of & !", Subp
, Typ
);
918 -- In case of functions check also the result type
920 if Ekind
(Subp
) = E_Function
then
921 if Is_Access_Type
(Etype
(Subp
)) then
922 Typ
:= Designated_Type
(Etype
(Subp
));
927 -- The following should be better commented, especially since
928 -- we just added several new conditions here ???
930 if Comes_From_Source
(Subp
)
931 and then Is_Interface
(Typ
)
932 and then not Is_Class_Wide_Type
(Typ
)
933 and then not Is_Derived_Type
(Typ
)
934 and then not Is_Generic_Type
(Typ
)
935 and then not In_Instance
937 Error_Msg_N
("??declaration of& is too late!", Subp
);
939 ("\??spec should appear immediately after declaration "
940 & "of & !", Subp
, Typ
);
947 -- The subprograms build internally after the freezing point (such as
948 -- init procs, interface thunks, type support subprograms, and Offset
949 -- to top functions for accessing interface components in variable
950 -- size tagged types) are not primitives.
952 elsif Is_Frozen
(Tagged_Type
)
953 and then not Comes_From_Source
(Subp
)
954 and then not Has_Dispatching_Parent
956 -- Complete decoration of internally built subprograms that override
957 -- a dispatching primitive. These entities correspond with the
960 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
961 -- to override functions of nonabstract null extensions. These
962 -- primitives were added to the list of primitives of the tagged
963 -- type by Make_Controlling_Function_Wrappers. However, attribute
964 -- Is_Dispatching_Operation must be set to true.
966 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
969 -- 3. Subprograms associated with stream attributes (built by
970 -- New_Stream_Subprogram)
972 if Present
(Old_Subp
)
973 and then Present
(Overridden_Operation
(Subp
))
974 and then Is_Dispatching_Operation
(Old_Subp
)
977 ((Ekind
(Subp
) = E_Function
978 and then Is_Dispatching_Operation
(Old_Subp
)
979 and then Is_Null_Extension
(Base_Type
(Etype
(Subp
))))
981 (Ekind
(Subp
) = E_Procedure
982 and then Is_Dispatching_Operation
(Old_Subp
)
983 and then Present
(Alias
(Old_Subp
))
984 and then Is_Null_Interface_Primitive
985 (Ultimate_Alias
(Old_Subp
)))
986 or else Get_TSS_Name
(Subp
) = TSS_Stream_Read
987 or else Get_TSS_Name
(Subp
) = TSS_Stream_Write
);
989 Check_Controlling_Formals
(Tagged_Type
, Subp
);
990 Override_Dispatching_Operation
(Tagged_Type
, Old_Subp
, Subp
);
991 Set_Is_Dispatching_Operation
(Subp
);
996 -- The operation may be a child unit, whose scope is the defining
997 -- package, but which is not a primitive operation of the type.
999 elsif Is_Child_Unit
(Subp
) then
1002 -- If the subprogram is not defined in a package spec, the only case
1003 -- where it can be a dispatching op is when it overrides an operation
1004 -- before the freezing point of the type.
1006 elsif ((not Is_Package_Or_Generic_Package
(Scope
(Subp
)))
1007 or else In_Package_Body
(Scope
(Subp
)))
1008 and then not Has_Dispatching_Parent
1010 if not Comes_From_Source
(Subp
)
1011 or else (Present
(Old_Subp
) and then not Is_Frozen
(Tagged_Type
))
1015 -- If the type is already frozen, the overriding is not allowed
1016 -- except when Old_Subp is not a dispatching operation (which can
1017 -- occur when Old_Subp was inherited by an untagged type). However,
1018 -- a body with no previous spec freezes the type *after* its
1019 -- declaration, and therefore is a legal overriding (unless the type
1020 -- has already been frozen). Only the first such body is legal.
1022 elsif Present
(Old_Subp
)
1023 and then Is_Dispatching_Operation
(Old_Subp
)
1025 if Comes_From_Source
(Subp
)
1027 (Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Body
1028 or else Nkind
(Unit_Declaration_Node
(Subp
)) in N_Body_Stub
)
1031 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1032 Decl_Item
: Node_Id
;
1035 -- ??? The checks here for whether the type has been frozen
1036 -- prior to the new body are not complete. It's not simple
1037 -- to check frozenness at this point since the body has
1038 -- already caused the type to be prematurely frozen in
1039 -- Analyze_Declarations, but we're forced to recheck this
1040 -- here because of the odd rule interpretation that allows
1041 -- the overriding if the type wasn't frozen prior to the
1042 -- body. The freezing action should probably be delayed
1043 -- until after the spec is seen, but that's a tricky
1044 -- change to the delicate freezing code.
1046 -- Look at each declaration following the type up until the
1047 -- new subprogram body. If any of the declarations is a body
1048 -- then the type has been frozen already so the overriding
1049 -- primitive is illegal.
1051 Decl_Item
:= Next
(Parent
(Tagged_Type
));
1052 while Present
(Decl_Item
)
1053 and then (Decl_Item
/= Subp_Body
)
1055 if Comes_From_Source
(Decl_Item
)
1056 and then (Nkind
(Decl_Item
) in N_Proper_Body
1057 or else Nkind
(Decl_Item
) in N_Body_Stub
)
1059 Error_Msg_N
("overriding of& is too late!", Subp
);
1061 ("\spec should appear immediately after the type!",
1069 -- If the subprogram doesn't follow in the list of
1070 -- declarations including the type then the type has
1071 -- definitely been frozen already and the body is illegal.
1073 if No
(Decl_Item
) then
1074 Error_Msg_N
("overriding of& is too late!", Subp
);
1076 ("\spec should appear immediately after the type!",
1079 elsif Is_Frozen
(Subp
) then
1081 -- The subprogram body declares a primitive operation.
1082 -- If the subprogram is already frozen, we must update
1083 -- its dispatching information explicitly here. The
1084 -- information is taken from the overridden subprogram.
1085 -- We must also generate a cross-reference entry because
1086 -- references to other primitives were already created
1087 -- when type was frozen.
1089 Body_Is_Last_Primitive
:= True;
1091 if Present
(DTC_Entity
(Old_Subp
)) then
1092 Set_DTC_Entity
(Subp
, DTC_Entity
(Old_Subp
));
1093 Set_DT_Position
(Subp
, DT_Position
(Old_Subp
));
1095 if not Restriction_Active
(No_Dispatching_Calls
) then
1096 if Building_Static_DT
(Tagged_Type
) then
1098 -- If the static dispatch table has not been
1099 -- built then there is nothing else to do now;
1100 -- otherwise we notify that we cannot build the
1101 -- static dispatch table.
1103 if Has_Dispatch_Table
(Tagged_Type
) then
1105 ("overriding of& is too late for building" &
1106 " static dispatch tables!", Subp
);
1108 ("\spec should appear immediately after" &
1109 " the type!", Subp
);
1112 -- No code required to register primitives in VM
1115 elsif VM_Target
/= No_VM
then
1119 Insert_Actions_After
(Subp_Body
,
1120 Register_Primitive
(Sloc
(Subp_Body
),
1124 -- Indicate that this is an overriding operation,
1125 -- and replace the overridden entry in the list of
1126 -- primitive operations, which is used for xref
1127 -- generation subsequently.
1129 Generate_Reference
(Tagged_Type
, Subp
, 'P', False);
1130 Override_Dispatching_Operation
1131 (Tagged_Type
, Old_Subp
, Subp
);
1138 Error_Msg_N
("overriding of& is too late!", Subp
);
1140 ("\subprogram spec should appear immediately after the type!",
1144 -- If the type is not frozen yet and we are not in the overriding
1145 -- case it looks suspiciously like an attempt to define a primitive
1146 -- operation, which requires the declaration to be in a package spec
1147 -- (3.2.3(6)). Only report cases where the type and subprogram are
1148 -- in the same declaration list (by checking the enclosing parent
1149 -- declarations), to avoid spurious warnings on subprograms in
1150 -- instance bodies when the type is declared in the instance spec
1151 -- but hasn't been frozen by the instance body.
1153 elsif not Is_Frozen
(Tagged_Type
)
1154 and then In_Same_List
(Parent
(Tagged_Type
), Parent
(Parent
(Subp
)))
1157 ("??not dispatching (must be defined in a package spec)", Subp
);
1160 -- When the type is frozen, it is legitimate to define a new
1161 -- non-primitive operation.
1167 -- Now, we are sure that the scope is a package spec. If the subprogram
1168 -- is declared after the freezing point of the type that's an error
1170 elsif Is_Frozen
(Tagged_Type
) and then not Has_Dispatching_Parent
then
1171 Error_Msg_N
("this primitive operation is declared too late", Subp
);
1173 ("??no primitive operations for& after this line",
1174 Freeze_Node
(Tagged_Type
),
1179 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1181 Ovr_Subp
:= Old_Subp
;
1183 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1184 -- overridden by Subp
1187 and then Ada_Version
>= Ada_2012
1189 Ovr_Subp
:= Find_Hidden_Overridden_Primitive
(Subp
);
1192 -- Now it should be a correct primitive operation, put it in the list
1194 if Present
(Ovr_Subp
) then
1196 -- If the type has interfaces we complete this check after we set
1197 -- attribute Is_Dispatching_Operation.
1199 Check_Subtype_Conformant
(Subp
, Ovr_Subp
);
1201 if (Chars
(Subp
) = Name_Initialize
1202 or else Chars
(Subp
) = Name_Adjust
1203 or else Chars
(Subp
) = Name_Finalize
)
1204 and then Is_Controlled
(Tagged_Type
)
1205 and then not Is_Visibly_Controlled
(Tagged_Type
)
1207 Set_Overridden_Operation
(Subp
, Empty
);
1209 -- If the subprogram specification carries an overriding
1210 -- indicator, no need for the warning: it is either redundant,
1211 -- or else an error will be reported.
1213 if Nkind
(Parent
(Subp
)) = N_Procedure_Specification
1215 (Must_Override
(Parent
(Subp
))
1216 or else Must_Not_Override
(Parent
(Subp
)))
1220 -- Here we need the warning
1224 ("operation does not override inherited&??", Subp
, Subp
);
1228 Override_Dispatching_Operation
(Tagged_Type
, Ovr_Subp
, Subp
);
1230 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1231 -- that covers abstract interface subprograms we must register it
1232 -- in all the secondary dispatch tables associated with abstract
1233 -- interfaces. We do this now only if not building static tables,
1234 -- nor when the expander is inactive (we avoid trying to register
1235 -- primitives in semantics-only mode, since the type may not have
1236 -- an associated dispatch table). Otherwise the patch code is
1237 -- emitted after those tables are built, to prevent access before
1238 -- elaboration in gigi.
1240 if Body_Is_Last_Primitive
and then Full_Expander_Active
then
1242 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1247 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1248 while Present
(Elmt
) loop
1249 Prim
:= Node
(Elmt
);
1251 -- No code required to register primitives in VM targets
1253 if Present
(Alias
(Prim
))
1254 and then Present
(Interface_Alias
(Prim
))
1255 and then Alias
(Prim
) = Subp
1256 and then not Building_Static_DT
(Tagged_Type
)
1257 and then VM_Target
= No_VM
1259 Insert_Actions_After
(Subp_Body
,
1260 Register_Primitive
(Sloc
(Subp_Body
), Prim
=> Prim
));
1266 -- Redisplay the contents of the updated dispatch table
1268 if Debug_Flag_ZZ
then
1269 Write_Str
("Late overriding: ");
1270 Write_DT
(Tagged_Type
);
1276 -- If the tagged type is a concurrent type then we must be compiling
1277 -- with no code generation (we are either compiling a generic unit or
1278 -- compiling under -gnatc mode) because we have previously tested that
1279 -- no serious errors has been reported. In this case we do not add the
1280 -- primitive to the list of primitives of Tagged_Type but we leave the
1281 -- primitive decorated as a dispatching operation to be able to analyze
1282 -- and report errors associated with the Object.Operation notation.
1284 elsif Is_Concurrent_Type
(Tagged_Type
) then
1285 pragma Assert
(not Expander_Active
);
1288 -- If no old subprogram, then we add this as a dispatching operation,
1289 -- but we avoid doing this if an error was posted, to prevent annoying
1292 elsif not Error_Posted
(Subp
) then
1293 Add_Dispatching_Operation
(Tagged_Type
, Subp
);
1296 Set_Is_Dispatching_Operation
(Subp
, True);
1298 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1299 -- subtype conformance against all the interfaces covered by this
1302 if Present
(Ovr_Subp
)
1303 and then Has_Interfaces
(Tagged_Type
)
1306 Ifaces_List
: Elist_Id
;
1307 Iface_Elmt
: Elmt_Id
;
1308 Iface_Prim_Elmt
: Elmt_Id
;
1309 Iface_Prim
: Entity_Id
;
1310 Ret_Typ
: Entity_Id
;
1313 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
1315 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1316 while Present
(Iface_Elmt
) loop
1317 if not Is_Ancestor
(Node
(Iface_Elmt
), Tagged_Type
) then
1319 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
1320 while Present
(Iface_Prim_Elmt
) loop
1321 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
1323 if Is_Interface_Conformant
1324 (Tagged_Type
, Iface_Prim
, Subp
)
1326 -- Handle procedures, functions whose return type
1327 -- matches, or functions not returning interfaces
1329 if Ekind
(Subp
) = E_Procedure
1330 or else Etype
(Iface_Prim
) = Etype
(Subp
)
1331 or else not Is_Interface
(Etype
(Iface_Prim
))
1333 Check_Subtype_Conformant
1335 Old_Id
=> Iface_Prim
,
1337 Skip_Controlling_Formals
=> True);
1339 -- Handle functions returning interfaces
1341 elsif Implements_Interface
1342 (Etype
(Subp
), Etype
(Iface_Prim
))
1344 -- Temporarily force both entities to return the
1345 -- same type. Required because Subtype_Conformant
1346 -- does not handle this case.
1348 Ret_Typ
:= Etype
(Iface_Prim
);
1349 Set_Etype
(Iface_Prim
, Etype
(Subp
));
1351 Check_Subtype_Conformant
1353 Old_Id
=> Iface_Prim
,
1355 Skip_Controlling_Formals
=> True);
1357 Set_Etype
(Iface_Prim
, Ret_Typ
);
1361 Next_Elmt
(Iface_Prim_Elmt
);
1365 Next_Elmt
(Iface_Elmt
);
1370 if not Body_Is_Last_Primitive
then
1371 Set_DT_Position
(Subp
, No_Uint
);
1373 elsif Has_Controlled_Component
(Tagged_Type
)
1375 (Chars
(Subp
) = Name_Initialize
or else
1376 Chars
(Subp
) = Name_Adjust
or else
1377 Chars
(Subp
) = Name_Finalize
or else
1378 Chars
(Subp
) = Name_Finalize_Address
)
1381 F_Node
: constant Node_Id
:= Freeze_Node
(Tagged_Type
);
1385 Old_Spec
: Entity_Id
;
1387 C_Names
: constant array (1 .. 4) of Name_Id
:=
1391 Name_Finalize_Address
);
1393 D_Names
: constant array (1 .. 4) of TSS_Name_Type
:=
1394 (TSS_Deep_Initialize
,
1397 TSS_Finalize_Address
);
1400 -- Remove previous controlled function which was constructed and
1401 -- analyzed when the type was frozen. This requires removing the
1402 -- body of the redefined primitive, as well as its specification
1403 -- if needed (there is no spec created for Deep_Initialize, see
1404 -- exp_ch3.adb). We must also dismantle the exception information
1405 -- that may have been generated for it when front end zero-cost
1406 -- tables are enabled.
1408 for J
in D_Names
'Range loop
1409 Old_P
:= TSS
(Tagged_Type
, D_Names
(J
));
1412 and then Chars
(Subp
) = C_Names
(J
)
1414 Old_Bod
:= Unit_Declaration_Node
(Old_P
);
1416 Set_Is_Eliminated
(Old_P
);
1417 Set_Scope
(Old_P
, Scope
(Current_Scope
));
1419 if Nkind
(Old_Bod
) = N_Subprogram_Body
1420 and then Present
(Corresponding_Spec
(Old_Bod
))
1422 Old_Spec
:= Corresponding_Spec
(Old_Bod
);
1423 Set_Has_Completion
(Old_Spec
, False);
1428 Build_Late_Proc
(Tagged_Type
, Chars
(Subp
));
1430 -- The new operation is added to the actions of the freeze node
1431 -- for the type, but this node has already been analyzed, so we
1432 -- must retrieve and analyze explicitly the new body.
1435 and then Present
(Actions
(F_Node
))
1437 Decl
:= Last
(Actions
(F_Node
));
1442 end Check_Dispatching_Operation
;
1444 ------------------------------------------
1445 -- Check_Operation_From_Incomplete_Type --
1446 ------------------------------------------
1448 procedure Check_Operation_From_Incomplete_Type
1452 Full
: constant Entity_Id
:= Full_View
(Typ
);
1453 Parent_Typ
: constant Entity_Id
:= Etype
(Full
);
1454 Old_Prim
: constant Elist_Id
:= Primitive_Operations
(Parent_Typ
);
1455 New_Prim
: constant Elist_Id
:= Primitive_Operations
(Full
);
1457 Prev
: Elmt_Id
:= No_Elmt
;
1459 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean;
1460 -- Check that Subp has profile of an operation derived from Parent_Subp.
1461 -- Subp must have a parameter or result type that is Typ or an access
1462 -- parameter or access result type that designates Typ.
1468 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean is
1472 if Chars
(Parent_Subp
) /= Chars
(Subp
) then
1476 -- Check that the type of controlling formals is derived from the
1477 -- parent subprogram's controlling formal type (or designated type
1478 -- if the formal type is an anonymous access type).
1480 F1
:= First_Formal
(Parent_Subp
);
1481 F2
:= First_Formal
(Subp
);
1482 while Present
(F1
) and then Present
(F2
) loop
1483 if Ekind
(Etype
(F1
)) = E_Anonymous_Access_Type
then
1484 if Ekind
(Etype
(F2
)) /= E_Anonymous_Access_Type
then
1486 elsif Designated_Type
(Etype
(F1
)) = Parent_Typ
1487 and then Designated_Type
(Etype
(F2
)) /= Full
1492 elsif Ekind
(Etype
(F2
)) = E_Anonymous_Access_Type
then
1495 elsif Etype
(F1
) = Parent_Typ
and then Etype
(F2
) /= Full
then
1503 -- Check that a controlling result type is derived from the parent
1504 -- subprogram's result type (or designated type if the result type
1505 -- is an anonymous access type).
1507 if Ekind
(Parent_Subp
) = E_Function
then
1508 if Ekind
(Subp
) /= E_Function
then
1511 elsif Ekind
(Etype
(Parent_Subp
)) = E_Anonymous_Access_Type
then
1512 if Ekind
(Etype
(Subp
)) /= E_Anonymous_Access_Type
then
1515 elsif Designated_Type
(Etype
(Parent_Subp
)) = Parent_Typ
1516 and then Designated_Type
(Etype
(Subp
)) /= Full
1521 elsif Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
then
1524 elsif Etype
(Parent_Subp
) = Parent_Typ
1525 and then Etype
(Subp
) /= Full
1530 elsif Ekind
(Subp
) = E_Function
then
1534 return No
(F1
) and then No
(F2
);
1537 -- Start of processing for Check_Operation_From_Incomplete_Type
1540 -- The operation may override an inherited one, or may be a new one
1541 -- altogether. The inherited operation will have been hidden by the
1542 -- current one at the point of the type derivation, so it does not
1543 -- appear in the list of primitive operations of the type. We have to
1544 -- find the proper place of insertion in the list of primitive opera-
1545 -- tions by iterating over the list for the parent type.
1547 Op1
:= First_Elmt
(Old_Prim
);
1548 Op2
:= First_Elmt
(New_Prim
);
1549 while Present
(Op1
) and then Present
(Op2
) loop
1550 if Derives_From
(Node
(Op1
)) then
1553 -- Avoid adding it to the list of primitives if already there!
1555 if Node
(Op2
) /= Subp
then
1556 Prepend_Elmt
(Subp
, New_Prim
);
1560 Insert_Elmt_After
(Subp
, Prev
);
1571 -- Operation is a new primitive
1573 Append_Elmt
(Subp
, New_Prim
);
1574 end Check_Operation_From_Incomplete_Type
;
1576 ---------------------------------------
1577 -- Check_Operation_From_Private_View --
1578 ---------------------------------------
1580 procedure Check_Operation_From_Private_View
(Subp
, Old_Subp
: Entity_Id
) is
1581 Tagged_Type
: Entity_Id
;
1584 if Is_Dispatching_Operation
(Alias
(Subp
)) then
1585 Set_Scope
(Subp
, Current_Scope
);
1586 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1588 -- Add Old_Subp to primitive operations if not already present
1590 if Present
(Tagged_Type
) and then Is_Tagged_Type
(Tagged_Type
) then
1591 Append_Unique_Elmt
(Old_Subp
, Primitive_Operations
(Tagged_Type
));
1593 -- If Old_Subp isn't already marked as dispatching then this is
1594 -- the case of an operation of an untagged private type fulfilled
1595 -- by a tagged type that overrides an inherited dispatching
1596 -- operation, so we set the necessary dispatching attributes here.
1598 if not Is_Dispatching_Operation
(Old_Subp
) then
1600 -- If the untagged type has no discriminants, and the full
1601 -- view is constrained, there will be a spurious mismatch of
1602 -- subtypes on the controlling arguments, because the tagged
1603 -- type is the internal base type introduced in the derivation.
1604 -- Use the original type to verify conformance, rather than the
1607 if not Comes_From_Source
(Tagged_Type
)
1608 and then Has_Discriminants
(Tagged_Type
)
1614 Formal
:= First_Formal
(Old_Subp
);
1615 while Present
(Formal
) loop
1616 if Tagged_Type
= Base_Type
(Etype
(Formal
)) then
1617 Tagged_Type
:= Etype
(Formal
);
1620 Next_Formal
(Formal
);
1624 if Tagged_Type
= Base_Type
(Etype
(Old_Subp
)) then
1625 Tagged_Type
:= Etype
(Old_Subp
);
1629 Check_Controlling_Formals
(Tagged_Type
, Old_Subp
);
1630 Set_Is_Dispatching_Operation
(Old_Subp
, True);
1631 Set_DT_Position
(Old_Subp
, No_Uint
);
1634 -- If the old subprogram is an explicit renaming of some other
1635 -- entity, it is not overridden by the inherited subprogram.
1636 -- Otherwise, update its alias and other attributes.
1638 if Present
(Alias
(Old_Subp
))
1639 and then Nkind
(Unit_Declaration_Node
(Old_Subp
)) /=
1640 N_Subprogram_Renaming_Declaration
1642 Set_Alias
(Old_Subp
, Alias
(Subp
));
1644 -- The derived subprogram should inherit the abstractness of
1645 -- the parent subprogram (except in the case of a function
1646 -- returning the type). This sets the abstractness properly
1647 -- for cases where a private extension may have inherited an
1648 -- abstract operation, but the full type is derived from a
1649 -- descendant type and inherits a nonabstract version.
1651 if Etype
(Subp
) /= Tagged_Type
then
1652 Set_Is_Abstract_Subprogram
1653 (Old_Subp
, Is_Abstract_Subprogram
(Alias
(Subp
)));
1658 end Check_Operation_From_Private_View
;
1660 --------------------------
1661 -- Find_Controlling_Arg --
1662 --------------------------
1664 function Find_Controlling_Arg
(N
: Node_Id
) return Node_Id
is
1665 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
1669 if Nkind
(Orig_Node
) = N_Qualified_Expression
then
1670 return Find_Controlling_Arg
(Expression
(Orig_Node
));
1673 -- Dispatching on result case. If expansion is disabled, the node still
1674 -- has the structure of a function call. However, if the function name
1675 -- is an operator and the call was given in infix form, the original
1676 -- node has no controlling result and we must examine the current node.
1678 if Nkind
(N
) = N_Function_Call
1679 and then Present
(Controlling_Argument
(N
))
1680 and then Has_Controlling_Result
(Entity
(Name
(N
)))
1682 return Controlling_Argument
(N
);
1684 -- If expansion is enabled, the call may have been transformed into
1685 -- an indirect call, and we need to recover the original node.
1687 elsif Nkind
(Orig_Node
) = N_Function_Call
1688 and then Present
(Controlling_Argument
(Orig_Node
))
1689 and then Has_Controlling_Result
(Entity
(Name
(Orig_Node
)))
1691 return Controlling_Argument
(Orig_Node
);
1693 -- Type conversions are dynamically tagged if the target type, or its
1694 -- designated type, are classwide. An interface conversion expands into
1695 -- a dereference, so test must be performed on the original node.
1697 elsif Nkind
(Orig_Node
) = N_Type_Conversion
1698 and then Nkind
(N
) = N_Explicit_Dereference
1699 and then Is_Controlling_Actual
(N
)
1702 Target_Type
: constant Entity_Id
:=
1703 Entity
(Subtype_Mark
(Orig_Node
));
1706 if Is_Class_Wide_Type
(Target_Type
) then
1709 elsif Is_Access_Type
(Target_Type
)
1710 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
1721 elsif Is_Controlling_Actual
(N
)
1723 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1724 and then Is_Controlling_Actual
(Parent
(N
)))
1728 if Is_Access_Type
(Typ
) then
1730 -- In the case of an Access attribute, use the type of the prefix,
1731 -- since in the case of an actual for an access parameter, the
1732 -- attribute's type may be of a specific designated type, even
1733 -- though the prefix type is class-wide.
1735 if Nkind
(N
) = N_Attribute_Reference
then
1736 Typ
:= Etype
(Prefix
(N
));
1738 -- An allocator is dispatching if the type of qualified expression
1739 -- is class_wide, in which case this is the controlling type.
1741 elsif Nkind
(Orig_Node
) = N_Allocator
1742 and then Nkind
(Expression
(Orig_Node
)) = N_Qualified_Expression
1744 Typ
:= Etype
(Expression
(Orig_Node
));
1746 Typ
:= Designated_Type
(Typ
);
1750 if Is_Class_Wide_Type
(Typ
)
1752 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1753 and then Is_Access_Type
(Etype
(N
))
1754 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(N
))))
1761 end Find_Controlling_Arg
;
1763 ---------------------------
1764 -- Find_Dispatching_Type --
1765 ---------------------------
1767 function Find_Dispatching_Type
(Subp
: Entity_Id
) return Entity_Id
is
1768 A_Formal
: Entity_Id
;
1770 Ctrl_Type
: Entity_Id
;
1773 if Ekind_In
(Subp
, E_Function
, E_Procedure
)
1774 and then Present
(DTC_Entity
(Subp
))
1776 return Scope
(DTC_Entity
(Subp
));
1778 -- For subprograms internally generated by derivations of tagged types
1779 -- use the alias subprogram as a reference to locate the dispatching
1782 elsif not Comes_From_Source
(Subp
)
1783 and then Present
(Alias
(Subp
))
1784 and then Is_Dispatching_Operation
(Alias
(Subp
))
1786 if Ekind
(Alias
(Subp
)) = E_Function
1787 and then Has_Controlling_Result
(Alias
(Subp
))
1789 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
1792 Formal
:= First_Formal
(Subp
);
1793 A_Formal
:= First_Formal
(Alias
(Subp
));
1794 while Present
(A_Formal
) loop
1795 if Is_Controlling_Formal
(A_Formal
) then
1796 return Check_Controlling_Type
(Etype
(Formal
), Subp
);
1799 Next_Formal
(Formal
);
1800 Next_Formal
(A_Formal
);
1803 pragma Assert
(False);
1810 Formal
:= First_Formal
(Subp
);
1811 while Present
(Formal
) loop
1812 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
1814 if Present
(Ctrl_Type
) then
1818 Next_Formal
(Formal
);
1821 -- The subprogram may also be dispatching on result
1823 if Present
(Etype
(Subp
)) then
1824 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
1828 pragma Assert
(not Is_Dispatching_Operation
(Subp
));
1830 end Find_Dispatching_Type
;
1832 --------------------------------------
1833 -- Find_Hidden_Overridden_Primitive --
1834 --------------------------------------
1836 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
1838 Tag_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
1840 Orig_Prim
: Entity_Id
;
1842 Vis_List
: Elist_Id
;
1845 -- This Ada 2012 rule is valid only for type extensions or private
1849 or else not Is_Record_Type
(Tag_Typ
)
1850 or else Etype
(Tag_Typ
) = Tag_Typ
1855 -- Collect the list of visible ancestor of the tagged type
1857 Vis_List
:= Visible_Ancestors
(Tag_Typ
);
1859 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
1860 while Present
(Elmt
) loop
1861 Prim
:= Node
(Elmt
);
1863 -- Find an inherited hidden dispatching primitive with the name of S
1864 -- and a type-conformant profile.
1866 if Present
(Alias
(Prim
))
1867 and then Is_Hidden
(Alias
(Prim
))
1868 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Tag_Typ
1869 and then Primitive_Names_Match
(S
, Prim
)
1870 and then Type_Conformant
(S
, Prim
)
1873 Vis_Ancestor
: Elmt_Id
;
1877 -- The original corresponding operation of Prim must be an
1878 -- operation of a visible ancestor of the dispatching type S,
1879 -- and the original corresponding operation of S2 must be
1882 Orig_Prim
:= Original_Corresponding_Operation
(Prim
);
1884 if Orig_Prim
/= Prim
1885 and then Is_Immediately_Visible
(Orig_Prim
)
1887 Vis_Ancestor
:= First_Elmt
(Vis_List
);
1888 while Present
(Vis_Ancestor
) loop
1890 First_Elmt
(Primitive_Operations
(Node
(Vis_Ancestor
)));
1891 while Present
(Elmt
) loop
1892 if Node
(Elmt
) = Orig_Prim
then
1893 Set_Overridden_Operation
(S
, Prim
);
1894 Set_Alias
(Prim
, Orig_Prim
);
1901 Next_Elmt
(Vis_Ancestor
);
1911 end Find_Hidden_Overridden_Primitive
;
1913 ---------------------------------------
1914 -- Find_Primitive_Covering_Interface --
1915 ---------------------------------------
1917 function Find_Primitive_Covering_Interface
1918 (Tagged_Type
: Entity_Id
;
1919 Iface_Prim
: Entity_Id
) return Entity_Id
1925 pragma Assert
(Is_Interface
(Find_Dispatching_Type
(Iface_Prim
))
1926 or else (Present
(Alias
(Iface_Prim
))
1929 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
1931 -- Search in the homonym chain. Done to speed up locating visible
1932 -- entities and required to catch primitives associated with the partial
1933 -- view of private types when processing the corresponding full view.
1935 E
:= Current_Entity
(Iface_Prim
);
1936 while Present
(E
) loop
1937 if Is_Subprogram
(E
)
1938 and then Is_Dispatching_Operation
(E
)
1939 and then Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
)
1947 -- Search in the list of primitives of the type. Required to locate
1948 -- the covering primitive if the covering primitive is not visible
1949 -- (for example, non-visible inherited primitive of private type).
1951 El
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1952 while Present
(El
) loop
1955 -- Keep separate the management of internal entities that link
1956 -- primitives with interface primitives from tagged type primitives.
1958 if No
(Interface_Alias
(E
)) then
1959 if Present
(Alias
(E
)) then
1961 -- This interface primitive has not been covered yet
1963 if Alias
(E
) = Iface_Prim
then
1966 -- The covering primitive was inherited
1968 elsif Overridden_Operation
(Ultimate_Alias
(E
))
1975 -- Check if E covers the interface primitive (includes case in
1976 -- which E is an inherited private primitive).
1978 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
1982 -- Use the internal entity that links the interface primitive with
1983 -- the covering primitive to locate the entity.
1985 elsif Interface_Alias
(E
) = Iface_Prim
then
1995 end Find_Primitive_Covering_Interface
;
1997 ---------------------------
1998 -- Inherited_Subprograms --
1999 ---------------------------
2001 function Inherited_Subprograms
(S
: Entity_Id
) return Subprogram_List
is
2002 Result
: Subprogram_List
(1 .. 6000);
2003 -- 6000 here is intended to be infinity. We could use an expandable
2004 -- table, but it would be awfully heavy, and there is no way that we
2005 -- could reasonably exceed this value.
2008 -- Number of entries in Result
2010 Parent_Op
: Entity_Id
;
2011 -- Traverses the Overridden_Operation chain
2013 procedure Store_IS
(E
: Entity_Id
);
2014 -- Stores E in Result if not already stored
2020 procedure Store_IS
(E
: Entity_Id
) is
2022 for J
in 1 .. N
loop
2023 if E
= Result
(J
) then
2032 -- Start of processing for Inherited_Subprograms
2035 if Present
(S
) and then Is_Dispatching_Operation
(S
) then
2037 -- Deal with direct inheritance
2041 Parent_Op
:= Overridden_Operation
(Parent_Op
);
2042 exit when No
(Parent_Op
);
2044 if Is_Subprogram
(Parent_Op
)
2045 or else Is_Generic_Subprogram
(Parent_Op
)
2047 Store_IS
(Parent_Op
);
2051 -- Now deal with interfaces
2054 Tag_Typ
: Entity_Id
;
2059 Tag_Typ
:= Find_Dispatching_Type
(S
);
2061 if Is_Concurrent_Type
(Tag_Typ
) then
2062 Tag_Typ
:= Corresponding_Record_Type
(Tag_Typ
);
2065 -- Search primitive operations of dispatching type
2067 if Present
(Tag_Typ
)
2068 and then Present
(Primitive_Operations
(Tag_Typ
))
2070 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2071 while Present
(Elmt
) loop
2072 Prim
:= Node
(Elmt
);
2074 -- The following test eliminates some odd cases in which
2075 -- Ekind (Prim) is Void, to be investigated further ???
2077 if not (Is_Subprogram
(Prim
)
2079 Is_Generic_Subprogram
(Prim
))
2083 -- For [generic] subprogram, look at interface alias
2085 elsif Present
(Interface_Alias
(Prim
))
2086 and then Alias
(Prim
) = S
2088 -- We have found a primitive covered by S
2090 Store_IS
(Interface_Alias
(Prim
));
2099 return Result
(1 .. N
);
2100 end Inherited_Subprograms
;
2102 ---------------------------
2103 -- Is_Dynamically_Tagged --
2104 ---------------------------
2106 function Is_Dynamically_Tagged
(N
: Node_Id
) return Boolean is
2108 if Nkind
(N
) = N_Error
then
2111 return Find_Controlling_Arg
(N
) /= Empty
;
2113 end Is_Dynamically_Tagged
;
2115 ---------------------------------
2116 -- Is_Null_Interface_Primitive --
2117 ---------------------------------
2119 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2121 return Comes_From_Source
(E
)
2122 and then Is_Dispatching_Operation
(E
)
2123 and then Ekind
(E
) = E_Procedure
2124 and then Null_Present
(Parent
(E
))
2125 and then Is_Interface
(Find_Dispatching_Type
(E
));
2126 end Is_Null_Interface_Primitive
;
2128 --------------------------
2129 -- Is_Tag_Indeterminate --
2130 --------------------------
2132 function Is_Tag_Indeterminate
(N
: Node_Id
) return Boolean is
2135 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2138 if Nkind
(Orig_Node
) = N_Function_Call
2139 and then Is_Entity_Name
(Name
(Orig_Node
))
2141 Nam
:= Entity
(Name
(Orig_Node
));
2143 if not Has_Controlling_Result
(Nam
) then
2146 -- The function may have a controlling result, but if the return type
2147 -- is not visibly tagged, then this is not tag-indeterminate.
2149 elsif Is_Access_Type
(Etype
(Nam
))
2150 and then not Is_Tagged_Type
(Designated_Type
(Etype
(Nam
)))
2154 -- An explicit dereference means that the call has already been
2155 -- expanded and there is no tag to propagate.
2157 elsif Nkind
(N
) = N_Explicit_Dereference
then
2160 -- If there are no actuals, the call is tag-indeterminate
2162 elsif No
(Parameter_Associations
(Orig_Node
)) then
2166 Actual
:= First_Actual
(Orig_Node
);
2167 while Present
(Actual
) loop
2168 if Is_Controlling_Actual
(Actual
)
2169 and then not Is_Tag_Indeterminate
(Actual
)
2171 -- One operand is dispatching
2176 Next_Actual
(Actual
);
2182 elsif Nkind
(Orig_Node
) = N_Qualified_Expression
then
2183 return Is_Tag_Indeterminate
(Expression
(Orig_Node
));
2185 -- Case of a call to the Input attribute (possibly rewritten), which is
2186 -- always tag-indeterminate except when its prefix is a Class attribute.
2188 elsif Nkind
(Orig_Node
) = N_Attribute_Reference
2190 Get_Attribute_Id
(Attribute_Name
(Orig_Node
)) = Attribute_Input
2192 Nkind
(Prefix
(Orig_Node
)) /= N_Attribute_Reference
2196 -- In Ada 2005, a function that returns an anonymous access type can be
2197 -- dispatching, and the dereference of a call to such a function can
2198 -- also be tag-indeterminate if the call itself is.
2200 elsif Nkind
(Orig_Node
) = N_Explicit_Dereference
2201 and then Ada_Version
>= Ada_2005
2203 return Is_Tag_Indeterminate
(Prefix
(Orig_Node
));
2208 end Is_Tag_Indeterminate
;
2210 ------------------------------------
2211 -- Override_Dispatching_Operation --
2212 ------------------------------------
2214 procedure Override_Dispatching_Operation
2215 (Tagged_Type
: Entity_Id
;
2216 Prev_Op
: Entity_Id
;
2218 Is_Wrapper
: Boolean := False)
2224 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
2225 -- we do it unconditionally in Ada 95 now, since this is our pragma!)
2227 if No_Return
(Prev_Op
) and then not No_Return
(New_Op
) then
2228 Error_Msg_N
("procedure & must have No_Return pragma", New_Op
);
2229 Error_Msg_N
("\since overridden procedure has No_Return", New_Op
);
2232 -- If there is no previous operation to override, the type declaration
2233 -- was malformed, and an error must have been emitted already.
2235 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2236 while Present
(Elmt
)
2237 and then Node
(Elmt
) /= Prev_Op
2246 -- The location of entities that come from source in the list of
2247 -- primitives of the tagged type must follow their order of occurrence
2248 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
2249 -- primitive of an interface that is not implemented by the parents of
2250 -- this tagged type (that is, it is an alias of an interface primitive
2251 -- generated by Derive_Interface_Progenitors), then we must append the
2252 -- new entity at the end of the list of primitives.
2254 if Present
(Alias
(Prev_Op
))
2255 and then Etype
(Tagged_Type
) /= Tagged_Type
2256 and then Is_Interface
(Find_Dispatching_Type
(Alias
(Prev_Op
)))
2257 and then not Is_Ancestor
(Find_Dispatching_Type
(Alias
(Prev_Op
)),
2258 Tagged_Type
, Use_Full_View
=> True)
2259 and then not Implements_Interface
2260 (Etype
(Tagged_Type
),
2261 Find_Dispatching_Type
(Alias
(Prev_Op
)))
2263 Remove_Elmt
(Primitive_Operations
(Tagged_Type
), Elmt
);
2264 Append_Elmt
(New_Op
, Primitive_Operations
(Tagged_Type
));
2266 -- The new primitive replaces the overridden entity. Required to ensure
2267 -- that overriding primitive is assigned the same dispatch table slot.
2270 Replace_Elmt
(Elmt
, New_Op
);
2273 if Ada_Version
>= Ada_2005
2274 and then Has_Interfaces
(Tagged_Type
)
2276 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
2277 -- entities of the overridden primitive to reference New_Op, and
2278 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
2279 -- that the new operation is subtype conformant with the interface
2280 -- operations that it implements (for operations inherited from the
2281 -- parent itself, this check is made when building the derived type).
2283 -- Note: This code is executed with internally generated wrappers of
2284 -- functions with controlling result and late overridings.
2286 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2287 while Present
(Elmt
) loop
2288 Prim
:= Node
(Elmt
);
2290 if Prim
= New_Op
then
2293 -- Note: The check on Is_Subprogram protects the frontend against
2294 -- reading attributes in entities that are not yet fully decorated
2296 elsif Is_Subprogram
(Prim
)
2297 and then Present
(Interface_Alias
(Prim
))
2298 and then Alias
(Prim
) = Prev_Op
2300 Set_Alias
(Prim
, New_Op
);
2302 -- No further decoration needed yet for internally generated
2303 -- wrappers of controlling functions since (at this stage)
2304 -- they are not yet decorated.
2306 if not Is_Wrapper
then
2307 Check_Subtype_Conformant
(New_Op
, Prim
);
2309 Set_Is_Abstract_Subprogram
(Prim
,
2310 Is_Abstract_Subprogram
(New_Op
));
2312 -- Ensure that this entity will be expanded to fill the
2313 -- corresponding entry in its dispatch table.
2315 if not Is_Abstract_Subprogram
(Prim
) then
2316 Set_Has_Delayed_Freeze
(Prim
);
2325 if (not Is_Package_Or_Generic_Package
(Current_Scope
))
2326 or else not In_Private_Part
(Current_Scope
)
2328 -- Not a private primitive
2332 else pragma Assert
(Is_Inherited_Operation
(Prev_Op
));
2334 -- Make the overriding operation into an alias of the implicit one.
2335 -- In this fashion a call from outside ends up calling the new body
2336 -- even if non-dispatching, and a call from inside calls the over-
2337 -- riding operation because it hides the implicit one. To indicate
2338 -- that the body of Prev_Op is never called, set its dispatch table
2339 -- entity to Empty. If the overridden operation has a dispatching
2340 -- result, so does the overriding one.
2342 Set_Alias
(Prev_Op
, New_Op
);
2343 Set_DTC_Entity
(Prev_Op
, Empty
);
2344 Set_Has_Controlling_Result
(New_Op
, Has_Controlling_Result
(Prev_Op
));
2347 end Override_Dispatching_Operation
;
2353 procedure Propagate_Tag
(Control
: Node_Id
; Actual
: Node_Id
) is
2354 Call_Node
: Node_Id
;
2358 if Nkind
(Actual
) = N_Function_Call
then
2359 Call_Node
:= Actual
;
2361 elsif Nkind
(Actual
) = N_Identifier
2362 and then Nkind
(Original_Node
(Actual
)) = N_Function_Call
2364 -- Call rewritten as object declaration when stack-checking is
2365 -- enabled. Propagate tag to expression in declaration, which is
2368 Call_Node
:= Expression
(Parent
(Entity
(Actual
)));
2370 -- Ada 2005: If this is a dereference of a call to a function with a
2371 -- dispatching access-result, the tag is propagated when the dereference
2372 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
2374 elsif Nkind
(Actual
) = N_Explicit_Dereference
2375 and then Nkind
(Original_Node
(Prefix
(Actual
))) = N_Function_Call
2379 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
2380 -- and in that case we can simply return.
2382 elsif Nkind
(Actual
) = N_Attribute_Reference
then
2383 pragma Assert
(Attribute_Name
(Actual
) = Name_Input
);
2387 -- Only other possibilities are parenthesized or qualified expression,
2388 -- or an expander-generated unchecked conversion of a function call to
2389 -- a stream Input attribute.
2392 Call_Node
:= Expression
(Actual
);
2395 -- No action needed if the call has been already expanded
2397 if Is_Expanded_Dispatching_Call
(Call_Node
) then
2401 -- Do not set the Controlling_Argument if already set. This happens in
2402 -- the special case of _Input (see Exp_Attr, case Input).
2404 if No
(Controlling_Argument
(Call_Node
)) then
2405 Set_Controlling_Argument
(Call_Node
, Control
);
2408 Arg
:= First_Actual
(Call_Node
);
2409 while Present
(Arg
) loop
2410 if Is_Tag_Indeterminate
(Arg
) then
2411 Propagate_Tag
(Control
, Arg
);
2417 -- Expansion of dispatching calls is suppressed when VM_Target, because
2418 -- the VM back-ends directly handle the generation of dispatching calls
2419 -- and would have to undo any expansion to an indirect call.
2421 if Tagged_Type_Expansion
then
2423 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
2426 Expand_Dispatching_Call
(Call_Node
);
2428 -- If the controlling argument is an interface type and the type
2429 -- of Call_Node differs then we must add an implicit conversion to
2430 -- force displacement of the pointer to the object to reference
2431 -- the secondary dispatch table of the interface.
2433 if Is_Interface
(Etype
(Control
))
2434 and then Etype
(Control
) /= Call_Typ
2436 -- Cannot use Convert_To because the previous call to
2437 -- Expand_Dispatching_Call leaves decorated the Call_Node
2438 -- with the type of Control.
2441 Make_Type_Conversion
(Sloc
(Call_Node
),
2443 New_Occurrence_Of
(Etype
(Control
), Sloc
(Call_Node
)),
2444 Expression
=> Relocate_Node
(Call_Node
)));
2445 Set_Etype
(Call_Node
, Etype
(Control
));
2446 Set_Analyzed
(Call_Node
);
2448 Expand_Interface_Conversion
(Call_Node
, Is_Static
=> False);
2452 -- Expansion of a dispatching call results in an indirect call, which in
2453 -- turn causes current values to be killed (see Resolve_Call), so on VM
2454 -- targets we do the call here to ensure consistent warnings between VM
2455 -- and non-VM targets.
2458 Kill_Current_Values
;