1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Ch8
; use Sem_Ch8
;
48 with Sem_Eval
; use Sem_Eval
;
49 with Sem_Type
; use Sem_Type
;
50 with Sem_Util
; use Sem_Util
;
51 with Snames
; use Snames
;
52 with Sinfo
; use Sinfo
;
53 with Tbuild
; use Tbuild
;
54 with Uintp
; use Uintp
;
55 with Warnsw
; use Warnsw
;
57 package body Sem_Disp
is
59 -----------------------
60 -- Local Subprograms --
61 -----------------------
63 procedure Add_Dispatching_Operation
64 (Tagged_Type
: Entity_Id
;
66 -- Add New_Op in the list of primitive operations of Tagged_Type
68 function Check_Controlling_Type
70 Subp
: Entity_Id
) return Entity_Id
;
71 -- T is the tagged type of a formal parameter or the result of Subp.
72 -- If the subprogram has a controlling parameter or result that matches
73 -- the type, then returns the tagged type of that parameter or result
74 -- (returning the designated tagged type in the case of an access
75 -- parameter); otherwise returns empty.
77 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
;
78 -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
79 -- type of S that has the same name of S, a type-conformant profile, an
80 -- original corresponding operation O that is a primitive of a visible
81 -- ancestor of the dispatching type of S and O is visible at the point of
82 -- of declaration of S. If the entity is found the Alias of S is set to the
83 -- original corresponding operation S and its Overridden_Operation is set
84 -- to the found entity; otherwise return Empty.
86 -- This routine does not search for non-hidden primitives since they are
87 -- covered by the normal Ada 2005 rules.
89 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean;
90 -- Check whether a primitive operation is inherited from an operation
91 -- declared in the visible part of its package.
93 -------------------------------
94 -- Add_Dispatching_Operation --
95 -------------------------------
97 procedure Add_Dispatching_Operation
98 (Tagged_Type
: Entity_Id
;
101 List
: constant Elist_Id
:= Primitive_Operations
(Tagged_Type
);
104 -- The dispatching operation may already be on the list, if it is the
105 -- wrapper for an inherited function of a null extension (see Exp_Ch3
106 -- for the construction of function wrappers). The list of primitive
107 -- operations must not contain duplicates.
109 Append_Unique_Elmt
(New_Op
, List
);
110 end Add_Dispatching_Operation
;
112 --------------------------
113 -- Covered_Interface_Op --
114 --------------------------
116 function Covered_Interface_Op
(Prim
: Entity_Id
) return Entity_Id
is
117 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
122 pragma Assert
(Is_Dispatching_Operation
(Prim
));
124 -- Although this is a dispatching primitive we must check if its
125 -- dispatching type is available because it may be the primitive
126 -- of a private type not defined as tagged in its partial view.
128 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
130 -- If the tagged type is frozen then the internal entities associated
131 -- with interfaces are available in the list of primitives of the
132 -- tagged type and can be used to speed up this search.
134 if Is_Frozen
(Tagged_Type
) then
135 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
136 while Present
(Elmt
) loop
139 if Present
(Interface_Alias
(E
))
140 and then Alias
(E
) = Prim
142 return Interface_Alias
(E
);
148 -- Otherwise we must collect all the interface primitives and check
149 -- if the Prim overrides (implements) some interface primitive.
153 Ifaces_List
: Elist_Id
;
154 Iface_Elmt
: Elmt_Id
;
156 Iface_Prim
: Entity_Id
;
159 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
160 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
161 while Present
(Iface_Elmt
) loop
162 Iface
:= Node
(Iface_Elmt
);
164 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
165 while Present
(Elmt
) loop
166 Iface_Prim
:= Node
(Elmt
);
168 if Chars
(Iface_Prim
) = Chars
(Prim
)
169 and then Is_Interface_Conformant
170 (Tagged_Type
, Iface_Prim
, Prim
)
178 Next_Elmt
(Iface_Elmt
);
185 end Covered_Interface_Op
;
187 -------------------------------
188 -- Check_Controlling_Formals --
189 -------------------------------
191 procedure Check_Controlling_Formals
196 Ctrl_Type
: Entity_Id
;
199 Formal
:= First_Formal
(Subp
);
200 while Present
(Formal
) loop
201 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
203 if Present
(Ctrl_Type
) then
205 -- When controlling type is concurrent and declared within a
206 -- generic or inside an instance use corresponding record type.
208 if Is_Concurrent_Type
(Ctrl_Type
)
209 and then Present
(Corresponding_Record_Type
(Ctrl_Type
))
211 Ctrl_Type
:= Corresponding_Record_Type
(Ctrl_Type
);
214 if Ctrl_Type
= Typ
then
215 Set_Is_Controlling_Formal
(Formal
);
217 -- Ada 2005 (AI-231): Anonymous access types that are used in
218 -- controlling parameters exclude null because it is necessary
219 -- to read the tag to dispatch, and null has no tag.
221 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
222 Set_Can_Never_Be_Null
(Etype
(Formal
));
223 Set_Is_Known_Non_Null
(Etype
(Formal
));
226 -- Check that the parameter's nominal subtype statically
227 -- matches the first subtype.
229 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
230 if not Subtypes_Statically_Match
231 (Typ
, Designated_Type
(Etype
(Formal
)))
234 ("parameter subtype does not match controlling type",
238 -- Within a predicate function, the formal may be a subtype
239 -- of a tagged type, given that the predicate is expressed
240 -- in terms of the subtype.
242 elsif not Subtypes_Statically_Match
(Typ
, Etype
(Formal
))
243 and then not Is_Predicate_Function
(Subp
)
246 ("parameter subtype does not match controlling type",
250 if Present
(Default_Value
(Formal
)) then
252 -- In Ada 2005, access parameters can have defaults
254 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
255 and then Ada_Version
< Ada_2005
258 ("default not allowed for controlling access parameter",
259 Default_Value
(Formal
));
261 elsif not Is_Tag_Indeterminate
(Default_Value
(Formal
)) then
263 ("default expression must be a tag indeterminate" &
264 " function call", Default_Value
(Formal
));
268 elsif Comes_From_Source
(Subp
) then
270 ("operation can be dispatching in only one type", Subp
);
274 Next_Formal
(Formal
);
277 if Ekind_In
(Subp
, E_Function
, E_Generic_Function
) then
278 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Subp
), Subp
);
280 if Present
(Ctrl_Type
) then
281 if Ctrl_Type
= Typ
then
282 Set_Has_Controlling_Result
(Subp
);
284 -- Check that result subtype statically matches first subtype
285 -- (Ada 2005): Subp may have a controlling access result.
287 if Subtypes_Statically_Match
(Typ
, Etype
(Subp
))
288 or else (Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
290 Subtypes_Statically_Match
291 (Typ
, Designated_Type
(Etype
(Subp
))))
297 ("result subtype does not match controlling type", Subp
);
300 elsif Comes_From_Source
(Subp
) then
302 ("operation can be dispatching in only one type", Subp
);
306 end Check_Controlling_Formals
;
308 ----------------------------
309 -- Check_Controlling_Type --
310 ----------------------------
312 function Check_Controlling_Type
314 Subp
: Entity_Id
) return Entity_Id
316 Tagged_Type
: Entity_Id
:= Empty
;
319 if Is_Tagged_Type
(T
) then
320 if Is_First_Subtype
(T
) then
323 Tagged_Type
:= Base_Type
(T
);
326 -- If the type is incomplete, it may have been declared without a
327 -- Tagged indication, but the full view may be tagged, in which case
328 -- that is the controlling type of the subprogram. This is one of the
329 -- approx. 579 places in the language where a lookahead would help.
331 elsif Ekind
(T
) = E_Incomplete_Type
332 and then Present
(Full_View
(T
))
333 and then Is_Tagged_Type
(Full_View
(T
))
335 Set_Is_Tagged_Type
(T
);
336 Tagged_Type
:= Full_View
(T
);
338 elsif Ekind
(T
) = E_Anonymous_Access_Type
339 and then Is_Tagged_Type
(Designated_Type
(T
))
341 if Ekind
(Designated_Type
(T
)) /= E_Incomplete_Type
then
342 if Is_First_Subtype
(Designated_Type
(T
)) then
343 Tagged_Type
:= Designated_Type
(T
);
345 Tagged_Type
:= Base_Type
(Designated_Type
(T
));
348 -- Ada 2005: an incomplete type can be tagged. An operation with an
349 -- access parameter of the type is dispatching.
351 elsif Scope
(Designated_Type
(T
)) = Current_Scope
then
352 Tagged_Type
:= Designated_Type
(T
);
354 -- Ada 2005 (AI-50217)
356 elsif From_Limited_With
(Designated_Type
(T
))
357 and then Has_Non_Limited_View
(Designated_Type
(T
))
358 and then Scope
(Designated_Type
(T
)) = Scope
(Subp
)
360 if Is_First_Subtype
(Non_Limited_View
(Designated_Type
(T
))) then
361 Tagged_Type
:= Non_Limited_View
(Designated_Type
(T
));
363 Tagged_Type
:= Base_Type
(Non_Limited_View
364 (Designated_Type
(T
)));
369 if No
(Tagged_Type
) or else Is_Class_Wide_Type
(Tagged_Type
) then
372 -- The dispatching type and the primitive operation must be defined in
373 -- the same scope, except in the case of internal operations and formal
374 -- abstract subprograms.
376 elsif ((Scope
(Subp
) = Scope
(Tagged_Type
) or else Is_Internal
(Subp
))
377 and then (not Is_Generic_Type
(Tagged_Type
)
378 or else not Comes_From_Source
(Subp
)))
380 (Is_Formal_Subprogram
(Subp
) and then Is_Abstract_Subprogram
(Subp
))
382 (Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Renaming_Declaration
384 Present
(Corresponding_Formal_Spec
(Parent
(Parent
(Subp
))))
386 Is_Abstract_Subprogram
(Subp
))
393 end Check_Controlling_Type
;
395 ----------------------------
396 -- Check_Dispatching_Call --
397 ----------------------------
399 procedure Check_Dispatching_Call
(N
: Node_Id
) is
400 Loc
: constant Source_Ptr
:= Sloc
(N
);
403 Control
: Node_Id
:= Empty
;
405 Subp_Entity
: Entity_Id
;
406 Indeterm_Ancestor_Call
: Boolean := False;
407 Indeterm_Ctrl_Type
: Entity_Id
;
409 Static_Tag
: Node_Id
:= Empty
;
410 -- If a controlling formal has a statically tagged actual, the tag of
411 -- this actual is to be used for any tag-indeterminate actual.
413 procedure Check_Direct_Call
;
414 -- In the case when the controlling actual is a class-wide type whose
415 -- root type's completion is a task or protected type, the call is in
416 -- fact direct. This routine detects the above case and modifies the
419 procedure Check_Dispatching_Context
(Call
: Node_Id
);
420 -- If the call is tag-indeterminate and the entity being called is
421 -- abstract, verify that the context is a call that will eventually
422 -- provide a tag for dispatching, or has provided one already.
424 -----------------------
425 -- Check_Direct_Call --
426 -----------------------
428 procedure Check_Direct_Call
is
429 Typ
: Entity_Id
:= Etype
(Control
);
431 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean;
432 -- Determine whether an entity denotes a user-defined equality
434 ------------------------------
435 -- Is_User_Defined_Equality --
436 ------------------------------
438 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
441 Ekind
(Id
) = E_Function
442 and then Chars
(Id
) = Name_Op_Eq
443 and then Comes_From_Source
(Id
)
445 -- Internally generated equalities have a full type declaration
448 and then Nkind
(Parent
(Id
)) = N_Function_Specification
;
449 end Is_User_Defined_Equality
;
451 -- Start of processing for Check_Direct_Call
454 -- Predefined primitives do not receive wrappers since they are built
455 -- from scratch for the corresponding record of synchronized types.
456 -- Equality is in general predefined, but is excluded from the check
457 -- when it is user-defined.
459 if Is_Predefined_Dispatching_Operation
(Subp_Entity
)
460 and then not Is_User_Defined_Equality
(Subp_Entity
)
465 if Is_Class_Wide_Type
(Typ
) then
466 Typ
:= Root_Type
(Typ
);
469 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
470 Typ
:= Full_View
(Typ
);
473 if Is_Concurrent_Type
(Typ
)
475 Present
(Corresponding_Record_Type
(Typ
))
477 Typ
:= Corresponding_Record_Type
(Typ
);
479 -- The concurrent record's list of primitives should contain a
480 -- wrapper for the entity of the call, retrieve it.
485 Wrapper_Found
: Boolean := False;
488 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
489 while Present
(Prim_Elmt
) loop
490 Prim
:= Node
(Prim_Elmt
);
492 if Is_Primitive_Wrapper
(Prim
)
493 and then Wrapped_Entity
(Prim
) = Subp_Entity
495 Wrapper_Found
:= True;
499 Next_Elmt
(Prim_Elmt
);
502 -- A primitive declared between two views should have a
503 -- corresponding wrapper.
505 pragma Assert
(Wrapper_Found
);
507 -- Modify the call by setting the proper entity
509 Set_Entity
(Name
(N
), Prim
);
512 end Check_Direct_Call
;
514 -------------------------------
515 -- Check_Dispatching_Context --
516 -------------------------------
518 procedure Check_Dispatching_Context
(Call
: Node_Id
) is
519 Subp
: constant Entity_Id
:= Entity
(Name
(Call
));
521 procedure Abstract_Context_Error
;
522 -- Error for abstract call dispatching on result is not dispatching
524 ----------------------------
525 -- Abstract_Context_Error --
526 ----------------------------
528 procedure Abstract_Context_Error
is
530 if Ekind
(Subp
) = E_Function
then
532 ("call to abstract function must be dispatching", N
);
534 -- This error can occur for a procedure in the case of a call to
535 -- an abstract formal procedure with a statically tagged operand.
539 ("call to abstract procedure must be dispatching", N
);
541 end Abstract_Context_Error
;
545 Scop
: constant Entity_Id
:= Current_Scope_No_Loops
;
546 Typ
: constant Entity_Id
:= Etype
(Subp
);
549 -- Start of processing for Check_Dispatching_Context
552 -- If the called subprogram is a private overriding, replace it
553 -- with its alias, which has the correct body. Verify that the
554 -- two subprograms have the same controlling type (this is not the
555 -- case for an inherited subprogram that has become abstract).
557 if Is_Abstract_Subprogram
(Subp
)
558 and then No
(Controlling_Argument
(Call
))
560 if Present
(Alias
(Subp
))
561 and then not Is_Abstract_Subprogram
(Alias
(Subp
))
562 and then No
(DTC_Entity
(Subp
))
563 and then Find_Dispatching_Type
(Subp
) =
564 Find_Dispatching_Type
(Alias
(Subp
))
566 -- Private overriding of inherited abstract operation, call is
569 Set_Entity
(Name
(N
), Alias
(Subp
));
572 -- An obscure special case: a null procedure may have a class-
573 -- wide pre/postcondition that includes a call to an abstract
574 -- subp. Calls within the expression may not have been rewritten
575 -- as dispatching calls yet, because the null body appears in
576 -- the current declarative part. The expression will be properly
577 -- rewritten/reanalyzed when the postcondition procedure is built.
579 -- Similarly, if this is a pre/postcondition for an abstract
580 -- subprogram, it may call another abstract function which is
581 -- a primitive of an abstract type. The call is non-dispatching
582 -- but will be legal in overridings of the operation.
584 elsif (Is_Subprogram
(Scop
)
585 or else Chars
(Scop
) = Name_Postcondition
)
587 (Is_Abstract_Subprogram
(Scop
)
589 (Nkind
(Parent
(Scop
)) = N_Procedure_Specification
590 and then Null_Present
(Parent
(Scop
))))
594 elsif Ekind
(Current_Scope
) = E_Function
595 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
596 N_Generic_Subprogram_Declaration
601 -- We need to determine whether the context of the call
602 -- provides a tag to make the call dispatching. This requires
603 -- the call to be the actual in an enclosing call, and that
604 -- actual must be controlling. If the call is an operand of
605 -- equality, the other operand must not ve abstract.
607 if not Is_Tagged_Type
(Typ
)
609 (Ekind
(Typ
) = E_Anonymous_Access_Type
610 and then Is_Tagged_Type
(Designated_Type
(Typ
)))
612 Abstract_Context_Error
;
616 Par
:= Parent
(Call
);
618 if Nkind
(Par
) = N_Parameter_Association
then
622 if Nkind
(Par
) = N_Qualified_Expression
623 or else Nkind
(Par
) = N_Unchecked_Type_Conversion
628 if Nkind_In
(Par
, N_Function_Call
, N_Procedure_Call_Statement
)
629 and then Is_Entity_Name
(Name
(Par
))
632 Enc_Subp
: constant Entity_Id
:= Entity
(Name
(Par
));
636 Ret_Type
: Entity_Id
;
639 -- Find controlling formal that can provide tag for the
640 -- tag-indeterminate actual. The corresponding actual
641 -- must be the corresponding class-wide type.
643 F
:= First_Formal
(Enc_Subp
);
644 A
:= First_Actual
(Par
);
646 -- Find controlling type of call. Dereference if function
647 -- returns an access type.
649 Ret_Type
:= Etype
(Call
);
650 if Is_Access_Type
(Etype
(Call
)) then
651 Ret_Type
:= Designated_Type
(Ret_Type
);
654 while Present
(F
) loop
655 Control
:= Etype
(A
);
657 if Is_Access_Type
(Control
) then
658 Control
:= Designated_Type
(Control
);
661 if Is_Controlling_Formal
(F
)
662 and then not (Call
= A
or else Parent
(Call
) = A
)
663 and then Control
= Class_Wide_Type
(Ret_Type
)
672 if Nkind
(Par
) = N_Function_Call
673 and then Is_Tag_Indeterminate
(Par
)
675 -- The parent may be an actual of an enclosing call
677 Check_Dispatching_Context
(Par
);
682 ("call to abstract function must be dispatching",
688 -- For equality operators, one of the operands must be
689 -- statically or dynamically tagged.
691 elsif Nkind_In
(Par
, N_Op_Eq
, N_Op_Ne
) then
692 if N
= Right_Opnd
(Par
)
693 and then Is_Tag_Indeterminate
(Left_Opnd
(Par
))
695 Abstract_Context_Error
;
697 elsif N
= Left_Opnd
(Par
)
698 and then Is_Tag_Indeterminate
(Right_Opnd
(Par
))
700 Abstract_Context_Error
;
705 -- The left-hand side of an assignment provides the tag
707 elsif Nkind
(Par
) = N_Assignment_Statement
then
711 Abstract_Context_Error
;
715 end Check_Dispatching_Context
;
717 -- Start of processing for Check_Dispatching_Call
720 -- Find a controlling argument, if any
722 if Present
(Parameter_Associations
(N
)) then
723 Subp_Entity
:= Entity
(Name
(N
));
725 Actual
:= First_Actual
(N
);
726 Formal
:= First_Formal
(Subp_Entity
);
727 while Present
(Actual
) loop
728 Control
:= Find_Controlling_Arg
(Actual
);
729 exit when Present
(Control
);
731 -- Check for the case where the actual is a tag-indeterminate call
732 -- whose result type is different than the tagged type associated
733 -- with the containing call, but is an ancestor of the type.
735 if Is_Controlling_Formal
(Formal
)
736 and then Is_Tag_Indeterminate
(Actual
)
737 and then Base_Type
(Etype
(Actual
)) /= Base_Type
(Etype
(Formal
))
738 and then Is_Ancestor
(Etype
(Actual
), Etype
(Formal
))
740 Indeterm_Ancestor_Call
:= True;
741 Indeterm_Ctrl_Type
:= Etype
(Formal
);
743 -- If the formal is controlling but the actual is not, the type
744 -- of the actual is statically known, and may be used as the
745 -- controlling tag for some other tag-indeterminate actual.
747 elsif Is_Controlling_Formal
(Formal
)
748 and then Is_Entity_Name
(Actual
)
749 and then Is_Tagged_Type
(Etype
(Actual
))
751 Static_Tag
:= Actual
;
754 Next_Actual
(Actual
);
755 Next_Formal
(Formal
);
758 -- If the call doesn't have a controlling actual but does have an
759 -- indeterminate actual that requires dispatching treatment, then an
760 -- object is needed that will serve as the controlling argument for
761 -- a dispatching call on the indeterminate actual. This can occur
762 -- in the unusual situation of a default actual given by a tag-
763 -- indeterminate call and where the type of the call is an ancestor
764 -- of the type associated with a containing call to an inherited
765 -- operation (see AI-239).
767 -- Rather than create an object of the tagged type, which would
768 -- be problematic for various reasons (default initialization,
769 -- discriminants), the tag of the containing call's associated
770 -- tagged type is directly used to control the dispatching.
773 and then Indeterm_Ancestor_Call
774 and then No
(Static_Tag
)
777 Make_Attribute_Reference
(Loc
,
778 Prefix
=> New_Occurrence_Of
(Indeterm_Ctrl_Type
, Loc
),
779 Attribute_Name
=> Name_Tag
);
784 if Present
(Control
) then
786 -- Verify that no controlling arguments are statically tagged
789 Write_Str
("Found Dispatching call");
794 Actual
:= First_Actual
(N
);
795 while Present
(Actual
) loop
796 if Actual
/= Control
then
798 if not Is_Controlling_Actual
(Actual
) then
799 null; -- Can be anything
801 elsif Is_Dynamically_Tagged
(Actual
) then
802 null; -- Valid parameter
804 elsif Is_Tag_Indeterminate
(Actual
) then
806 -- The tag is inherited from the enclosing call (the node
807 -- we are currently analyzing). Explicitly expand the
808 -- actual, since the previous call to Expand (from
809 -- Resolve_Call) had no way of knowing about the
810 -- required dispatching.
812 Propagate_Tag
(Control
, Actual
);
816 ("controlling argument is not dynamically tagged",
822 Next_Actual
(Actual
);
825 -- Mark call as a dispatching call
827 Set_Controlling_Argument
(N
, Control
);
828 Check_Restriction
(No_Dispatching_Calls
, N
);
830 -- The dispatching call may need to be converted into a direct
831 -- call in certain cases.
835 -- If there is a statically tagged actual and a tag-indeterminate
836 -- call to a function of the ancestor (such as that provided by a
837 -- default), then treat this as a dispatching call and propagate
838 -- the tag to the tag-indeterminate call(s).
840 elsif Present
(Static_Tag
) and then Indeterm_Ancestor_Call
then
842 Make_Attribute_Reference
(Loc
,
844 New_Occurrence_Of
(Etype
(Static_Tag
), Loc
),
845 Attribute_Name
=> Name_Tag
);
849 Actual
:= First_Actual
(N
);
850 Formal
:= First_Formal
(Subp_Entity
);
851 while Present
(Actual
) loop
852 if Is_Tag_Indeterminate
(Actual
)
853 and then Is_Controlling_Formal
(Formal
)
855 Propagate_Tag
(Control
, Actual
);
858 Next_Actual
(Actual
);
859 Next_Formal
(Formal
);
862 Check_Dispatching_Context
(N
);
864 elsif Nkind
(N
) /= N_Function_Call
then
866 -- The call is not dispatching, so check that there aren't any
867 -- tag-indeterminate abstract calls left among its actuals.
869 Actual
:= First_Actual
(N
);
870 while Present
(Actual
) loop
871 if Is_Tag_Indeterminate
(Actual
) then
873 -- Function call case
875 if Nkind
(Original_Node
(Actual
)) = N_Function_Call
then
876 Func
:= Entity
(Name
(Original_Node
(Actual
)));
878 -- If the actual is an attribute then it can't be abstract
879 -- (the only current case of a tag-indeterminate attribute
880 -- is the stream Input attribute).
882 elsif Nkind
(Original_Node
(Actual
)) = N_Attribute_Reference
886 -- Ditto if it is an explicit dereference
888 elsif Nkind
(Original_Node
(Actual
)) = N_Explicit_Dereference
892 -- Only other possibility is a qualified expression whose
893 -- constituent expression is itself a call.
897 Entity
(Name
(Original_Node
898 (Expression
(Original_Node
(Actual
)))));
901 if Present
(Func
) and then Is_Abstract_Subprogram
(Func
) then
903 ("call to abstract function must be dispatching",
908 Next_Actual
(Actual
);
911 Check_Dispatching_Context
(N
);
914 elsif Nkind
(Parent
(N
)) in N_Subexpr
then
915 Check_Dispatching_Context
(N
);
917 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
918 and then Is_Class_Wide_Type
(Etype
(Name
(Parent
(N
))))
922 elsif Is_Abstract_Subprogram
(Subp_Entity
) then
923 Check_Dispatching_Context
(N
);
928 -- If dispatching on result, the enclosing call, if any, will
929 -- determine the controlling argument. Otherwise this is the
930 -- primitive operation of the root type.
932 Check_Dispatching_Context
(N
);
934 end Check_Dispatching_Call
;
936 ---------------------------------
937 -- Check_Dispatching_Operation --
938 ---------------------------------
940 procedure Check_Dispatching_Operation
(Subp
, Old_Subp
: Entity_Id
) is
941 procedure Warn_On_Late_Primitive_After_Private_Extension
944 -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
945 -- if it is a public primitive defined after some private extension of
948 ----------------------------------------------------
949 -- Warn_On_Late_Primitive_After_Private_Extension --
950 ----------------------------------------------------
952 procedure Warn_On_Late_Primitive_After_Private_Extension
959 if Warn_On_Late_Primitives
960 and then Comes_From_Source
(Prim
)
961 and then Has_Private_Extension
(Typ
)
962 and then Is_Package_Or_Generic_Package
(Current_Scope
)
963 and then not In_Private_Part
(Current_Scope
)
965 E
:= Next_Entity
(Typ
);
968 if Ekind
(E
) = E_Record_Type_With_Private
969 and then Etype
(E
) = Typ
971 Error_Msg_Name_1
:= Chars
(Typ
);
972 Error_Msg_Name_2
:= Chars
(E
);
973 Error_Msg_Sloc
:= Sloc
(E
);
975 ("?j?primitive of type % defined after private extension "
977 Error_Msg_Name_1
:= Chars
(Prim
);
978 Error_Msg_Name_2
:= Chars
(E
);
980 ("\spec of % should appear before declaration of type %!",
988 end Warn_On_Late_Primitive_After_Private_Extension
;
992 Body_Is_Last_Primitive
: Boolean := False;
993 Has_Dispatching_Parent
: Boolean := False;
994 Ovr_Subp
: Entity_Id
:= Empty
;
995 Tagged_Type
: Entity_Id
;
997 -- Start of processing for Check_Dispatching_Operation
1000 if not Ekind_In
(Subp
, E_Function
, E_Procedure
) then
1003 -- The Default_Initial_Condition procedure is not a primitive subprogram
1004 -- even if it relates to a tagged type. This routine is not meant to be
1005 -- inherited or overridden.
1007 elsif Is_DIC_Procedure
(Subp
) then
1010 -- The "partial" and "full" type invariant procedures are not primitive
1011 -- subprograms even if they relate to a tagged type. These routines are
1012 -- not meant to be inherited or overridden.
1014 elsif Is_Invariant_Procedure
(Subp
)
1015 or else Is_Partial_Invariant_Procedure
(Subp
)
1020 Set_Is_Dispatching_Operation
(Subp
, False);
1021 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1023 -- Ada 2005 (AI-345): Use the corresponding record (if available).
1024 -- Required because primitives of concurrent types are attached
1025 -- to the corresponding record (not to the concurrent type).
1027 if Ada_Version
>= Ada_2005
1028 and then Present
(Tagged_Type
)
1029 and then Is_Concurrent_Type
(Tagged_Type
)
1030 and then Present
(Corresponding_Record_Type
(Tagged_Type
))
1032 Tagged_Type
:= Corresponding_Record_Type
(Tagged_Type
);
1035 -- (AI-345): The task body procedure is not a primitive of the tagged
1038 if Present
(Tagged_Type
)
1039 and then Is_Concurrent_Record_Type
(Tagged_Type
)
1040 and then Present
(Corresponding_Concurrent_Type
(Tagged_Type
))
1041 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Tagged_Type
))
1042 and then Subp
= Get_Task_Body_Procedure
1043 (Corresponding_Concurrent_Type
(Tagged_Type
))
1048 -- If Subp is derived from a dispatching operation then it should
1049 -- always be treated as dispatching. In this case various checks
1050 -- below will be bypassed. Makes sure that late declarations for
1051 -- inherited private subprograms are treated as dispatching, even
1052 -- if the associated tagged type is already frozen.
1054 Has_Dispatching_Parent
:=
1055 Present
(Alias
(Subp
))
1056 and then Is_Dispatching_Operation
(Alias
(Subp
));
1058 if No
(Tagged_Type
) then
1060 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
1061 -- with an abstract interface type unless the interface acts as a
1062 -- parent type in a derivation. If the interface type is a formal
1063 -- type then the operation is not primitive and therefore legal.
1070 E
:= First_Entity
(Subp
);
1071 while Present
(E
) loop
1073 -- For an access parameter, check designated type
1075 if Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
then
1076 Typ
:= Designated_Type
(Etype
(E
));
1081 if Comes_From_Source
(Subp
)
1082 and then Is_Interface
(Typ
)
1083 and then not Is_Class_Wide_Type
(Typ
)
1084 and then not Is_Derived_Type
(Typ
)
1085 and then not Is_Generic_Type
(Typ
)
1086 and then not In_Instance
1088 Error_Msg_N
("??declaration of& is too late!", Subp
);
1089 Error_Msg_NE
-- CODEFIX??
1090 ("\??spec should appear immediately after declaration of "
1091 & "& !", Subp
, Typ
);
1098 -- In case of functions check also the result type
1100 if Ekind
(Subp
) = E_Function
then
1101 if Is_Access_Type
(Etype
(Subp
)) then
1102 Typ
:= Designated_Type
(Etype
(Subp
));
1104 Typ
:= Etype
(Subp
);
1107 -- The following should be better commented, especially since
1108 -- we just added several new conditions here ???
1110 if Comes_From_Source
(Subp
)
1111 and then Is_Interface
(Typ
)
1112 and then not Is_Class_Wide_Type
(Typ
)
1113 and then not Is_Derived_Type
(Typ
)
1114 and then not Is_Generic_Type
(Typ
)
1115 and then not In_Instance
1117 Error_Msg_N
("??declaration of& is too late!", Subp
);
1119 ("\??spec should appear immediately after declaration of "
1120 & "& !", Subp
, Typ
);
1127 -- The subprograms build internally after the freezing point (such as
1128 -- init procs, interface thunks, type support subprograms, and Offset
1129 -- to top functions for accessing interface components in variable
1130 -- size tagged types) are not primitives.
1132 elsif Is_Frozen
(Tagged_Type
)
1133 and then not Comes_From_Source
(Subp
)
1134 and then not Has_Dispatching_Parent
1136 -- Complete decoration of internally built subprograms that override
1137 -- a dispatching primitive. These entities correspond with the
1140 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
1141 -- to override functions of nonabstract null extensions. These
1142 -- primitives were added to the list of primitives of the tagged
1143 -- type by Make_Controlling_Function_Wrappers. However, attribute
1144 -- Is_Dispatching_Operation must be set to true.
1146 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
1149 -- 3. Subprograms associated with stream attributes (built by
1150 -- New_Stream_Subprogram)
1152 -- 4. Wrapper built for inherited operations with inherited class-
1153 -- wide conditions, where the conditions include calls to other
1154 -- overridden primitives. The wrappers include checks on these
1155 -- modified conditions. (AI12-113).
1157 if Present
(Old_Subp
)
1158 and then Present
(Overridden_Operation
(Subp
))
1159 and then Is_Dispatching_Operation
(Old_Subp
)
1162 ((Ekind
(Subp
) = E_Function
1163 and then Is_Dispatching_Operation
(Old_Subp
)
1164 and then Is_Null_Extension
(Base_Type
(Etype
(Subp
))))
1167 (Ekind
(Subp
) = E_Procedure
1168 and then Is_Dispatching_Operation
(Old_Subp
)
1169 and then Present
(Alias
(Old_Subp
))
1170 and then Is_Null_Interface_Primitive
1171 (Ultimate_Alias
(Old_Subp
)))
1173 or else Get_TSS_Name
(Subp
) = TSS_Stream_Read
1174 or else Get_TSS_Name
(Subp
) = TSS_Stream_Write
1176 or else Present
(Contract
(Overridden_Operation
(Subp
))));
1178 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1179 Override_Dispatching_Operation
(Tagged_Type
, Old_Subp
, Subp
);
1180 Set_Is_Dispatching_Operation
(Subp
);
1185 -- The operation may be a child unit, whose scope is the defining
1186 -- package, but which is not a primitive operation of the type.
1188 elsif Is_Child_Unit
(Subp
) then
1191 -- If the subprogram is not defined in a package spec, the only case
1192 -- where it can be a dispatching op is when it overrides an operation
1193 -- before the freezing point of the type.
1195 elsif ((not Is_Package_Or_Generic_Package
(Scope
(Subp
)))
1196 or else In_Package_Body
(Scope
(Subp
)))
1197 and then not Has_Dispatching_Parent
1199 if not Comes_From_Source
(Subp
)
1200 or else (Present
(Old_Subp
) and then not Is_Frozen
(Tagged_Type
))
1204 -- If the type is already frozen, the overriding is not allowed
1205 -- except when Old_Subp is not a dispatching operation (which can
1206 -- occur when Old_Subp was inherited by an untagged type). However,
1207 -- a body with no previous spec freezes the type *after* its
1208 -- declaration, and therefore is a legal overriding (unless the type
1209 -- has already been frozen). Only the first such body is legal.
1211 elsif Present
(Old_Subp
)
1212 and then Is_Dispatching_Operation
(Old_Subp
)
1214 if Comes_From_Source
(Subp
)
1216 (Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Body
1217 or else Nkind
(Unit_Declaration_Node
(Subp
)) in N_Body_Stub
)
1220 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1221 Decl_Item
: Node_Id
;
1224 -- ??? The checks here for whether the type has been frozen
1225 -- prior to the new body are not complete. It's not simple
1226 -- to check frozenness at this point since the body has
1227 -- already caused the type to be prematurely frozen in
1228 -- Analyze_Declarations, but we're forced to recheck this
1229 -- here because of the odd rule interpretation that allows
1230 -- the overriding if the type wasn't frozen prior to the
1231 -- body. The freezing action should probably be delayed
1232 -- until after the spec is seen, but that's a tricky
1233 -- change to the delicate freezing code.
1235 -- Look at each declaration following the type up until the
1236 -- new subprogram body. If any of the declarations is a body
1237 -- then the type has been frozen already so the overriding
1238 -- primitive is illegal.
1240 Decl_Item
:= Next
(Parent
(Tagged_Type
));
1241 while Present
(Decl_Item
)
1242 and then (Decl_Item
/= Subp_Body
)
1244 if Comes_From_Source
(Decl_Item
)
1245 and then (Nkind
(Decl_Item
) in N_Proper_Body
1246 or else Nkind
(Decl_Item
) in N_Body_Stub
)
1248 Error_Msg_N
("overriding of& is too late!", Subp
);
1250 ("\spec should appear immediately after the type!",
1258 -- If the subprogram doesn't follow in the list of
1259 -- declarations including the type then the type has
1260 -- definitely been frozen already and the body is illegal.
1262 if No
(Decl_Item
) then
1263 Error_Msg_N
("overriding of& is too late!", Subp
);
1265 ("\spec should appear immediately after the type!",
1268 elsif Is_Frozen
(Subp
) then
1270 -- The subprogram body declares a primitive operation.
1271 -- If the subprogram is already frozen, we must update
1272 -- its dispatching information explicitly here. The
1273 -- information is taken from the overridden subprogram.
1274 -- We must also generate a cross-reference entry because
1275 -- references to other primitives were already created
1276 -- when type was frozen.
1278 Body_Is_Last_Primitive
:= True;
1280 if Present
(DTC_Entity
(Old_Subp
)) then
1281 Set_DTC_Entity
(Subp
, DTC_Entity
(Old_Subp
));
1282 Set_DT_Position_Value
(Subp
, DT_Position
(Old_Subp
));
1284 if not Restriction_Active
(No_Dispatching_Calls
) then
1285 if Building_Static_DT
(Tagged_Type
) then
1287 -- If the static dispatch table has not been
1288 -- built then there is nothing else to do now;
1289 -- otherwise we notify that we cannot build the
1290 -- static dispatch table.
1292 if Has_Dispatch_Table
(Tagged_Type
) then
1294 ("overriding of& is too late for building "
1295 & " static dispatch tables!", Subp
);
1297 ("\spec should appear immediately after "
1298 & "the type!", Subp
);
1301 -- No code required to register primitives in VM
1304 elsif not Tagged_Type_Expansion
then
1308 Insert_Actions_After
(Subp_Body
,
1309 Register_Primitive
(Sloc
(Subp_Body
),
1313 -- Indicate that this is an overriding operation,
1314 -- and replace the overridden entry in the list of
1315 -- primitive operations, which is used for xref
1316 -- generation subsequently.
1318 Generate_Reference
(Tagged_Type
, Subp
, 'P', False);
1319 Override_Dispatching_Operation
1320 (Tagged_Type
, Old_Subp
, Subp
);
1327 Error_Msg_N
("overriding of& is too late!", Subp
);
1329 ("\subprogram spec should appear immediately after the type!",
1333 -- If the type is not frozen yet and we are not in the overriding
1334 -- case it looks suspiciously like an attempt to define a primitive
1335 -- operation, which requires the declaration to be in a package spec
1336 -- (3.2.3(6)). Only report cases where the type and subprogram are
1337 -- in the same declaration list (by checking the enclosing parent
1338 -- declarations), to avoid spurious warnings on subprograms in
1339 -- instance bodies when the type is declared in the instance spec
1340 -- but hasn't been frozen by the instance body.
1342 elsif not Is_Frozen
(Tagged_Type
)
1343 and then In_Same_List
(Parent
(Tagged_Type
), Parent
(Parent
(Subp
)))
1346 ("??not dispatching (must be defined in a package spec)", Subp
);
1349 -- When the type is frozen, it is legitimate to define a new
1350 -- non-primitive operation.
1356 -- Now, we are sure that the scope is a package spec. If the subprogram
1357 -- is declared after the freezing point of the type that's an error
1359 elsif Is_Frozen
(Tagged_Type
) and then not Has_Dispatching_Parent
then
1360 Error_Msg_N
("this primitive operation is declared too late", Subp
);
1362 ("??no primitive operations for& after this line",
1363 Freeze_Node
(Tagged_Type
),
1368 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1370 Ovr_Subp
:= Old_Subp
;
1372 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1373 -- overridden by Subp. This only applies to source subprograms, and
1374 -- their declaration must carry an explicit overriding indicator.
1377 and then Ada_Version
>= Ada_2012
1378 and then Comes_From_Source
(Subp
)
1380 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1382 Ovr_Subp
:= Find_Hidden_Overridden_Primitive
(Subp
);
1384 -- Verify that the proper overriding indicator has been supplied.
1386 if Present
(Ovr_Subp
)
1388 not Must_Override
(Specification
(Unit_Declaration_Node
(Subp
)))
1390 Error_Msg_NE
("missing overriding indicator for&", Subp
, Subp
);
1394 -- Now it should be a correct primitive operation, put it in the list
1396 if Present
(Ovr_Subp
) then
1398 -- If the type has interfaces we complete this check after we set
1399 -- attribute Is_Dispatching_Operation.
1401 Check_Subtype_Conformant
(Subp
, Ovr_Subp
);
1403 -- A primitive operation with the name of a primitive controlled
1404 -- operation does not override a non-visible overriding controlled
1405 -- operation, i.e. one declared in a private part when the full
1406 -- view of a type is controlled. Conversely, it will override a
1407 -- visible operation that may be declared in a partial view when
1408 -- the full view is controlled.
1410 if Nam_In
(Chars
(Subp
), Name_Initialize
, Name_Adjust
, Name_Finalize
)
1411 and then Is_Controlled
(Tagged_Type
)
1412 and then not Is_Visibly_Controlled
(Tagged_Type
)
1413 and then not Is_Inherited_Public_Operation
(Ovr_Subp
)
1415 Set_Overridden_Operation
(Subp
, Empty
);
1417 -- If the subprogram specification carries an overriding
1418 -- indicator, no need for the warning: it is either redundant,
1419 -- or else an error will be reported.
1421 if Nkind
(Parent
(Subp
)) = N_Procedure_Specification
1423 (Must_Override
(Parent
(Subp
))
1424 or else Must_Not_Override
(Parent
(Subp
)))
1428 -- Here we need the warning
1432 ("operation does not override inherited&??", Subp
, Subp
);
1436 Override_Dispatching_Operation
(Tagged_Type
, Ovr_Subp
, Subp
);
1438 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1439 -- that covers abstract interface subprograms we must register it
1440 -- in all the secondary dispatch tables associated with abstract
1441 -- interfaces. We do this now only if not building static tables,
1442 -- nor when the expander is inactive (we avoid trying to register
1443 -- primitives in semantics-only mode, since the type may not have
1444 -- an associated dispatch table). Otherwise the patch code is
1445 -- emitted after those tables are built, to prevent access before
1446 -- elaboration in gigi.
1448 if Body_Is_Last_Primitive
and then Expander_Active
then
1450 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1455 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1456 while Present
(Elmt
) loop
1457 Prim
:= Node
(Elmt
);
1459 -- No code required to register primitives in VM targets
1461 if Present
(Alias
(Prim
))
1462 and then Present
(Interface_Alias
(Prim
))
1463 and then Alias
(Prim
) = Subp
1464 and then not Building_Static_DT
(Tagged_Type
)
1465 and then Tagged_Type_Expansion
1467 Insert_Actions_After
(Subp_Body
,
1468 Register_Primitive
(Sloc
(Subp_Body
), Prim
=> Prim
));
1474 -- Redisplay the contents of the updated dispatch table
1476 if Debug_Flag_ZZ
then
1477 Write_Str
("Late overriding: ");
1478 Write_DT
(Tagged_Type
);
1484 -- If the tagged type is a concurrent type then we must be compiling
1485 -- with no code generation (we are either compiling a generic unit or
1486 -- compiling under -gnatc mode) because we have previously tested that
1487 -- no serious errors has been reported. In this case we do not add the
1488 -- primitive to the list of primitives of Tagged_Type but we leave the
1489 -- primitive decorated as a dispatching operation to be able to analyze
1490 -- and report errors associated with the Object.Operation notation.
1492 elsif Is_Concurrent_Type
(Tagged_Type
) then
1493 pragma Assert
(not Expander_Active
);
1495 -- Attach operation to list of primitives of the synchronized type
1496 -- itself, for ASIS use.
1498 Append_Elmt
(Subp
, Direct_Primitive_Operations
(Tagged_Type
));
1500 -- If no old subprogram, then we add this as a dispatching operation,
1501 -- but we avoid doing this if an error was posted, to prevent annoying
1504 elsif not Error_Posted
(Subp
) then
1505 Add_Dispatching_Operation
(Tagged_Type
, Subp
);
1508 Set_Is_Dispatching_Operation
(Subp
, True);
1510 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1511 -- subtype conformance against all the interfaces covered by this
1514 if Present
(Ovr_Subp
)
1515 and then Has_Interfaces
(Tagged_Type
)
1518 Ifaces_List
: Elist_Id
;
1519 Iface_Elmt
: Elmt_Id
;
1520 Iface_Prim_Elmt
: Elmt_Id
;
1521 Iface_Prim
: Entity_Id
;
1522 Ret_Typ
: Entity_Id
;
1525 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
1527 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1528 while Present
(Iface_Elmt
) loop
1529 if not Is_Ancestor
(Node
(Iface_Elmt
), Tagged_Type
) then
1531 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
1532 while Present
(Iface_Prim_Elmt
) loop
1533 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
1535 if Is_Interface_Conformant
1536 (Tagged_Type
, Iface_Prim
, Subp
)
1538 -- Handle procedures, functions whose return type
1539 -- matches, or functions not returning interfaces
1541 if Ekind
(Subp
) = E_Procedure
1542 or else Etype
(Iface_Prim
) = Etype
(Subp
)
1543 or else not Is_Interface
(Etype
(Iface_Prim
))
1545 Check_Subtype_Conformant
1547 Old_Id
=> Iface_Prim
,
1549 Skip_Controlling_Formals
=> True);
1551 -- Handle functions returning interfaces
1553 elsif Implements_Interface
1554 (Etype
(Subp
), Etype
(Iface_Prim
))
1556 -- Temporarily force both entities to return the
1557 -- same type. Required because Subtype_Conformant
1558 -- does not handle this case.
1560 Ret_Typ
:= Etype
(Iface_Prim
);
1561 Set_Etype
(Iface_Prim
, Etype
(Subp
));
1563 Check_Subtype_Conformant
1565 Old_Id
=> Iface_Prim
,
1567 Skip_Controlling_Formals
=> True);
1569 Set_Etype
(Iface_Prim
, Ret_Typ
);
1573 Next_Elmt
(Iface_Prim_Elmt
);
1577 Next_Elmt
(Iface_Elmt
);
1582 if not Body_Is_Last_Primitive
then
1583 Set_DT_Position_Value
(Subp
, No_Uint
);
1585 elsif Has_Controlled_Component
(Tagged_Type
)
1586 and then Nam_In
(Chars
(Subp
), Name_Initialize
,
1589 Name_Finalize_Address
)
1592 F_Node
: constant Node_Id
:= Freeze_Node
(Tagged_Type
);
1596 Old_Spec
: Entity_Id
;
1598 C_Names
: constant array (1 .. 4) of Name_Id
:=
1602 Name_Finalize_Address
);
1604 D_Names
: constant array (1 .. 4) of TSS_Name_Type
:=
1605 (TSS_Deep_Initialize
,
1608 TSS_Finalize_Address
);
1611 -- Remove previous controlled function which was constructed and
1612 -- analyzed when the type was frozen. This requires removing the
1613 -- body of the redefined primitive, as well as its specification
1614 -- if needed (there is no spec created for Deep_Initialize, see
1615 -- exp_ch3.adb). We must also dismantle the exception information
1616 -- that may have been generated for it when front end zero-cost
1617 -- tables are enabled.
1619 for J
in D_Names
'Range loop
1620 Old_P
:= TSS
(Tagged_Type
, D_Names
(J
));
1623 and then Chars
(Subp
) = C_Names
(J
)
1625 Old_Bod
:= Unit_Declaration_Node
(Old_P
);
1627 Set_Is_Eliminated
(Old_P
);
1628 Set_Scope
(Old_P
, Scope
(Current_Scope
));
1630 if Nkind
(Old_Bod
) = N_Subprogram_Body
1631 and then Present
(Corresponding_Spec
(Old_Bod
))
1633 Old_Spec
:= Corresponding_Spec
(Old_Bod
);
1634 Set_Has_Completion
(Old_Spec
, False);
1639 Build_Late_Proc
(Tagged_Type
, Chars
(Subp
));
1641 -- The new operation is added to the actions of the freeze node
1642 -- for the type, but this node has already been analyzed, so we
1643 -- must retrieve and analyze explicitly the new body.
1646 and then Present
(Actions
(F_Node
))
1648 Decl
:= Last
(Actions
(F_Node
));
1654 -- For similarity with record extensions, in Ada 9X the language should
1655 -- have disallowed adding visible operations to a tagged type after
1656 -- deriving a private extension from it. Report a warning if this
1657 -- primitive is defined after a private extension of Tagged_Type.
1659 Warn_On_Late_Primitive_After_Private_Extension
(Tagged_Type
, Subp
);
1660 end Check_Dispatching_Operation
;
1662 ------------------------------------------
1663 -- Check_Operation_From_Incomplete_Type --
1664 ------------------------------------------
1666 procedure Check_Operation_From_Incomplete_Type
1670 Full
: constant Entity_Id
:= Full_View
(Typ
);
1671 Parent_Typ
: constant Entity_Id
:= Etype
(Full
);
1672 Old_Prim
: constant Elist_Id
:= Primitive_Operations
(Parent_Typ
);
1673 New_Prim
: constant Elist_Id
:= Primitive_Operations
(Full
);
1675 Prev
: Elmt_Id
:= No_Elmt
;
1677 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean;
1678 -- Check that Subp has profile of an operation derived from Parent_Subp.
1679 -- Subp must have a parameter or result type that is Typ or an access
1680 -- parameter or access result type that designates Typ.
1686 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean is
1690 if Chars
(Parent_Subp
) /= Chars
(Subp
) then
1694 -- Check that the type of controlling formals is derived from the
1695 -- parent subprogram's controlling formal type (or designated type
1696 -- if the formal type is an anonymous access type).
1698 F1
:= First_Formal
(Parent_Subp
);
1699 F2
:= First_Formal
(Subp
);
1700 while Present
(F1
) and then Present
(F2
) loop
1701 if Ekind
(Etype
(F1
)) = E_Anonymous_Access_Type
then
1702 if Ekind
(Etype
(F2
)) /= E_Anonymous_Access_Type
then
1704 elsif Designated_Type
(Etype
(F1
)) = Parent_Typ
1705 and then Designated_Type
(Etype
(F2
)) /= Full
1710 elsif Ekind
(Etype
(F2
)) = E_Anonymous_Access_Type
then
1713 elsif Etype
(F1
) = Parent_Typ
and then Etype
(F2
) /= Full
then
1721 -- Check that a controlling result type is derived from the parent
1722 -- subprogram's result type (or designated type if the result type
1723 -- is an anonymous access type).
1725 if Ekind
(Parent_Subp
) = E_Function
then
1726 if Ekind
(Subp
) /= E_Function
then
1729 elsif Ekind
(Etype
(Parent_Subp
)) = E_Anonymous_Access_Type
then
1730 if Ekind
(Etype
(Subp
)) /= E_Anonymous_Access_Type
then
1733 elsif Designated_Type
(Etype
(Parent_Subp
)) = Parent_Typ
1734 and then Designated_Type
(Etype
(Subp
)) /= Full
1739 elsif Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
then
1742 elsif Etype
(Parent_Subp
) = Parent_Typ
1743 and then Etype
(Subp
) /= Full
1748 elsif Ekind
(Subp
) = E_Function
then
1752 return No
(F1
) and then No
(F2
);
1755 -- Start of processing for Check_Operation_From_Incomplete_Type
1758 -- The operation may override an inherited one, or may be a new one
1759 -- altogether. The inherited operation will have been hidden by the
1760 -- current one at the point of the type derivation, so it does not
1761 -- appear in the list of primitive operations of the type. We have to
1762 -- find the proper place of insertion in the list of primitive opera-
1763 -- tions by iterating over the list for the parent type.
1765 Op1
:= First_Elmt
(Old_Prim
);
1766 Op2
:= First_Elmt
(New_Prim
);
1767 while Present
(Op1
) and then Present
(Op2
) loop
1768 if Derives_From
(Node
(Op1
)) then
1771 -- Avoid adding it to the list of primitives if already there
1773 if Node
(Op2
) /= Subp
then
1774 Prepend_Elmt
(Subp
, New_Prim
);
1778 Insert_Elmt_After
(Subp
, Prev
);
1789 -- Operation is a new primitive
1791 Append_Elmt
(Subp
, New_Prim
);
1792 end Check_Operation_From_Incomplete_Type
;
1794 ---------------------------------------
1795 -- Check_Operation_From_Private_View --
1796 ---------------------------------------
1798 procedure Check_Operation_From_Private_View
(Subp
, Old_Subp
: Entity_Id
) is
1799 Tagged_Type
: Entity_Id
;
1802 if Is_Dispatching_Operation
(Alias
(Subp
)) then
1803 Set_Scope
(Subp
, Current_Scope
);
1804 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1806 -- Add Old_Subp to primitive operations if not already present
1808 if Present
(Tagged_Type
) and then Is_Tagged_Type
(Tagged_Type
) then
1809 Append_Unique_Elmt
(Old_Subp
, Primitive_Operations
(Tagged_Type
));
1811 -- If Old_Subp isn't already marked as dispatching then this is
1812 -- the case of an operation of an untagged private type fulfilled
1813 -- by a tagged type that overrides an inherited dispatching
1814 -- operation, so we set the necessary dispatching attributes here.
1816 if not Is_Dispatching_Operation
(Old_Subp
) then
1818 -- If the untagged type has no discriminants, and the full
1819 -- view is constrained, there will be a spurious mismatch of
1820 -- subtypes on the controlling arguments, because the tagged
1821 -- type is the internal base type introduced in the derivation.
1822 -- Use the original type to verify conformance, rather than the
1825 if not Comes_From_Source
(Tagged_Type
)
1826 and then Has_Discriminants
(Tagged_Type
)
1832 Formal
:= First_Formal
(Old_Subp
);
1833 while Present
(Formal
) loop
1834 if Tagged_Type
= Base_Type
(Etype
(Formal
)) then
1835 Tagged_Type
:= Etype
(Formal
);
1838 Next_Formal
(Formal
);
1842 if Tagged_Type
= Base_Type
(Etype
(Old_Subp
)) then
1843 Tagged_Type
:= Etype
(Old_Subp
);
1847 Check_Controlling_Formals
(Tagged_Type
, Old_Subp
);
1848 Set_Is_Dispatching_Operation
(Old_Subp
, True);
1849 Set_DT_Position_Value
(Old_Subp
, No_Uint
);
1852 -- If the old subprogram is an explicit renaming of some other
1853 -- entity, it is not overridden by the inherited subprogram.
1854 -- Otherwise, update its alias and other attributes.
1856 if Present
(Alias
(Old_Subp
))
1857 and then Nkind
(Unit_Declaration_Node
(Old_Subp
)) /=
1858 N_Subprogram_Renaming_Declaration
1860 Set_Alias
(Old_Subp
, Alias
(Subp
));
1862 -- The derived subprogram should inherit the abstractness of
1863 -- the parent subprogram (except in the case of a function
1864 -- returning the type). This sets the abstractness properly
1865 -- for cases where a private extension may have inherited an
1866 -- abstract operation, but the full type is derived from a
1867 -- descendant type and inherits a nonabstract version.
1869 if Etype
(Subp
) /= Tagged_Type
then
1870 Set_Is_Abstract_Subprogram
1871 (Old_Subp
, Is_Abstract_Subprogram
(Alias
(Subp
)));
1876 end Check_Operation_From_Private_View
;
1878 --------------------------
1879 -- Find_Controlling_Arg --
1880 --------------------------
1882 function Find_Controlling_Arg
(N
: Node_Id
) return Node_Id
is
1883 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
1887 if Nkind
(Orig_Node
) = N_Qualified_Expression
then
1888 return Find_Controlling_Arg
(Expression
(Orig_Node
));
1891 -- Dispatching on result case. If expansion is disabled, the node still
1892 -- has the structure of a function call. However, if the function name
1893 -- is an operator and the call was given in infix form, the original
1894 -- node has no controlling result and we must examine the current node.
1896 if Nkind
(N
) = N_Function_Call
1897 and then Present
(Controlling_Argument
(N
))
1898 and then Has_Controlling_Result
(Entity
(Name
(N
)))
1900 return Controlling_Argument
(N
);
1902 -- If expansion is enabled, the call may have been transformed into
1903 -- an indirect call, and we need to recover the original node.
1905 elsif Nkind
(Orig_Node
) = N_Function_Call
1906 and then Present
(Controlling_Argument
(Orig_Node
))
1907 and then Has_Controlling_Result
(Entity
(Name
(Orig_Node
)))
1909 return Controlling_Argument
(Orig_Node
);
1911 -- Type conversions are dynamically tagged if the target type, or its
1912 -- designated type, are classwide. An interface conversion expands into
1913 -- a dereference, so test must be performed on the original node.
1915 elsif Nkind
(Orig_Node
) = N_Type_Conversion
1916 and then Nkind
(N
) = N_Explicit_Dereference
1917 and then Is_Controlling_Actual
(N
)
1920 Target_Type
: constant Entity_Id
:=
1921 Entity
(Subtype_Mark
(Orig_Node
));
1924 if Is_Class_Wide_Type
(Target_Type
) then
1927 elsif Is_Access_Type
(Target_Type
)
1928 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
1939 elsif Is_Controlling_Actual
(N
)
1941 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1942 and then Is_Controlling_Actual
(Parent
(N
)))
1946 if Is_Access_Type
(Typ
) then
1948 -- In the case of an Access attribute, use the type of the prefix,
1949 -- since in the case of an actual for an access parameter, the
1950 -- attribute's type may be of a specific designated type, even
1951 -- though the prefix type is class-wide.
1953 if Nkind
(N
) = N_Attribute_Reference
then
1954 Typ
:= Etype
(Prefix
(N
));
1956 -- An allocator is dispatching if the type of qualified expression
1957 -- is class_wide, in which case this is the controlling type.
1959 elsif Nkind
(Orig_Node
) = N_Allocator
1960 and then Nkind
(Expression
(Orig_Node
)) = N_Qualified_Expression
1962 Typ
:= Etype
(Expression
(Orig_Node
));
1964 Typ
:= Designated_Type
(Typ
);
1968 if Is_Class_Wide_Type
(Typ
)
1970 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1971 and then Is_Access_Type
(Etype
(N
))
1972 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(N
))))
1979 end Find_Controlling_Arg
;
1981 ---------------------------
1982 -- Find_Dispatching_Type --
1983 ---------------------------
1985 function Find_Dispatching_Type
(Subp
: Entity_Id
) return Entity_Id
is
1986 A_Formal
: Entity_Id
;
1988 Ctrl_Type
: Entity_Id
;
1991 if Ekind_In
(Subp
, E_Function
, E_Procedure
)
1992 and then Present
(DTC_Entity
(Subp
))
1994 return Scope
(DTC_Entity
(Subp
));
1996 -- For subprograms internally generated by derivations of tagged types
1997 -- use the alias subprogram as a reference to locate the dispatching
2000 elsif not Comes_From_Source
(Subp
)
2001 and then Present
(Alias
(Subp
))
2002 and then Is_Dispatching_Operation
(Alias
(Subp
))
2004 if Ekind
(Alias
(Subp
)) = E_Function
2005 and then Has_Controlling_Result
(Alias
(Subp
))
2007 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2010 Formal
:= First_Formal
(Subp
);
2011 A_Formal
:= First_Formal
(Alias
(Subp
));
2012 while Present
(A_Formal
) loop
2013 if Is_Controlling_Formal
(A_Formal
) then
2014 return Check_Controlling_Type
(Etype
(Formal
), Subp
);
2017 Next_Formal
(Formal
);
2018 Next_Formal
(A_Formal
);
2021 pragma Assert
(False);
2028 Formal
:= First_Formal
(Subp
);
2029 while Present
(Formal
) loop
2030 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
2032 if Present
(Ctrl_Type
) then
2036 Next_Formal
(Formal
);
2039 -- The subprogram may also be dispatching on result
2041 if Present
(Etype
(Subp
)) then
2042 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2046 pragma Assert
(not Is_Dispatching_Operation
(Subp
));
2048 end Find_Dispatching_Type
;
2050 --------------------------------------
2051 -- Find_Hidden_Overridden_Primitive --
2052 --------------------------------------
2054 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
2056 Tag_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
2058 Orig_Prim
: Entity_Id
;
2060 Vis_List
: Elist_Id
;
2063 -- This Ada 2012 rule applies only for type extensions or private
2064 -- extensions, where the parent type is not in a parent unit, and
2065 -- where an operation is never declared but still inherited.
2068 or else not Is_Record_Type
(Tag_Typ
)
2069 or else Etype
(Tag_Typ
) = Tag_Typ
2070 or else In_Open_Scopes
(Scope
(Etype
(Tag_Typ
)))
2075 -- Collect the list of visible ancestor of the tagged type
2077 Vis_List
:= Visible_Ancestors
(Tag_Typ
);
2079 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2080 while Present
(Elmt
) loop
2081 Prim
:= Node
(Elmt
);
2083 -- Find an inherited hidden dispatching primitive with the name of S
2084 -- and a type-conformant profile.
2086 if Present
(Alias
(Prim
))
2087 and then Is_Hidden
(Alias
(Prim
))
2088 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Tag_Typ
2089 and then Primitive_Names_Match
(S
, Prim
)
2090 and then Type_Conformant
(S
, Prim
)
2093 Vis_Ancestor
: Elmt_Id
;
2097 -- The original corresponding operation of Prim must be an
2098 -- operation of a visible ancestor of the dispatching type S,
2099 -- and the original corresponding operation of S2 must be
2102 Orig_Prim
:= Original_Corresponding_Operation
(Prim
);
2104 if Orig_Prim
/= Prim
2105 and then Is_Immediately_Visible
(Orig_Prim
)
2107 Vis_Ancestor
:= First_Elmt
(Vis_List
);
2108 while Present
(Vis_Ancestor
) loop
2110 First_Elmt
(Primitive_Operations
(Node
(Vis_Ancestor
)));
2111 while Present
(Elmt
) loop
2112 if Node
(Elmt
) = Orig_Prim
then
2113 Set_Overridden_Operation
(S
, Prim
);
2114 Set_Alias
(Prim
, Orig_Prim
);
2121 Next_Elmt
(Vis_Ancestor
);
2131 end Find_Hidden_Overridden_Primitive
;
2133 ---------------------------------------
2134 -- Find_Primitive_Covering_Interface --
2135 ---------------------------------------
2137 function Find_Primitive_Covering_Interface
2138 (Tagged_Type
: Entity_Id
;
2139 Iface_Prim
: Entity_Id
) return Entity_Id
2145 pragma Assert
(Is_Interface
(Find_Dispatching_Type
(Iface_Prim
))
2146 or else (Present
(Alias
(Iface_Prim
))
2149 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
2151 -- Search in the homonym chain. Done to speed up locating visible
2152 -- entities and required to catch primitives associated with the partial
2153 -- view of private types when processing the corresponding full view.
2155 E
:= Current_Entity
(Iface_Prim
);
2156 while Present
(E
) loop
2157 if Is_Subprogram
(E
)
2158 and then Is_Dispatching_Operation
(E
)
2159 and then Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
)
2167 -- Search in the list of primitives of the type. Required to locate
2168 -- the covering primitive if the covering primitive is not visible
2169 -- (for example, non-visible inherited primitive of private type).
2171 El
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2172 while Present
(El
) loop
2175 -- Keep separate the management of internal entities that link
2176 -- primitives with interface primitives from tagged type primitives.
2178 if No
(Interface_Alias
(E
)) then
2179 if Present
(Alias
(E
)) then
2181 -- This interface primitive has not been covered yet
2183 if Alias
(E
) = Iface_Prim
then
2186 -- The covering primitive was inherited
2188 elsif Overridden_Operation
(Ultimate_Alias
(E
))
2195 -- Check if E covers the interface primitive (includes case in
2196 -- which E is an inherited private primitive).
2198 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2202 -- Use the internal entity that links the interface primitive with
2203 -- the covering primitive to locate the entity.
2205 elsif Interface_Alias
(E
) = Iface_Prim
then
2215 end Find_Primitive_Covering_Interface
;
2217 ---------------------------
2218 -- Inherited_Subprograms --
2219 ---------------------------
2221 function Inherited_Subprograms
2223 No_Interfaces
: Boolean := False;
2224 Interfaces_Only
: Boolean := False;
2225 One_Only
: Boolean := False) return Subprogram_List
2227 Result
: Subprogram_List
(1 .. 6000);
2228 -- 6000 here is intended to be infinity. We could use an expandable
2229 -- table, but it would be awfully heavy, and there is no way that we
2230 -- could reasonably exceed this value.
2233 -- Number of entries in Result
2235 Parent_Op
: Entity_Id
;
2236 -- Traverses the Overridden_Operation chain
2238 procedure Store_IS
(E
: Entity_Id
);
2239 -- Stores E in Result if not already stored
2245 procedure Store_IS
(E
: Entity_Id
) is
2247 for J
in 1 .. N
loop
2248 if E
= Result
(J
) then
2257 -- Start of processing for Inherited_Subprograms
2260 pragma Assert
(not (No_Interfaces
and Interfaces_Only
));
2262 if Present
(S
) and then Is_Dispatching_Operation
(S
) then
2264 -- Deal with direct inheritance
2266 if not Interfaces_Only
then
2269 Parent_Op
:= Overridden_Operation
(Parent_Op
);
2270 exit when No
(Parent_Op
)
2274 Is_Interface
(Find_Dispatching_Type
(Parent_Op
)));
2276 if Is_Subprogram_Or_Generic_Subprogram
(Parent_Op
) then
2277 Store_IS
(Parent_Op
);
2286 -- Now deal with interfaces
2288 if not No_Interfaces
then
2290 Tag_Typ
: Entity_Id
;
2295 Tag_Typ
:= Find_Dispatching_Type
(S
);
2297 -- In the presence of limited views there may be no visible
2298 -- dispatching type. Primitives will be inherited when non-
2299 -- limited view is frozen.
2301 if No
(Tag_Typ
) then
2302 return Result
(1 .. 0);
2305 if Is_Concurrent_Type
(Tag_Typ
) then
2306 Tag_Typ
:= Corresponding_Record_Type
(Tag_Typ
);
2309 -- Search primitive operations of dispatching type
2311 if Present
(Tag_Typ
)
2312 and then Present
(Primitive_Operations
(Tag_Typ
))
2314 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2315 while Present
(Elmt
) loop
2316 Prim
:= Node
(Elmt
);
2318 -- The following test eliminates some odd cases in which
2319 -- Ekind (Prim) is Void, to be investigated further ???
2321 if not Is_Subprogram_Or_Generic_Subprogram
(Prim
) then
2324 -- For [generic] subprogram, look at interface alias
2326 elsif Present
(Interface_Alias
(Prim
))
2327 and then Alias
(Prim
) = S
2329 -- We have found a primitive covered by S
2331 Store_IS
(Interface_Alias
(Prim
));
2347 return Result
(1 .. N
);
2348 end Inherited_Subprograms
;
2350 ---------------------------
2351 -- Is_Dynamically_Tagged --
2352 ---------------------------
2354 function Is_Dynamically_Tagged
(N
: Node_Id
) return Boolean is
2356 if Nkind
(N
) = N_Error
then
2359 elsif Present
(Find_Controlling_Arg
(N
)) then
2362 -- Special cases: entities, and calls that dispatch on result
2364 elsif Is_Entity_Name
(N
) then
2365 return Is_Class_Wide_Type
(Etype
(N
));
2367 elsif Nkind
(N
) = N_Function_Call
2368 and then Is_Class_Wide_Type
(Etype
(N
))
2372 -- Otherwise check whether call has controlling argument
2377 end Is_Dynamically_Tagged
;
2379 ---------------------------------
2380 -- Is_Null_Interface_Primitive --
2381 ---------------------------------
2383 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2385 return Comes_From_Source
(E
)
2386 and then Is_Dispatching_Operation
(E
)
2387 and then Ekind
(E
) = E_Procedure
2388 and then Null_Present
(Parent
(E
))
2389 and then Is_Interface
(Find_Dispatching_Type
(E
));
2390 end Is_Null_Interface_Primitive
;
2392 -----------------------------------
2393 -- Is_Inherited_Public_Operation --
2394 -----------------------------------
2396 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean is
2397 Prim
: constant Entity_Id
:= Alias
(Op
);
2398 Scop
: constant Entity_Id
:= Scope
(Prim
);
2399 Pack_Decl
: Node_Id
;
2402 if Comes_From_Source
(Prim
) and then Ekind
(Scop
) = E_Package
then
2403 Pack_Decl
:= Unit_Declaration_Node
(Scop
);
2404 return Nkind
(Pack_Decl
) = N_Package_Declaration
2405 and then List_Containing
(Unit_Declaration_Node
(Prim
)) =
2406 Visible_Declarations
(Specification
(Pack_Decl
));
2411 end Is_Inherited_Public_Operation
;
2413 ------------------------------
2414 -- Is_Overriding_Subprogram --
2415 ------------------------------
2417 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean is
2418 Inherited
: constant Subprogram_List
:=
2419 Inherited_Subprograms
(E
, One_Only
=> True);
2421 return Inherited
'Length > 0;
2422 end Is_Overriding_Subprogram
;
2424 --------------------------
2425 -- Is_Tag_Indeterminate --
2426 --------------------------
2428 function Is_Tag_Indeterminate
(N
: Node_Id
) return Boolean is
2431 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2434 if Nkind
(Orig_Node
) = N_Function_Call
2435 and then Is_Entity_Name
(Name
(Orig_Node
))
2437 Nam
:= Entity
(Name
(Orig_Node
));
2439 if not Has_Controlling_Result
(Nam
) then
2442 -- The function may have a controlling result, but if the return type
2443 -- is not visibly tagged, then this is not tag-indeterminate.
2445 elsif Is_Access_Type
(Etype
(Nam
))
2446 and then not Is_Tagged_Type
(Designated_Type
(Etype
(Nam
)))
2450 -- An explicit dereference means that the call has already been
2451 -- expanded and there is no tag to propagate.
2453 elsif Nkind
(N
) = N_Explicit_Dereference
then
2456 -- If there are no actuals, the call is tag-indeterminate
2458 elsif No
(Parameter_Associations
(Orig_Node
)) then
2462 Actual
:= First_Actual
(Orig_Node
);
2463 while Present
(Actual
) loop
2464 if Is_Controlling_Actual
(Actual
)
2465 and then not Is_Tag_Indeterminate
(Actual
)
2467 -- One operand is dispatching
2472 Next_Actual
(Actual
);
2478 elsif Nkind
(Orig_Node
) = N_Qualified_Expression
then
2479 return Is_Tag_Indeterminate
(Expression
(Orig_Node
));
2481 -- Case of a call to the Input attribute (possibly rewritten), which is
2482 -- always tag-indeterminate except when its prefix is a Class attribute.
2484 elsif Nkind
(Orig_Node
) = N_Attribute_Reference
2486 Get_Attribute_Id
(Attribute_Name
(Orig_Node
)) = Attribute_Input
2487 and then Nkind
(Prefix
(Orig_Node
)) /= N_Attribute_Reference
2491 -- In Ada 2005, a function that returns an anonymous access type can be
2492 -- dispatching, and the dereference of a call to such a function can
2493 -- also be tag-indeterminate if the call itself is.
2495 elsif Nkind
(Orig_Node
) = N_Explicit_Dereference
2496 and then Ada_Version
>= Ada_2005
2498 return Is_Tag_Indeterminate
(Prefix
(Orig_Node
));
2503 end Is_Tag_Indeterminate
;
2505 ------------------------------------
2506 -- Override_Dispatching_Operation --
2507 ------------------------------------
2509 procedure Override_Dispatching_Operation
2510 (Tagged_Type
: Entity_Id
;
2511 Prev_Op
: Entity_Id
;
2513 Is_Wrapper
: Boolean := False)
2519 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
2520 -- we do it unconditionally in Ada 95 now, since this is our pragma).
2522 if No_Return
(Prev_Op
) and then not No_Return
(New_Op
) then
2523 Error_Msg_N
("procedure & must have No_Return pragma", New_Op
);
2524 Error_Msg_N
("\since overridden procedure has No_Return", New_Op
);
2527 -- If there is no previous operation to override, the type declaration
2528 -- was malformed, and an error must have been emitted already.
2530 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2531 while Present
(Elmt
) and then Node
(Elmt
) /= Prev_Op
loop
2539 -- The location of entities that come from source in the list of
2540 -- primitives of the tagged type must follow their order of occurrence
2541 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
2542 -- primitive of an interface that is not implemented by the parents of
2543 -- this tagged type (that is, it is an alias of an interface primitive
2544 -- generated by Derive_Interface_Progenitors), then we must append the
2545 -- new entity at the end of the list of primitives.
2547 if Present
(Alias
(Prev_Op
))
2548 and then Etype
(Tagged_Type
) /= Tagged_Type
2549 and then Is_Interface
(Find_Dispatching_Type
(Alias
(Prev_Op
)))
2550 and then not Is_Ancestor
(Find_Dispatching_Type
(Alias
(Prev_Op
)),
2551 Tagged_Type
, Use_Full_View
=> True)
2552 and then not Implements_Interface
2553 (Etype
(Tagged_Type
),
2554 Find_Dispatching_Type
(Alias
(Prev_Op
)))
2556 Remove_Elmt
(Primitive_Operations
(Tagged_Type
), Elmt
);
2557 Append_Elmt
(New_Op
, Primitive_Operations
(Tagged_Type
));
2559 -- The new primitive replaces the overridden entity. Required to ensure
2560 -- that overriding primitive is assigned the same dispatch table slot.
2563 Replace_Elmt
(Elmt
, New_Op
);
2566 if Ada_Version
>= Ada_2005
and then Has_Interfaces
(Tagged_Type
) then
2568 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
2569 -- entities of the overridden primitive to reference New_Op, and
2570 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
2571 -- that the new operation is subtype conformant with the interface
2572 -- operations that it implements (for operations inherited from the
2573 -- parent itself, this check is made when building the derived type).
2575 -- Note: This code is executed with internally generated wrappers of
2576 -- functions with controlling result and late overridings.
2578 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2579 while Present
(Elmt
) loop
2580 Prim
:= Node
(Elmt
);
2582 if Prim
= New_Op
then
2585 -- Note: The check on Is_Subprogram protects the frontend against
2586 -- reading attributes in entities that are not yet fully decorated
2588 elsif Is_Subprogram
(Prim
)
2589 and then Present
(Interface_Alias
(Prim
))
2590 and then Alias
(Prim
) = Prev_Op
2592 Set_Alias
(Prim
, New_Op
);
2594 -- No further decoration needed yet for internally generated
2595 -- wrappers of controlling functions since (at this stage)
2596 -- they are not yet decorated.
2598 if not Is_Wrapper
then
2599 Check_Subtype_Conformant
(New_Op
, Prim
);
2601 Set_Is_Abstract_Subprogram
(Prim
,
2602 Is_Abstract_Subprogram
(New_Op
));
2604 -- Ensure that this entity will be expanded to fill the
2605 -- corresponding entry in its dispatch table.
2607 if not Is_Abstract_Subprogram
(Prim
) then
2608 Set_Has_Delayed_Freeze
(Prim
);
2617 if (not Is_Package_Or_Generic_Package
(Current_Scope
))
2618 or else not In_Private_Part
(Current_Scope
)
2620 -- Not a private primitive
2624 else pragma Assert
(Is_Inherited_Operation
(Prev_Op
));
2626 -- Make the overriding operation into an alias of the implicit one.
2627 -- In this fashion a call from outside ends up calling the new body
2628 -- even if non-dispatching, and a call from inside calls the over-
2629 -- riding operation because it hides the implicit one. To indicate
2630 -- that the body of Prev_Op is never called, set its dispatch table
2631 -- entity to Empty. If the overridden operation has a dispatching
2632 -- result, so does the overriding one.
2634 Set_Alias
(Prev_Op
, New_Op
);
2635 Set_DTC_Entity
(Prev_Op
, Empty
);
2636 Set_Has_Controlling_Result
(New_Op
, Has_Controlling_Result
(Prev_Op
));
2639 end Override_Dispatching_Operation
;
2645 procedure Propagate_Tag
(Control
: Node_Id
; Actual
: Node_Id
) is
2646 Call_Node
: Node_Id
;
2650 if Nkind
(Actual
) = N_Function_Call
then
2651 Call_Node
:= Actual
;
2653 elsif Nkind
(Actual
) = N_Identifier
2654 and then Nkind
(Original_Node
(Actual
)) = N_Function_Call
2656 -- Call rewritten as object declaration when stack-checking is
2657 -- enabled. Propagate tag to expression in declaration, which is
2660 Call_Node
:= Expression
(Parent
(Entity
(Actual
)));
2662 -- Ada 2005: If this is a dereference of a call to a function with a
2663 -- dispatching access-result, the tag is propagated when the dereference
2664 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
2666 elsif Nkind
(Actual
) = N_Explicit_Dereference
2667 and then Nkind
(Original_Node
(Prefix
(Actual
))) = N_Function_Call
2671 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
2672 -- and in that case we can simply return.
2674 elsif Nkind
(Actual
) = N_Attribute_Reference
then
2675 pragma Assert
(Attribute_Name
(Actual
) = Name_Input
);
2679 -- Only other possibilities are parenthesized or qualified expression,
2680 -- or an expander-generated unchecked conversion of a function call to
2681 -- a stream Input attribute.
2684 Call_Node
:= Expression
(Actual
);
2687 -- No action needed if the call has been already expanded
2689 if Is_Expanded_Dispatching_Call
(Call_Node
) then
2693 -- Do not set the Controlling_Argument if already set. This happens in
2694 -- the special case of _Input (see Exp_Attr, case Input).
2696 if No
(Controlling_Argument
(Call_Node
)) then
2697 Set_Controlling_Argument
(Call_Node
, Control
);
2700 Arg
:= First_Actual
(Call_Node
);
2701 while Present
(Arg
) loop
2702 if Is_Tag_Indeterminate
(Arg
) then
2703 Propagate_Tag
(Control
, Arg
);
2709 -- Expansion of dispatching calls is suppressed on VM targets, because
2710 -- the VM back-ends directly handle the generation of dispatching calls
2711 -- and would have to undo any expansion to an indirect call.
2713 if Tagged_Type_Expansion
then
2715 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
2718 Expand_Dispatching_Call
(Call_Node
);
2720 -- If the controlling argument is an interface type and the type
2721 -- of Call_Node differs then we must add an implicit conversion to
2722 -- force displacement of the pointer to the object to reference
2723 -- the secondary dispatch table of the interface.
2725 if Is_Interface
(Etype
(Control
))
2726 and then Etype
(Control
) /= Call_Typ
2728 -- Cannot use Convert_To because the previous call to
2729 -- Expand_Dispatching_Call leaves decorated the Call_Node
2730 -- with the type of Control.
2733 Make_Type_Conversion
(Sloc
(Call_Node
),
2735 New_Occurrence_Of
(Etype
(Control
), Sloc
(Call_Node
)),
2736 Expression
=> Relocate_Node
(Call_Node
)));
2737 Set_Etype
(Call_Node
, Etype
(Control
));
2738 Set_Analyzed
(Call_Node
);
2740 Expand_Interface_Conversion
(Call_Node
);
2744 -- Expansion of a dispatching call results in an indirect call, which in
2745 -- turn causes current values to be killed (see Resolve_Call), so on VM
2746 -- targets we do the call here to ensure consistent warnings between VM
2747 -- and non-VM targets.
2750 Kill_Current_Values
;