1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
;
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 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean;
89 -- Check whether a primitive operation is inherited from an operation
90 -- declared in the visible part of its package.
92 -------------------------------
93 -- Add_Dispatching_Operation --
94 -------------------------------
96 procedure Add_Dispatching_Operation
97 (Tagged_Type
: Entity_Id
;
100 List
: constant Elist_Id
:= Primitive_Operations
(Tagged_Type
);
103 -- The dispatching operation may already be on the list, if it is the
104 -- wrapper for an inherited function of a null extension (see Exp_Ch3
105 -- for the construction of function wrappers). The list of primitive
106 -- operations must not contain duplicates.
108 Append_Unique_Elmt
(New_Op
, List
);
109 end Add_Dispatching_Operation
;
111 ---------------------------
112 -- Covers_Some_Interface --
113 ---------------------------
115 function Covers_Some_Interface
(Prim
: Entity_Id
) return Boolean is
116 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
121 pragma Assert
(Is_Dispatching_Operation
(Prim
));
123 -- Although this is a dispatching primitive we must check if its
124 -- dispatching type is available because it may be the primitive
125 -- of a private type not defined as tagged in its partial view.
127 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
129 -- If the tagged type is frozen then the internal entities associated
130 -- with interfaces are available in the list of primitives of the
131 -- tagged type and can be used to speed up this search.
133 if Is_Frozen
(Tagged_Type
) then
134 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
135 while Present
(Elmt
) loop
138 if Present
(Interface_Alias
(E
))
139 and then Alias
(E
) = Prim
147 -- Otherwise we must collect all the interface primitives and check
148 -- if the Prim will override some interface primitive.
152 Ifaces_List
: Elist_Id
;
153 Iface_Elmt
: Elmt_Id
;
155 Iface_Prim
: Entity_Id
;
158 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
159 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
160 while Present
(Iface_Elmt
) loop
161 Iface
:= Node
(Iface_Elmt
);
163 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
164 while Present
(Elmt
) loop
165 Iface_Prim
:= Node
(Elmt
);
167 if Chars
(Iface
) = Chars
(Prim
)
168 and then Is_Interface_Conformant
169 (Tagged_Type
, Iface_Prim
, Prim
)
177 Next_Elmt
(Iface_Elmt
);
184 end Covers_Some_Interface
;
186 -------------------------------
187 -- Check_Controlling_Formals --
188 -------------------------------
190 procedure Check_Controlling_Formals
195 Ctrl_Type
: Entity_Id
;
198 Formal
:= First_Formal
(Subp
);
199 while Present
(Formal
) loop
200 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
202 if Present
(Ctrl_Type
) then
204 -- When controlling type is concurrent and declared within a
205 -- generic or inside an instance use corresponding record type.
207 if Is_Concurrent_Type
(Ctrl_Type
)
208 and then Present
(Corresponding_Record_Type
(Ctrl_Type
))
210 Ctrl_Type
:= Corresponding_Record_Type
(Ctrl_Type
);
213 if Ctrl_Type
= Typ
then
214 Set_Is_Controlling_Formal
(Formal
);
216 -- Ada 2005 (AI-231): Anonymous access types that are used in
217 -- controlling parameters exclude null because it is necessary
218 -- to read the tag to dispatch, and null has no tag.
220 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
221 Set_Can_Never_Be_Null
(Etype
(Formal
));
222 Set_Is_Known_Non_Null
(Etype
(Formal
));
225 -- Check that the parameter's nominal subtype statically
226 -- matches the first subtype.
228 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
229 if not Subtypes_Statically_Match
230 (Typ
, Designated_Type
(Etype
(Formal
)))
233 ("parameter subtype does not match controlling type",
237 elsif not Subtypes_Statically_Match
(Typ
, Etype
(Formal
)) then
239 ("parameter subtype does not match controlling type",
243 if Present
(Default_Value
(Formal
)) then
245 -- In Ada 2005, access parameters can have defaults
247 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
248 and then Ada_Version
< Ada_2005
251 ("default not allowed for controlling access parameter",
252 Default_Value
(Formal
));
254 elsif not Is_Tag_Indeterminate
(Default_Value
(Formal
)) then
256 ("default expression must be a tag indeterminate" &
257 " function call", Default_Value
(Formal
));
261 elsif Comes_From_Source
(Subp
) then
263 ("operation can be dispatching in only one type", Subp
);
267 Next_Formal
(Formal
);
270 if Ekind_In
(Subp
, E_Function
, E_Generic_Function
) then
271 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Subp
), Subp
);
273 if Present
(Ctrl_Type
) then
274 if Ctrl_Type
= Typ
then
275 Set_Has_Controlling_Result
(Subp
);
277 -- Check that result subtype statically matches first subtype
278 -- (Ada 2005): Subp may have a controlling access result.
280 if Subtypes_Statically_Match
(Typ
, Etype
(Subp
))
281 or else (Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
283 Subtypes_Statically_Match
284 (Typ
, Designated_Type
(Etype
(Subp
))))
290 ("result subtype does not match controlling type", Subp
);
293 elsif Comes_From_Source
(Subp
) then
295 ("operation can be dispatching in only one type", Subp
);
299 end Check_Controlling_Formals
;
301 ----------------------------
302 -- Check_Controlling_Type --
303 ----------------------------
305 function Check_Controlling_Type
307 Subp
: Entity_Id
) return Entity_Id
309 Tagged_Type
: Entity_Id
:= Empty
;
312 if Is_Tagged_Type
(T
) then
313 if Is_First_Subtype
(T
) then
316 Tagged_Type
:= Base_Type
(T
);
319 -- If the type is incomplete, it may have been declared without a
320 -- Tagged indication, but the full view may be tagged, in which case
321 -- that is the controlling type of the subprogram. This is one of the
322 -- approx. 579 places in the language where a lookahead would help.
324 elsif Ekind
(T
) = E_Incomplete_Type
325 and then Present
(Full_View
(T
))
326 and then Is_Tagged_Type
(Full_View
(T
))
328 Set_Is_Tagged_Type
(T
);
329 Tagged_Type
:= Full_View
(T
);
331 elsif Ekind
(T
) = E_Anonymous_Access_Type
332 and then Is_Tagged_Type
(Designated_Type
(T
))
334 if Ekind
(Designated_Type
(T
)) /= E_Incomplete_Type
then
335 if Is_First_Subtype
(Designated_Type
(T
)) then
336 Tagged_Type
:= Designated_Type
(T
);
338 Tagged_Type
:= Base_Type
(Designated_Type
(T
));
341 -- Ada 2005: an incomplete type can be tagged. An operation with an
342 -- access parameter of the type is dispatching.
344 elsif Scope
(Designated_Type
(T
)) = Current_Scope
then
345 Tagged_Type
:= Designated_Type
(T
);
347 -- Ada 2005 (AI-50217)
349 elsif From_Limited_With
(Designated_Type
(T
))
350 and then Has_Non_Limited_View
(Designated_Type
(T
))
351 and then Scope
(Designated_Type
(T
)) = Scope
(Subp
)
353 if Is_First_Subtype
(Non_Limited_View
(Designated_Type
(T
))) then
354 Tagged_Type
:= Non_Limited_View
(Designated_Type
(T
));
356 Tagged_Type
:= Base_Type
(Non_Limited_View
357 (Designated_Type
(T
)));
362 if No
(Tagged_Type
) or else Is_Class_Wide_Type
(Tagged_Type
) then
365 -- The dispatching type and the primitive operation must be defined in
366 -- the same scope, except in the case of internal operations and formal
367 -- abstract subprograms.
369 elsif ((Scope
(Subp
) = Scope
(Tagged_Type
) or else Is_Internal
(Subp
))
370 and then (not Is_Generic_Type
(Tagged_Type
)
371 or else not Comes_From_Source
(Subp
)))
373 (Is_Formal_Subprogram
(Subp
) and then Is_Abstract_Subprogram
(Subp
))
375 (Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Renaming_Declaration
377 Present
(Corresponding_Formal_Spec
(Parent
(Parent
(Subp
))))
379 Is_Abstract_Subprogram
(Subp
))
386 end Check_Controlling_Type
;
388 ----------------------------
389 -- Check_Dispatching_Call --
390 ----------------------------
392 procedure Check_Dispatching_Call
(N
: Node_Id
) is
393 Loc
: constant Source_Ptr
:= Sloc
(N
);
396 Control
: Node_Id
:= Empty
;
398 Subp_Entity
: Entity_Id
;
399 Indeterm_Ancestor_Call
: Boolean := False;
400 Indeterm_Ctrl_Type
: Entity_Id
;
402 Static_Tag
: Node_Id
:= Empty
;
403 -- If a controlling formal has a statically tagged actual, the tag of
404 -- this actual is to be used for any tag-indeterminate actual.
406 procedure Check_Direct_Call
;
407 -- In the case when the controlling actual is a class-wide type whose
408 -- root type's completion is a task or protected type, the call is in
409 -- fact direct. This routine detects the above case and modifies the
412 procedure Check_Dispatching_Context
;
413 -- If the call is tag-indeterminate and the entity being called is
414 -- abstract, verify that the context is a call that will eventually
415 -- provide a tag for dispatching, or has provided one already.
417 -----------------------
418 -- Check_Direct_Call --
419 -----------------------
421 procedure Check_Direct_Call
is
422 Typ
: Entity_Id
:= Etype
(Control
);
424 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean;
425 -- Determine whether an entity denotes a user-defined equality
427 ------------------------------
428 -- Is_User_Defined_Equality --
429 ------------------------------
431 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
434 Ekind
(Id
) = E_Function
435 and then Chars
(Id
) = Name_Op_Eq
436 and then Comes_From_Source
(Id
)
438 -- Internally generated equalities have a full type declaration
441 and then Nkind
(Parent
(Id
)) = N_Function_Specification
;
442 end Is_User_Defined_Equality
;
444 -- Start of processing for Check_Direct_Call
447 -- Predefined primitives do not receive wrappers since they are built
448 -- from scratch for the corresponding record of synchronized types.
449 -- Equality is in general predefined, but is excluded from the check
450 -- when it is user-defined.
452 if Is_Predefined_Dispatching_Operation
(Subp_Entity
)
453 and then not Is_User_Defined_Equality
(Subp_Entity
)
458 if Is_Class_Wide_Type
(Typ
) then
459 Typ
:= Root_Type
(Typ
);
462 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
463 Typ
:= Full_View
(Typ
);
466 if Is_Concurrent_Type
(Typ
)
468 Present
(Corresponding_Record_Type
(Typ
))
470 Typ
:= Corresponding_Record_Type
(Typ
);
472 -- The concurrent record's list of primitives should contain a
473 -- wrapper for the entity of the call, retrieve it.
478 Wrapper_Found
: Boolean := False;
481 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
482 while Present
(Prim_Elmt
) loop
483 Prim
:= Node
(Prim_Elmt
);
485 if Is_Primitive_Wrapper
(Prim
)
486 and then Wrapped_Entity
(Prim
) = Subp_Entity
488 Wrapper_Found
:= True;
492 Next_Elmt
(Prim_Elmt
);
495 -- A primitive declared between two views should have a
496 -- corresponding wrapper.
498 pragma Assert
(Wrapper_Found
);
500 -- Modify the call by setting the proper entity
502 Set_Entity
(Name
(N
), Prim
);
505 end Check_Direct_Call
;
507 -------------------------------
508 -- Check_Dispatching_Context --
509 -------------------------------
511 procedure Check_Dispatching_Context
is
512 Subp
: constant Entity_Id
:= Entity
(Name
(N
));
513 Typ
: constant Entity_Id
:= Etype
(Subp
);
516 procedure Abstract_Context_Error
;
517 -- Error for abstract call dispatching on result is not dispatching
519 ----------------------------
520 -- Abstract_Context_Error --
521 ----------------------------
523 procedure Abstract_Context_Error
is
525 if Ekind
(Subp
) = E_Function
then
527 ("call to abstract function must be dispatching", N
);
529 -- This error can occur for a procedure in the case of a call to
530 -- an abstract formal procedure with a statically tagged operand.
534 ("call to abstract procedure must be dispatching",
537 end Abstract_Context_Error
;
539 -- Start of processing for Check_Dispatching_Context
542 if Is_Abstract_Subprogram
(Subp
)
543 and then No
(Controlling_Argument
(N
))
545 if Present
(Alias
(Subp
))
546 and then not Is_Abstract_Subprogram
(Alias
(Subp
))
547 and then No
(DTC_Entity
(Subp
))
549 -- Private overriding of inherited abstract operation, call is
552 Set_Entity
(Name
(N
), Alias
(Subp
));
555 -- An obscure special case: a null procedure may have a class-
556 -- wide pre/postcondition that includes a call to an abstract
557 -- subp. Calls within the expression may not have been rewritten
558 -- as dispatching calls yet, because the null body appears in
559 -- the current declarative part. The expression will be properly
560 -- rewritten/reanalyzed when the postcondition procedure is built.
562 -- Similarly, if this is a pre/postcondition for an abstract
563 -- subprogram, it may call another abstract function which is
564 -- a primitive of an abstract type. The call is non-dispatching
565 -- but will be legal in overridings of the operation.
567 elsif In_Spec_Expression
568 and then Is_Subprogram
(Current_Scope
)
570 ((Nkind
(Parent
(Current_Scope
)) = N_Procedure_Specification
571 and then Null_Present
(Parent
(Current_Scope
)))
572 or else Is_Abstract_Subprogram
(Current_Scope
))
576 elsif Ekind
(Current_Scope
) = E_Function
577 and then Nkind
(Unit_Declaration_Node
(Current_Scope
)) =
578 N_Generic_Subprogram_Declaration
583 -- We need to determine whether the context of the call
584 -- provides a tag to make the call dispatching. This requires
585 -- the call to be the actual in an enclosing call, and that
586 -- actual must be controlling. If the call is an operand of
587 -- equality, the other operand must not ve abstract.
589 if not Is_Tagged_Type
(Typ
)
591 (Ekind
(Typ
) = E_Anonymous_Access_Type
592 and then Is_Tagged_Type
(Designated_Type
(Typ
)))
594 Abstract_Context_Error
;
600 if Nkind
(Par
) = N_Parameter_Association
then
604 while Present
(Par
) loop
605 if Nkind_In
(Par
, N_Function_Call
,
606 N_Procedure_Call_Statement
)
607 and then Is_Entity_Name
(Name
(Par
))
610 Enc_Subp
: constant Entity_Id
:= Entity
(Name
(Par
));
615 -- Find formal for which call is the actual, and is
616 -- a controlling argument.
618 F
:= First_Formal
(Enc_Subp
);
619 A
:= First_Actual
(Par
);
621 while Present
(F
) loop
622 if Is_Controlling_Formal
(F
)
623 and then (N
= A
or else Parent
(N
) = A
)
633 ("call to abstract function must be dispatching", N
);
637 -- For equalitiy operators, one of the operands must be
638 -- statically or dynamically tagged.
640 elsif Nkind_In
(Par
, N_Op_Eq
, N_Op_Ne
) then
641 if N
= Right_Opnd
(Par
)
642 and then Is_Tag_Indeterminate
(Left_Opnd
(Par
))
644 Abstract_Context_Error
;
646 elsif N
= Left_Opnd
(Par
)
647 and then Is_Tag_Indeterminate
(Right_Opnd
(Par
))
649 Abstract_Context_Error
;
654 elsif Nkind
(Par
) = N_Assignment_Statement
then
657 elsif Nkind
(Par
) = N_Qualified_Expression
658 or else Nkind
(Par
) = N_Unchecked_Type_Conversion
663 Abstract_Context_Error
;
669 end Check_Dispatching_Context
;
671 -- Start of processing for Check_Dispatching_Call
674 -- Find a controlling argument, if any
676 if Present
(Parameter_Associations
(N
)) then
677 Subp_Entity
:= Entity
(Name
(N
));
679 Actual
:= First_Actual
(N
);
680 Formal
:= First_Formal
(Subp_Entity
);
681 while Present
(Actual
) loop
682 Control
:= Find_Controlling_Arg
(Actual
);
683 exit when Present
(Control
);
685 -- Check for the case where the actual is a tag-indeterminate call
686 -- whose result type is different than the tagged type associated
687 -- with the containing call, but is an ancestor of the type.
689 if Is_Controlling_Formal
(Formal
)
690 and then Is_Tag_Indeterminate
(Actual
)
691 and then Base_Type
(Etype
(Actual
)) /= Base_Type
(Etype
(Formal
))
692 and then Is_Ancestor
(Etype
(Actual
), Etype
(Formal
))
694 Indeterm_Ancestor_Call
:= True;
695 Indeterm_Ctrl_Type
:= Etype
(Formal
);
697 -- If the formal is controlling but the actual is not, the type
698 -- of the actual is statically known, and may be used as the
699 -- controlling tag for some other tag-indeterminate actual.
701 elsif Is_Controlling_Formal
(Formal
)
702 and then Is_Entity_Name
(Actual
)
703 and then Is_Tagged_Type
(Etype
(Actual
))
705 Static_Tag
:= Actual
;
708 Next_Actual
(Actual
);
709 Next_Formal
(Formal
);
712 -- If the call doesn't have a controlling actual but does have an
713 -- indeterminate actual that requires dispatching treatment, then an
714 -- object is needed that will serve as the controlling argument for
715 -- a dispatching call on the indeterminate actual. This can occur
716 -- in the unusual situation of a default actual given by a tag-
717 -- indeterminate call and where the type of the call is an ancestor
718 -- of the type associated with a containing call to an inherited
719 -- operation (see AI-239).
721 -- Rather than create an object of the tagged type, which would
722 -- be problematic for various reasons (default initialization,
723 -- discriminants), the tag of the containing call's associated
724 -- tagged type is directly used to control the dispatching.
727 and then Indeterm_Ancestor_Call
728 and then No
(Static_Tag
)
731 Make_Attribute_Reference
(Loc
,
732 Prefix
=> New_Occurrence_Of
(Indeterm_Ctrl_Type
, Loc
),
733 Attribute_Name
=> Name_Tag
);
738 if Present
(Control
) then
740 -- Verify that no controlling arguments are statically tagged
743 Write_Str
("Found Dispatching call");
748 Actual
:= First_Actual
(N
);
749 while Present
(Actual
) loop
750 if Actual
/= Control
then
752 if not Is_Controlling_Actual
(Actual
) then
753 null; -- Can be anything
755 elsif Is_Dynamically_Tagged
(Actual
) then
756 null; -- Valid parameter
758 elsif Is_Tag_Indeterminate
(Actual
) then
760 -- The tag is inherited from the enclosing call (the node
761 -- we are currently analyzing). Explicitly expand the
762 -- actual, since the previous call to Expand (from
763 -- Resolve_Call) had no way of knowing about the
764 -- required dispatching.
766 Propagate_Tag
(Control
, Actual
);
770 ("controlling argument is not dynamically tagged",
776 Next_Actual
(Actual
);
779 -- Mark call as a dispatching call
781 Set_Controlling_Argument
(N
, Control
);
782 Check_Restriction
(No_Dispatching_Calls
, N
);
784 -- The dispatching call may need to be converted into a direct
785 -- call in certain cases.
789 -- If there is a statically tagged actual and a tag-indeterminate
790 -- call to a function of the ancestor (such as that provided by a
791 -- default), then treat this as a dispatching call and propagate
792 -- the tag to the tag-indeterminate call(s).
794 elsif Present
(Static_Tag
) and then Indeterm_Ancestor_Call
then
796 Make_Attribute_Reference
(Loc
,
798 New_Occurrence_Of
(Etype
(Static_Tag
), Loc
),
799 Attribute_Name
=> Name_Tag
);
803 Actual
:= First_Actual
(N
);
804 Formal
:= First_Formal
(Subp_Entity
);
805 while Present
(Actual
) loop
806 if Is_Tag_Indeterminate
(Actual
)
807 and then Is_Controlling_Formal
(Formal
)
809 Propagate_Tag
(Control
, Actual
);
812 Next_Actual
(Actual
);
813 Next_Formal
(Formal
);
816 Check_Dispatching_Context
;
819 -- The call is not dispatching, so check that there aren't any
820 -- tag-indeterminate abstract calls left.
822 Actual
:= First_Actual
(N
);
823 while Present
(Actual
) loop
824 if Is_Tag_Indeterminate
(Actual
) then
826 -- Function call case
828 if Nkind
(Original_Node
(Actual
)) = N_Function_Call
then
829 Func
:= Entity
(Name
(Original_Node
(Actual
)));
831 -- If the actual is an attribute then it can't be abstract
832 -- (the only current case of a tag-indeterminate attribute
833 -- is the stream Input attribute).
835 elsif Nkind
(Original_Node
(Actual
)) = N_Attribute_Reference
839 -- Ditto if it is an explicit dereference.
841 elsif Nkind
(Original_Node
(Actual
)) = N_Explicit_Dereference
845 -- Only other possibility is a qualified expression whose
846 -- constituent expression is itself a call.
850 Entity
(Name
(Original_Node
851 (Expression
(Original_Node
(Actual
)))));
854 if Present
(Func
) and then Is_Abstract_Subprogram
(Func
) then
856 ("call to abstract function must be dispatching", N
);
860 Next_Actual
(Actual
);
863 Check_Dispatching_Context
;
868 -- If dispatching on result, the enclosing call, if any, will
869 -- determine the controlling argument. Otherwise this is the
870 -- primitive operation of the root type.
872 Check_Dispatching_Context
;
874 end Check_Dispatching_Call
;
876 ---------------------------------
877 -- Check_Dispatching_Operation --
878 ---------------------------------
880 procedure Check_Dispatching_Operation
(Subp
, Old_Subp
: Entity_Id
) is
881 Tagged_Type
: Entity_Id
;
882 Has_Dispatching_Parent
: Boolean := False;
883 Body_Is_Last_Primitive
: Boolean := False;
884 Ovr_Subp
: Entity_Id
:= Empty
;
887 if not Ekind_In
(Subp
, E_Procedure
, E_Function
) then
891 Set_Is_Dispatching_Operation
(Subp
, False);
892 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
894 -- Ada 2005 (AI-345): Use the corresponding record (if available).
895 -- Required because primitives of concurrent types are attached
896 -- to the corresponding record (not to the concurrent type).
898 if Ada_Version
>= Ada_2005
899 and then Present
(Tagged_Type
)
900 and then Is_Concurrent_Type
(Tagged_Type
)
901 and then Present
(Corresponding_Record_Type
(Tagged_Type
))
903 Tagged_Type
:= Corresponding_Record_Type
(Tagged_Type
);
906 -- (AI-345): The task body procedure is not a primitive of the tagged
909 if Present
(Tagged_Type
)
910 and then Is_Concurrent_Record_Type
(Tagged_Type
)
911 and then Present
(Corresponding_Concurrent_Type
(Tagged_Type
))
912 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Tagged_Type
))
913 and then Subp
= Get_Task_Body_Procedure
914 (Corresponding_Concurrent_Type
(Tagged_Type
))
919 -- If Subp is derived from a dispatching operation then it should
920 -- always be treated as dispatching. In this case various checks
921 -- below will be bypassed. Makes sure that late declarations for
922 -- inherited private subprograms are treated as dispatching, even
923 -- if the associated tagged type is already frozen.
925 Has_Dispatching_Parent
:=
926 Present
(Alias
(Subp
))
927 and then Is_Dispatching_Operation
(Alias
(Subp
));
929 if No
(Tagged_Type
) then
931 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
932 -- with an abstract interface type unless the interface acts as a
933 -- parent type in a derivation. If the interface type is a formal
934 -- type then the operation is not primitive and therefore legal.
941 E
:= First_Entity
(Subp
);
942 while Present
(E
) loop
944 -- For an access parameter, check designated type
946 if Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
then
947 Typ
:= Designated_Type
(Etype
(E
));
952 if Comes_From_Source
(Subp
)
953 and then Is_Interface
(Typ
)
954 and then not Is_Class_Wide_Type
(Typ
)
955 and then not Is_Derived_Type
(Typ
)
956 and then not Is_Generic_Type
(Typ
)
957 and then not In_Instance
959 Error_Msg_N
("??declaration of& is too late!", Subp
);
960 Error_Msg_NE
-- CODEFIX??
961 ("\??spec should appear immediately after declaration "
962 & "of & !", Subp
, Typ
);
969 -- In case of functions check also the result type
971 if Ekind
(Subp
) = E_Function
then
972 if Is_Access_Type
(Etype
(Subp
)) then
973 Typ
:= Designated_Type
(Etype
(Subp
));
978 -- The following should be better commented, especially since
979 -- we just added several new conditions here ???
981 if Comes_From_Source
(Subp
)
982 and then Is_Interface
(Typ
)
983 and then not Is_Class_Wide_Type
(Typ
)
984 and then not Is_Derived_Type
(Typ
)
985 and then not Is_Generic_Type
(Typ
)
986 and then not In_Instance
988 Error_Msg_N
("??declaration of& is too late!", Subp
);
990 ("\??spec should appear immediately after declaration "
991 & "of & !", Subp
, Typ
);
998 -- The subprograms build internally after the freezing point (such as
999 -- init procs, interface thunks, type support subprograms, and Offset
1000 -- to top functions for accessing interface components in variable
1001 -- size tagged types) are not primitives.
1003 elsif Is_Frozen
(Tagged_Type
)
1004 and then not Comes_From_Source
(Subp
)
1005 and then not Has_Dispatching_Parent
1007 -- Complete decoration of internally built subprograms that override
1008 -- a dispatching primitive. These entities correspond with the
1011 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
1012 -- to override functions of nonabstract null extensions. These
1013 -- primitives were added to the list of primitives of the tagged
1014 -- type by Make_Controlling_Function_Wrappers. However, attribute
1015 -- Is_Dispatching_Operation must be set to true.
1017 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
1020 -- 3. Subprograms associated with stream attributes (built by
1021 -- New_Stream_Subprogram)
1023 if Present
(Old_Subp
)
1024 and then Present
(Overridden_Operation
(Subp
))
1025 and then Is_Dispatching_Operation
(Old_Subp
)
1028 ((Ekind
(Subp
) = E_Function
1029 and then Is_Dispatching_Operation
(Old_Subp
)
1030 and then Is_Null_Extension
(Base_Type
(Etype
(Subp
))))
1032 (Ekind
(Subp
) = E_Procedure
1033 and then Is_Dispatching_Operation
(Old_Subp
)
1034 and then Present
(Alias
(Old_Subp
))
1035 and then Is_Null_Interface_Primitive
1036 (Ultimate_Alias
(Old_Subp
)))
1037 or else Get_TSS_Name
(Subp
) = TSS_Stream_Read
1038 or else Get_TSS_Name
(Subp
) = TSS_Stream_Write
);
1040 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1041 Override_Dispatching_Operation
(Tagged_Type
, Old_Subp
, Subp
);
1042 Set_Is_Dispatching_Operation
(Subp
);
1047 -- The operation may be a child unit, whose scope is the defining
1048 -- package, but which is not a primitive operation of the type.
1050 elsif Is_Child_Unit
(Subp
) then
1053 -- If the subprogram is not defined in a package spec, the only case
1054 -- where it can be a dispatching op is when it overrides an operation
1055 -- before the freezing point of the type.
1057 elsif ((not Is_Package_Or_Generic_Package
(Scope
(Subp
)))
1058 or else In_Package_Body
(Scope
(Subp
)))
1059 and then not Has_Dispatching_Parent
1061 if not Comes_From_Source
(Subp
)
1062 or else (Present
(Old_Subp
) and then not Is_Frozen
(Tagged_Type
))
1066 -- If the type is already frozen, the overriding is not allowed
1067 -- except when Old_Subp is not a dispatching operation (which can
1068 -- occur when Old_Subp was inherited by an untagged type). However,
1069 -- a body with no previous spec freezes the type *after* its
1070 -- declaration, and therefore is a legal overriding (unless the type
1071 -- has already been frozen). Only the first such body is legal.
1073 elsif Present
(Old_Subp
)
1074 and then Is_Dispatching_Operation
(Old_Subp
)
1076 if Comes_From_Source
(Subp
)
1078 (Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Body
1079 or else Nkind
(Unit_Declaration_Node
(Subp
)) in N_Body_Stub
)
1082 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1083 Decl_Item
: Node_Id
;
1086 -- ??? The checks here for whether the type has been frozen
1087 -- prior to the new body are not complete. It's not simple
1088 -- to check frozenness at this point since the body has
1089 -- already caused the type to be prematurely frozen in
1090 -- Analyze_Declarations, but we're forced to recheck this
1091 -- here because of the odd rule interpretation that allows
1092 -- the overriding if the type wasn't frozen prior to the
1093 -- body. The freezing action should probably be delayed
1094 -- until after the spec is seen, but that's a tricky
1095 -- change to the delicate freezing code.
1097 -- Look at each declaration following the type up until the
1098 -- new subprogram body. If any of the declarations is a body
1099 -- then the type has been frozen already so the overriding
1100 -- primitive is illegal.
1102 Decl_Item
:= Next
(Parent
(Tagged_Type
));
1103 while Present
(Decl_Item
)
1104 and then (Decl_Item
/= Subp_Body
)
1106 if Comes_From_Source
(Decl_Item
)
1107 and then (Nkind
(Decl_Item
) in N_Proper_Body
1108 or else Nkind
(Decl_Item
) in N_Body_Stub
)
1110 Error_Msg_N
("overriding of& is too late!", Subp
);
1112 ("\spec should appear immediately after the type!",
1120 -- If the subprogram doesn't follow in the list of
1121 -- declarations including the type then the type has
1122 -- definitely been frozen already and the body is illegal.
1124 if No
(Decl_Item
) then
1125 Error_Msg_N
("overriding of& is too late!", Subp
);
1127 ("\spec should appear immediately after the type!",
1130 elsif Is_Frozen
(Subp
) then
1132 -- The subprogram body declares a primitive operation.
1133 -- If the subprogram is already frozen, we must update
1134 -- its dispatching information explicitly here. The
1135 -- information is taken from the overridden subprogram.
1136 -- We must also generate a cross-reference entry because
1137 -- references to other primitives were already created
1138 -- when type was frozen.
1140 Body_Is_Last_Primitive
:= True;
1142 if Present
(DTC_Entity
(Old_Subp
)) then
1143 Set_DTC_Entity
(Subp
, DTC_Entity
(Old_Subp
));
1144 Set_DT_Position_Value
(Subp
, DT_Position
(Old_Subp
));
1146 if not Restriction_Active
(No_Dispatching_Calls
) then
1147 if Building_Static_DT
(Tagged_Type
) then
1149 -- If the static dispatch table has not been
1150 -- built then there is nothing else to do now;
1151 -- otherwise we notify that we cannot build the
1152 -- static dispatch table.
1154 if Has_Dispatch_Table
(Tagged_Type
) then
1156 ("overriding of& is too late for building "
1157 & " static dispatch tables!", Subp
);
1159 ("\spec should appear immediately after "
1160 & "the type!", Subp
);
1163 -- No code required to register primitives in VM
1166 elsif not Tagged_Type_Expansion
then
1170 Insert_Actions_After
(Subp_Body
,
1171 Register_Primitive
(Sloc
(Subp_Body
),
1175 -- Indicate that this is an overriding operation,
1176 -- and replace the overridden entry in the list of
1177 -- primitive operations, which is used for xref
1178 -- generation subsequently.
1180 Generate_Reference
(Tagged_Type
, Subp
, 'P', False);
1181 Override_Dispatching_Operation
1182 (Tagged_Type
, Old_Subp
, Subp
);
1189 Error_Msg_N
("overriding of& is too late!", Subp
);
1191 ("\subprogram spec should appear immediately after the type!",
1195 -- If the type is not frozen yet and we are not in the overriding
1196 -- case it looks suspiciously like an attempt to define a primitive
1197 -- operation, which requires the declaration to be in a package spec
1198 -- (3.2.3(6)). Only report cases where the type and subprogram are
1199 -- in the same declaration list (by checking the enclosing parent
1200 -- declarations), to avoid spurious warnings on subprograms in
1201 -- instance bodies when the type is declared in the instance spec
1202 -- but hasn't been frozen by the instance body.
1204 elsif not Is_Frozen
(Tagged_Type
)
1205 and then In_Same_List
(Parent
(Tagged_Type
), Parent
(Parent
(Subp
)))
1208 ("??not dispatching (must be defined in a package spec)", Subp
);
1211 -- When the type is frozen, it is legitimate to define a new
1212 -- non-primitive operation.
1218 -- Now, we are sure that the scope is a package spec. If the subprogram
1219 -- is declared after the freezing point of the type that's an error
1221 elsif Is_Frozen
(Tagged_Type
) and then not Has_Dispatching_Parent
then
1222 Error_Msg_N
("this primitive operation is declared too late", Subp
);
1224 ("??no primitive operations for& after this line",
1225 Freeze_Node
(Tagged_Type
),
1230 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1232 Ovr_Subp
:= Old_Subp
;
1234 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1235 -- overridden by Subp. This only applies to source subprograms, and
1236 -- their declaration must carry an explicit overriding indicator.
1239 and then Ada_Version
>= Ada_2012
1240 and then Comes_From_Source
(Subp
)
1242 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1244 Ovr_Subp
:= Find_Hidden_Overridden_Primitive
(Subp
);
1246 -- Verify that the proper overriding indicator has been supplied.
1248 if Present
(Ovr_Subp
)
1250 not Must_Override
(Specification
(Unit_Declaration_Node
(Subp
)))
1252 Error_Msg_NE
("missing overriding indicator for&", Subp
, Subp
);
1256 -- Now it should be a correct primitive operation, put it in the list
1258 if Present
(Ovr_Subp
) then
1260 -- If the type has interfaces we complete this check after we set
1261 -- attribute Is_Dispatching_Operation.
1263 Check_Subtype_Conformant
(Subp
, Ovr_Subp
);
1265 -- A primitive operation with the name of a primitive controlled
1266 -- operation does not override a non-visible overriding controlled
1267 -- operation, i.e. one declared in a private part when the full
1268 -- view of a type is controlled. Conversely, it will override a
1269 -- visible operation that may be declared in a partial view when
1270 -- the full view is controlled.
1272 if Nam_In
(Chars
(Subp
), Name_Initialize
, Name_Adjust
, Name_Finalize
)
1273 and then Is_Controlled
(Tagged_Type
)
1274 and then not Is_Visibly_Controlled
(Tagged_Type
)
1275 and then not Is_Inherited_Public_Operation
(Ovr_Subp
)
1277 Set_Overridden_Operation
(Subp
, Empty
);
1279 -- If the subprogram specification carries an overriding
1280 -- indicator, no need for the warning: it is either redundant,
1281 -- or else an error will be reported.
1283 if Nkind
(Parent
(Subp
)) = N_Procedure_Specification
1285 (Must_Override
(Parent
(Subp
))
1286 or else Must_Not_Override
(Parent
(Subp
)))
1290 -- Here we need the warning
1294 ("operation does not override inherited&??", Subp
, Subp
);
1298 Override_Dispatching_Operation
(Tagged_Type
, Ovr_Subp
, Subp
);
1300 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1301 -- that covers abstract interface subprograms we must register it
1302 -- in all the secondary dispatch tables associated with abstract
1303 -- interfaces. We do this now only if not building static tables,
1304 -- nor when the expander is inactive (we avoid trying to register
1305 -- primitives in semantics-only mode, since the type may not have
1306 -- an associated dispatch table). Otherwise the patch code is
1307 -- emitted after those tables are built, to prevent access before
1308 -- elaboration in gigi.
1310 if Body_Is_Last_Primitive
and then Expander_Active
then
1312 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1317 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1318 while Present
(Elmt
) loop
1319 Prim
:= Node
(Elmt
);
1321 -- No code required to register primitives in VM targets
1323 if Present
(Alias
(Prim
))
1324 and then Present
(Interface_Alias
(Prim
))
1325 and then Alias
(Prim
) = Subp
1326 and then not Building_Static_DT
(Tagged_Type
)
1327 and then Tagged_Type_Expansion
1329 Insert_Actions_After
(Subp_Body
,
1330 Register_Primitive
(Sloc
(Subp_Body
), Prim
=> Prim
));
1336 -- Redisplay the contents of the updated dispatch table
1338 if Debug_Flag_ZZ
then
1339 Write_Str
("Late overriding: ");
1340 Write_DT
(Tagged_Type
);
1346 -- If the tagged type is a concurrent type then we must be compiling
1347 -- with no code generation (we are either compiling a generic unit or
1348 -- compiling under -gnatc mode) because we have previously tested that
1349 -- no serious errors has been reported. In this case we do not add the
1350 -- primitive to the list of primitives of Tagged_Type but we leave the
1351 -- primitive decorated as a dispatching operation to be able to analyze
1352 -- and report errors associated with the Object.Operation notation.
1354 elsif Is_Concurrent_Type
(Tagged_Type
) then
1355 pragma Assert
(not Expander_Active
);
1357 -- Attach operation to list of primitives of the synchronized type
1358 -- itself, for ASIS use.
1360 Append_Elmt
(Subp
, Direct_Primitive_Operations
(Tagged_Type
));
1362 -- If no old subprogram, then we add this as a dispatching operation,
1363 -- but we avoid doing this if an error was posted, to prevent annoying
1366 elsif not Error_Posted
(Subp
) then
1367 Add_Dispatching_Operation
(Tagged_Type
, Subp
);
1370 Set_Is_Dispatching_Operation
(Subp
, True);
1372 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1373 -- subtype conformance against all the interfaces covered by this
1376 if Present
(Ovr_Subp
)
1377 and then Has_Interfaces
(Tagged_Type
)
1380 Ifaces_List
: Elist_Id
;
1381 Iface_Elmt
: Elmt_Id
;
1382 Iface_Prim_Elmt
: Elmt_Id
;
1383 Iface_Prim
: Entity_Id
;
1384 Ret_Typ
: Entity_Id
;
1387 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
1389 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1390 while Present
(Iface_Elmt
) loop
1391 if not Is_Ancestor
(Node
(Iface_Elmt
), Tagged_Type
) then
1393 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
1394 while Present
(Iface_Prim_Elmt
) loop
1395 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
1397 if Is_Interface_Conformant
1398 (Tagged_Type
, Iface_Prim
, Subp
)
1400 -- Handle procedures, functions whose return type
1401 -- matches, or functions not returning interfaces
1403 if Ekind
(Subp
) = E_Procedure
1404 or else Etype
(Iface_Prim
) = Etype
(Subp
)
1405 or else not Is_Interface
(Etype
(Iface_Prim
))
1407 Check_Subtype_Conformant
1409 Old_Id
=> Iface_Prim
,
1411 Skip_Controlling_Formals
=> True);
1413 -- Handle functions returning interfaces
1415 elsif Implements_Interface
1416 (Etype
(Subp
), Etype
(Iface_Prim
))
1418 -- Temporarily force both entities to return the
1419 -- same type. Required because Subtype_Conformant
1420 -- does not handle this case.
1422 Ret_Typ
:= Etype
(Iface_Prim
);
1423 Set_Etype
(Iface_Prim
, Etype
(Subp
));
1425 Check_Subtype_Conformant
1427 Old_Id
=> Iface_Prim
,
1429 Skip_Controlling_Formals
=> True);
1431 Set_Etype
(Iface_Prim
, Ret_Typ
);
1435 Next_Elmt
(Iface_Prim_Elmt
);
1439 Next_Elmt
(Iface_Elmt
);
1444 if not Body_Is_Last_Primitive
then
1445 Set_DT_Position_Value
(Subp
, No_Uint
);
1447 elsif Has_Controlled_Component
(Tagged_Type
)
1448 and then Nam_In
(Chars
(Subp
), Name_Initialize
,
1451 Name_Finalize_Address
)
1454 F_Node
: constant Node_Id
:= Freeze_Node
(Tagged_Type
);
1458 Old_Spec
: Entity_Id
;
1460 C_Names
: constant array (1 .. 4) of Name_Id
:=
1464 Name_Finalize_Address
);
1466 D_Names
: constant array (1 .. 4) of TSS_Name_Type
:=
1467 (TSS_Deep_Initialize
,
1470 TSS_Finalize_Address
);
1473 -- Remove previous controlled function which was constructed and
1474 -- analyzed when the type was frozen. This requires removing the
1475 -- body of the redefined primitive, as well as its specification
1476 -- if needed (there is no spec created for Deep_Initialize, see
1477 -- exp_ch3.adb). We must also dismantle the exception information
1478 -- that may have been generated for it when front end zero-cost
1479 -- tables are enabled.
1481 for J
in D_Names
'Range loop
1482 Old_P
:= TSS
(Tagged_Type
, D_Names
(J
));
1485 and then Chars
(Subp
) = C_Names
(J
)
1487 Old_Bod
:= Unit_Declaration_Node
(Old_P
);
1489 Set_Is_Eliminated
(Old_P
);
1490 Set_Scope
(Old_P
, Scope
(Current_Scope
));
1492 if Nkind
(Old_Bod
) = N_Subprogram_Body
1493 and then Present
(Corresponding_Spec
(Old_Bod
))
1495 Old_Spec
:= Corresponding_Spec
(Old_Bod
);
1496 Set_Has_Completion
(Old_Spec
, False);
1501 Build_Late_Proc
(Tagged_Type
, Chars
(Subp
));
1503 -- The new operation is added to the actions of the freeze node
1504 -- for the type, but this node has already been analyzed, so we
1505 -- must retrieve and analyze explicitly the new body.
1508 and then Present
(Actions
(F_Node
))
1510 Decl
:= Last
(Actions
(F_Node
));
1515 end Check_Dispatching_Operation
;
1517 ------------------------------------------
1518 -- Check_Operation_From_Incomplete_Type --
1519 ------------------------------------------
1521 procedure Check_Operation_From_Incomplete_Type
1525 Full
: constant Entity_Id
:= Full_View
(Typ
);
1526 Parent_Typ
: constant Entity_Id
:= Etype
(Full
);
1527 Old_Prim
: constant Elist_Id
:= Primitive_Operations
(Parent_Typ
);
1528 New_Prim
: constant Elist_Id
:= Primitive_Operations
(Full
);
1530 Prev
: Elmt_Id
:= No_Elmt
;
1532 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean;
1533 -- Check that Subp has profile of an operation derived from Parent_Subp.
1534 -- Subp must have a parameter or result type that is Typ or an access
1535 -- parameter or access result type that designates Typ.
1541 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean is
1545 if Chars
(Parent_Subp
) /= Chars
(Subp
) then
1549 -- Check that the type of controlling formals is derived from the
1550 -- parent subprogram's controlling formal type (or designated type
1551 -- if the formal type is an anonymous access type).
1553 F1
:= First_Formal
(Parent_Subp
);
1554 F2
:= First_Formal
(Subp
);
1555 while Present
(F1
) and then Present
(F2
) loop
1556 if Ekind
(Etype
(F1
)) = E_Anonymous_Access_Type
then
1557 if Ekind
(Etype
(F2
)) /= E_Anonymous_Access_Type
then
1559 elsif Designated_Type
(Etype
(F1
)) = Parent_Typ
1560 and then Designated_Type
(Etype
(F2
)) /= Full
1565 elsif Ekind
(Etype
(F2
)) = E_Anonymous_Access_Type
then
1568 elsif Etype
(F1
) = Parent_Typ
and then Etype
(F2
) /= Full
then
1576 -- Check that a controlling result type is derived from the parent
1577 -- subprogram's result type (or designated type if the result type
1578 -- is an anonymous access type).
1580 if Ekind
(Parent_Subp
) = E_Function
then
1581 if Ekind
(Subp
) /= E_Function
then
1584 elsif Ekind
(Etype
(Parent_Subp
)) = E_Anonymous_Access_Type
then
1585 if Ekind
(Etype
(Subp
)) /= E_Anonymous_Access_Type
then
1588 elsif Designated_Type
(Etype
(Parent_Subp
)) = Parent_Typ
1589 and then Designated_Type
(Etype
(Subp
)) /= Full
1594 elsif Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
then
1597 elsif Etype
(Parent_Subp
) = Parent_Typ
1598 and then Etype
(Subp
) /= Full
1603 elsif Ekind
(Subp
) = E_Function
then
1607 return No
(F1
) and then No
(F2
);
1610 -- Start of processing for Check_Operation_From_Incomplete_Type
1613 -- The operation may override an inherited one, or may be a new one
1614 -- altogether. The inherited operation will have been hidden by the
1615 -- current one at the point of the type derivation, so it does not
1616 -- appear in the list of primitive operations of the type. We have to
1617 -- find the proper place of insertion in the list of primitive opera-
1618 -- tions by iterating over the list for the parent type.
1620 Op1
:= First_Elmt
(Old_Prim
);
1621 Op2
:= First_Elmt
(New_Prim
);
1622 while Present
(Op1
) and then Present
(Op2
) loop
1623 if Derives_From
(Node
(Op1
)) then
1626 -- Avoid adding it to the list of primitives if already there
1628 if Node
(Op2
) /= Subp
then
1629 Prepend_Elmt
(Subp
, New_Prim
);
1633 Insert_Elmt_After
(Subp
, Prev
);
1644 -- Operation is a new primitive
1646 Append_Elmt
(Subp
, New_Prim
);
1647 end Check_Operation_From_Incomplete_Type
;
1649 ---------------------------------------
1650 -- Check_Operation_From_Private_View --
1651 ---------------------------------------
1653 procedure Check_Operation_From_Private_View
(Subp
, Old_Subp
: Entity_Id
) is
1654 Tagged_Type
: Entity_Id
;
1657 if Is_Dispatching_Operation
(Alias
(Subp
)) then
1658 Set_Scope
(Subp
, Current_Scope
);
1659 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1661 -- Add Old_Subp to primitive operations if not already present
1663 if Present
(Tagged_Type
) and then Is_Tagged_Type
(Tagged_Type
) then
1664 Append_Unique_Elmt
(Old_Subp
, Primitive_Operations
(Tagged_Type
));
1666 -- If Old_Subp isn't already marked as dispatching then this is
1667 -- the case of an operation of an untagged private type fulfilled
1668 -- by a tagged type that overrides an inherited dispatching
1669 -- operation, so we set the necessary dispatching attributes here.
1671 if not Is_Dispatching_Operation
(Old_Subp
) then
1673 -- If the untagged type has no discriminants, and the full
1674 -- view is constrained, there will be a spurious mismatch of
1675 -- subtypes on the controlling arguments, because the tagged
1676 -- type is the internal base type introduced in the derivation.
1677 -- Use the original type to verify conformance, rather than the
1680 if not Comes_From_Source
(Tagged_Type
)
1681 and then Has_Discriminants
(Tagged_Type
)
1687 Formal
:= First_Formal
(Old_Subp
);
1688 while Present
(Formal
) loop
1689 if Tagged_Type
= Base_Type
(Etype
(Formal
)) then
1690 Tagged_Type
:= Etype
(Formal
);
1693 Next_Formal
(Formal
);
1697 if Tagged_Type
= Base_Type
(Etype
(Old_Subp
)) then
1698 Tagged_Type
:= Etype
(Old_Subp
);
1702 Check_Controlling_Formals
(Tagged_Type
, Old_Subp
);
1703 Set_Is_Dispatching_Operation
(Old_Subp
, True);
1704 Set_DT_Position_Value
(Old_Subp
, No_Uint
);
1707 -- If the old subprogram is an explicit renaming of some other
1708 -- entity, it is not overridden by the inherited subprogram.
1709 -- Otherwise, update its alias and other attributes.
1711 if Present
(Alias
(Old_Subp
))
1712 and then Nkind
(Unit_Declaration_Node
(Old_Subp
)) /=
1713 N_Subprogram_Renaming_Declaration
1715 Set_Alias
(Old_Subp
, Alias
(Subp
));
1717 -- The derived subprogram should inherit the abstractness of
1718 -- the parent subprogram (except in the case of a function
1719 -- returning the type). This sets the abstractness properly
1720 -- for cases where a private extension may have inherited an
1721 -- abstract operation, but the full type is derived from a
1722 -- descendant type and inherits a nonabstract version.
1724 if Etype
(Subp
) /= Tagged_Type
then
1725 Set_Is_Abstract_Subprogram
1726 (Old_Subp
, Is_Abstract_Subprogram
(Alias
(Subp
)));
1731 end Check_Operation_From_Private_View
;
1733 --------------------------
1734 -- Find_Controlling_Arg --
1735 --------------------------
1737 function Find_Controlling_Arg
(N
: Node_Id
) return Node_Id
is
1738 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
1742 if Nkind
(Orig_Node
) = N_Qualified_Expression
then
1743 return Find_Controlling_Arg
(Expression
(Orig_Node
));
1746 -- Dispatching on result case. If expansion is disabled, the node still
1747 -- has the structure of a function call. However, if the function name
1748 -- is an operator and the call was given in infix form, the original
1749 -- node has no controlling result and we must examine the current node.
1751 if Nkind
(N
) = N_Function_Call
1752 and then Present
(Controlling_Argument
(N
))
1753 and then Has_Controlling_Result
(Entity
(Name
(N
)))
1755 return Controlling_Argument
(N
);
1757 -- If expansion is enabled, the call may have been transformed into
1758 -- an indirect call, and we need to recover the original node.
1760 elsif Nkind
(Orig_Node
) = N_Function_Call
1761 and then Present
(Controlling_Argument
(Orig_Node
))
1762 and then Has_Controlling_Result
(Entity
(Name
(Orig_Node
)))
1764 return Controlling_Argument
(Orig_Node
);
1766 -- Type conversions are dynamically tagged if the target type, or its
1767 -- designated type, are classwide. An interface conversion expands into
1768 -- a dereference, so test must be performed on the original node.
1770 elsif Nkind
(Orig_Node
) = N_Type_Conversion
1771 and then Nkind
(N
) = N_Explicit_Dereference
1772 and then Is_Controlling_Actual
(N
)
1775 Target_Type
: constant Entity_Id
:=
1776 Entity
(Subtype_Mark
(Orig_Node
));
1779 if Is_Class_Wide_Type
(Target_Type
) then
1782 elsif Is_Access_Type
(Target_Type
)
1783 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
1794 elsif Is_Controlling_Actual
(N
)
1796 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1797 and then Is_Controlling_Actual
(Parent
(N
)))
1801 if Is_Access_Type
(Typ
) then
1803 -- In the case of an Access attribute, use the type of the prefix,
1804 -- since in the case of an actual for an access parameter, the
1805 -- attribute's type may be of a specific designated type, even
1806 -- though the prefix type is class-wide.
1808 if Nkind
(N
) = N_Attribute_Reference
then
1809 Typ
:= Etype
(Prefix
(N
));
1811 -- An allocator is dispatching if the type of qualified expression
1812 -- is class_wide, in which case this is the controlling type.
1814 elsif Nkind
(Orig_Node
) = N_Allocator
1815 and then Nkind
(Expression
(Orig_Node
)) = N_Qualified_Expression
1817 Typ
:= Etype
(Expression
(Orig_Node
));
1819 Typ
:= Designated_Type
(Typ
);
1823 if Is_Class_Wide_Type
(Typ
)
1825 (Nkind
(Parent
(N
)) = N_Qualified_Expression
1826 and then Is_Access_Type
(Etype
(N
))
1827 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(N
))))
1834 end Find_Controlling_Arg
;
1836 ---------------------------
1837 -- Find_Dispatching_Type --
1838 ---------------------------
1840 function Find_Dispatching_Type
(Subp
: Entity_Id
) return Entity_Id
is
1841 A_Formal
: Entity_Id
;
1843 Ctrl_Type
: Entity_Id
;
1846 if Ekind_In
(Subp
, E_Function
, E_Procedure
)
1847 and then Present
(DTC_Entity
(Subp
))
1849 return Scope
(DTC_Entity
(Subp
));
1851 -- For subprograms internally generated by derivations of tagged types
1852 -- use the alias subprogram as a reference to locate the dispatching
1855 elsif not Comes_From_Source
(Subp
)
1856 and then Present
(Alias
(Subp
))
1857 and then Is_Dispatching_Operation
(Alias
(Subp
))
1859 if Ekind
(Alias
(Subp
)) = E_Function
1860 and then Has_Controlling_Result
(Alias
(Subp
))
1862 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
1865 Formal
:= First_Formal
(Subp
);
1866 A_Formal
:= First_Formal
(Alias
(Subp
));
1867 while Present
(A_Formal
) loop
1868 if Is_Controlling_Formal
(A_Formal
) then
1869 return Check_Controlling_Type
(Etype
(Formal
), Subp
);
1872 Next_Formal
(Formal
);
1873 Next_Formal
(A_Formal
);
1876 pragma Assert
(False);
1883 Formal
:= First_Formal
(Subp
);
1884 while Present
(Formal
) loop
1885 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
1887 if Present
(Ctrl_Type
) then
1891 Next_Formal
(Formal
);
1894 -- The subprogram may also be dispatching on result
1896 if Present
(Etype
(Subp
)) then
1897 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
1901 pragma Assert
(not Is_Dispatching_Operation
(Subp
));
1903 end Find_Dispatching_Type
;
1905 --------------------------------------
1906 -- Find_Hidden_Overridden_Primitive --
1907 --------------------------------------
1909 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
1911 Tag_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
1913 Orig_Prim
: Entity_Id
;
1915 Vis_List
: Elist_Id
;
1918 -- This Ada 2012 rule applies only for type extensions or private
1919 -- extensions, where the parent type is not in a parent unit, and
1920 -- where an operation is never declared but still inherited.
1923 or else not Is_Record_Type
(Tag_Typ
)
1924 or else Etype
(Tag_Typ
) = Tag_Typ
1925 or else In_Open_Scopes
(Scope
(Etype
(Tag_Typ
)))
1930 -- Collect the list of visible ancestor of the tagged type
1932 Vis_List
:= Visible_Ancestors
(Tag_Typ
);
1934 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
1935 while Present
(Elmt
) loop
1936 Prim
:= Node
(Elmt
);
1938 -- Find an inherited hidden dispatching primitive with the name of S
1939 -- and a type-conformant profile.
1941 if Present
(Alias
(Prim
))
1942 and then Is_Hidden
(Alias
(Prim
))
1943 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Tag_Typ
1944 and then Primitive_Names_Match
(S
, Prim
)
1945 and then Type_Conformant
(S
, Prim
)
1948 Vis_Ancestor
: Elmt_Id
;
1952 -- The original corresponding operation of Prim must be an
1953 -- operation of a visible ancestor of the dispatching type S,
1954 -- and the original corresponding operation of S2 must be
1957 Orig_Prim
:= Original_Corresponding_Operation
(Prim
);
1959 if Orig_Prim
/= Prim
1960 and then Is_Immediately_Visible
(Orig_Prim
)
1962 Vis_Ancestor
:= First_Elmt
(Vis_List
);
1963 while Present
(Vis_Ancestor
) loop
1965 First_Elmt
(Primitive_Operations
(Node
(Vis_Ancestor
)));
1966 while Present
(Elmt
) loop
1967 if Node
(Elmt
) = Orig_Prim
then
1968 Set_Overridden_Operation
(S
, Prim
);
1969 Set_Alias
(Prim
, Orig_Prim
);
1976 Next_Elmt
(Vis_Ancestor
);
1986 end Find_Hidden_Overridden_Primitive
;
1988 ---------------------------------------
1989 -- Find_Primitive_Covering_Interface --
1990 ---------------------------------------
1992 function Find_Primitive_Covering_Interface
1993 (Tagged_Type
: Entity_Id
;
1994 Iface_Prim
: Entity_Id
) return Entity_Id
2000 pragma Assert
(Is_Interface
(Find_Dispatching_Type
(Iface_Prim
))
2001 or else (Present
(Alias
(Iface_Prim
))
2004 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
2006 -- Search in the homonym chain. Done to speed up locating visible
2007 -- entities and required to catch primitives associated with the partial
2008 -- view of private types when processing the corresponding full view.
2010 E
:= Current_Entity
(Iface_Prim
);
2011 while Present
(E
) loop
2012 if Is_Subprogram
(E
)
2013 and then Is_Dispatching_Operation
(E
)
2014 and then Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
)
2022 -- Search in the list of primitives of the type. Required to locate
2023 -- the covering primitive if the covering primitive is not visible
2024 -- (for example, non-visible inherited primitive of private type).
2026 El
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2027 while Present
(El
) loop
2030 -- Keep separate the management of internal entities that link
2031 -- primitives with interface primitives from tagged type primitives.
2033 if No
(Interface_Alias
(E
)) then
2034 if Present
(Alias
(E
)) then
2036 -- This interface primitive has not been covered yet
2038 if Alias
(E
) = Iface_Prim
then
2041 -- The covering primitive was inherited
2043 elsif Overridden_Operation
(Ultimate_Alias
(E
))
2050 -- Check if E covers the interface primitive (includes case in
2051 -- which E is an inherited private primitive).
2053 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2057 -- Use the internal entity that links the interface primitive with
2058 -- the covering primitive to locate the entity.
2060 elsif Interface_Alias
(E
) = Iface_Prim
then
2070 end Find_Primitive_Covering_Interface
;
2072 ---------------------------
2073 -- Inherited_Subprograms --
2074 ---------------------------
2076 function Inherited_Subprograms
2078 No_Interfaces
: Boolean := False;
2079 Interfaces_Only
: Boolean := False;
2080 One_Only
: Boolean := False) return Subprogram_List
2082 Result
: Subprogram_List
(1 .. 6000);
2083 -- 6000 here is intended to be infinity. We could use an expandable
2084 -- table, but it would be awfully heavy, and there is no way that we
2085 -- could reasonably exceed this value.
2088 -- Number of entries in Result
2090 Parent_Op
: Entity_Id
;
2091 -- Traverses the Overridden_Operation chain
2093 procedure Store_IS
(E
: Entity_Id
);
2094 -- Stores E in Result if not already stored
2100 procedure Store_IS
(E
: Entity_Id
) is
2102 for J
in 1 .. N
loop
2103 if E
= Result
(J
) then
2112 -- Start of processing for Inherited_Subprograms
2115 pragma Assert
(not (No_Interfaces
and Interfaces_Only
));
2117 if Present
(S
) and then Is_Dispatching_Operation
(S
) then
2119 -- Deal with direct inheritance
2121 if not Interfaces_Only
then
2124 Parent_Op
:= Overridden_Operation
(Parent_Op
);
2125 exit when No
(Parent_Op
)
2129 Is_Interface
(Find_Dispatching_Type
(Parent_Op
)));
2131 if Is_Subprogram_Or_Generic_Subprogram
(Parent_Op
) then
2132 Store_IS
(Parent_Op
);
2141 -- Now deal with interfaces
2143 if not No_Interfaces
then
2145 Tag_Typ
: Entity_Id
;
2150 Tag_Typ
:= Find_Dispatching_Type
(S
);
2152 -- In the presence of limited views there may be no visible
2153 -- dispatching type. Primitives will be inherited when non-
2154 -- limited view is frozen.
2156 if No
(Tag_Typ
) then
2157 return Result
(1 .. 0);
2160 if Is_Concurrent_Type
(Tag_Typ
) then
2161 Tag_Typ
:= Corresponding_Record_Type
(Tag_Typ
);
2164 -- Search primitive operations of dispatching type
2166 if Present
(Tag_Typ
)
2167 and then Present
(Primitive_Operations
(Tag_Typ
))
2169 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2170 while Present
(Elmt
) loop
2171 Prim
:= Node
(Elmt
);
2173 -- The following test eliminates some odd cases in which
2174 -- Ekind (Prim) is Void, to be investigated further ???
2176 if not Is_Subprogram_Or_Generic_Subprogram
(Prim
) then
2179 -- For [generic] subprogram, look at interface alias
2181 elsif Present
(Interface_Alias
(Prim
))
2182 and then Alias
(Prim
) = S
2184 -- We have found a primitive covered by S
2186 Store_IS
(Interface_Alias
(Prim
));
2202 return Result
(1 .. N
);
2203 end Inherited_Subprograms
;
2205 ---------------------------
2206 -- Is_Dynamically_Tagged --
2207 ---------------------------
2209 function Is_Dynamically_Tagged
(N
: Node_Id
) return Boolean is
2211 if Nkind
(N
) = N_Error
then
2214 elsif Present
(Find_Controlling_Arg
(N
)) then
2217 -- Special cases: entities, and calls that dispatch on result
2219 elsif Is_Entity_Name
(N
) then
2220 return Is_Class_Wide_Type
(Etype
(N
));
2222 elsif Nkind
(N
) = N_Function_Call
2223 and then Is_Class_Wide_Type
(Etype
(N
))
2227 -- Otherwise check whether call has controlling argument
2232 end Is_Dynamically_Tagged
;
2234 ---------------------------------
2235 -- Is_Null_Interface_Primitive --
2236 ---------------------------------
2238 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2240 return Comes_From_Source
(E
)
2241 and then Is_Dispatching_Operation
(E
)
2242 and then Ekind
(E
) = E_Procedure
2243 and then Null_Present
(Parent
(E
))
2244 and then Is_Interface
(Find_Dispatching_Type
(E
));
2245 end Is_Null_Interface_Primitive
;
2247 -----------------------------------
2248 -- Is_Inherited_Public_Operation --
2249 -----------------------------------
2251 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean is
2252 Prim
: constant Entity_Id
:= Alias
(Op
);
2253 Scop
: constant Entity_Id
:= Scope
(Prim
);
2254 Pack_Decl
: Node_Id
;
2257 if Comes_From_Source
(Prim
) and then Ekind
(Scop
) = E_Package
then
2258 Pack_Decl
:= Unit_Declaration_Node
(Scop
);
2259 return Nkind
(Pack_Decl
) = N_Package_Declaration
2260 and then List_Containing
(Unit_Declaration_Node
(Prim
)) =
2261 Visible_Declarations
(Specification
(Pack_Decl
));
2266 end Is_Inherited_Public_Operation
;
2268 ------------------------------
2269 -- Is_Overriding_Subprogram --
2270 ------------------------------
2272 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean is
2273 Inherited
: constant Subprogram_List
:=
2274 Inherited_Subprograms
(E
, One_Only
=> True);
2276 return Inherited
'Length > 0;
2277 end Is_Overriding_Subprogram
;
2279 --------------------------
2280 -- Is_Tag_Indeterminate --
2281 --------------------------
2283 function Is_Tag_Indeterminate
(N
: Node_Id
) return Boolean is
2286 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2289 if Nkind
(Orig_Node
) = N_Function_Call
2290 and then Is_Entity_Name
(Name
(Orig_Node
))
2292 Nam
:= Entity
(Name
(Orig_Node
));
2294 if not Has_Controlling_Result
(Nam
) then
2297 -- The function may have a controlling result, but if the return type
2298 -- is not visibly tagged, then this is not tag-indeterminate.
2300 elsif Is_Access_Type
(Etype
(Nam
))
2301 and then not Is_Tagged_Type
(Designated_Type
(Etype
(Nam
)))
2305 -- An explicit dereference means that the call has already been
2306 -- expanded and there is no tag to propagate.
2308 elsif Nkind
(N
) = N_Explicit_Dereference
then
2311 -- If there are no actuals, the call is tag-indeterminate
2313 elsif No
(Parameter_Associations
(Orig_Node
)) then
2317 Actual
:= First_Actual
(Orig_Node
);
2318 while Present
(Actual
) loop
2319 if Is_Controlling_Actual
(Actual
)
2320 and then not Is_Tag_Indeterminate
(Actual
)
2322 -- One operand is dispatching
2327 Next_Actual
(Actual
);
2333 elsif Nkind
(Orig_Node
) = N_Qualified_Expression
then
2334 return Is_Tag_Indeterminate
(Expression
(Orig_Node
));
2336 -- Case of a call to the Input attribute (possibly rewritten), which is
2337 -- always tag-indeterminate except when its prefix is a Class attribute.
2339 elsif Nkind
(Orig_Node
) = N_Attribute_Reference
2341 Get_Attribute_Id
(Attribute_Name
(Orig_Node
)) = Attribute_Input
2342 and then Nkind
(Prefix
(Orig_Node
)) /= N_Attribute_Reference
2346 -- In Ada 2005, a function that returns an anonymous access type can be
2347 -- dispatching, and the dereference of a call to such a function can
2348 -- also be tag-indeterminate if the call itself is.
2350 elsif Nkind
(Orig_Node
) = N_Explicit_Dereference
2351 and then Ada_Version
>= Ada_2005
2353 return Is_Tag_Indeterminate
(Prefix
(Orig_Node
));
2358 end Is_Tag_Indeterminate
;
2360 ------------------------------------
2361 -- Override_Dispatching_Operation --
2362 ------------------------------------
2364 procedure Override_Dispatching_Operation
2365 (Tagged_Type
: Entity_Id
;
2366 Prev_Op
: Entity_Id
;
2368 Is_Wrapper
: Boolean := False)
2374 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
2375 -- we do it unconditionally in Ada 95 now, since this is our pragma).
2377 if No_Return
(Prev_Op
) and then not No_Return
(New_Op
) then
2378 Error_Msg_N
("procedure & must have No_Return pragma", New_Op
);
2379 Error_Msg_N
("\since overridden procedure has No_Return", New_Op
);
2382 -- If there is no previous operation to override, the type declaration
2383 -- was malformed, and an error must have been emitted already.
2385 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2386 while Present
(Elmt
) and then Node
(Elmt
) /= Prev_Op
loop
2394 -- The location of entities that come from source in the list of
2395 -- primitives of the tagged type must follow their order of occurrence
2396 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
2397 -- primitive of an interface that is not implemented by the parents of
2398 -- this tagged type (that is, it is an alias of an interface primitive
2399 -- generated by Derive_Interface_Progenitors), then we must append the
2400 -- new entity at the end of the list of primitives.
2402 if Present
(Alias
(Prev_Op
))
2403 and then Etype
(Tagged_Type
) /= Tagged_Type
2404 and then Is_Interface
(Find_Dispatching_Type
(Alias
(Prev_Op
)))
2405 and then not Is_Ancestor
(Find_Dispatching_Type
(Alias
(Prev_Op
)),
2406 Tagged_Type
, Use_Full_View
=> True)
2407 and then not Implements_Interface
2408 (Etype
(Tagged_Type
),
2409 Find_Dispatching_Type
(Alias
(Prev_Op
)))
2411 Remove_Elmt
(Primitive_Operations
(Tagged_Type
), Elmt
);
2412 Append_Elmt
(New_Op
, Primitive_Operations
(Tagged_Type
));
2414 -- The new primitive replaces the overridden entity. Required to ensure
2415 -- that overriding primitive is assigned the same dispatch table slot.
2418 Replace_Elmt
(Elmt
, New_Op
);
2421 if Ada_Version
>= Ada_2005
and then Has_Interfaces
(Tagged_Type
) then
2423 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
2424 -- entities of the overridden primitive to reference New_Op, and
2425 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
2426 -- that the new operation is subtype conformant with the interface
2427 -- operations that it implements (for operations inherited from the
2428 -- parent itself, this check is made when building the derived type).
2430 -- Note: This code is executed with internally generated wrappers of
2431 -- functions with controlling result and late overridings.
2433 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2434 while Present
(Elmt
) loop
2435 Prim
:= Node
(Elmt
);
2437 if Prim
= New_Op
then
2440 -- Note: The check on Is_Subprogram protects the frontend against
2441 -- reading attributes in entities that are not yet fully decorated
2443 elsif Is_Subprogram
(Prim
)
2444 and then Present
(Interface_Alias
(Prim
))
2445 and then Alias
(Prim
) = Prev_Op
2447 Set_Alias
(Prim
, New_Op
);
2449 -- No further decoration needed yet for internally generated
2450 -- wrappers of controlling functions since (at this stage)
2451 -- they are not yet decorated.
2453 if not Is_Wrapper
then
2454 Check_Subtype_Conformant
(New_Op
, Prim
);
2456 Set_Is_Abstract_Subprogram
(Prim
,
2457 Is_Abstract_Subprogram
(New_Op
));
2459 -- Ensure that this entity will be expanded to fill the
2460 -- corresponding entry in its dispatch table.
2462 if not Is_Abstract_Subprogram
(Prim
) then
2463 Set_Has_Delayed_Freeze
(Prim
);
2472 if (not Is_Package_Or_Generic_Package
(Current_Scope
))
2473 or else not In_Private_Part
(Current_Scope
)
2475 -- Not a private primitive
2479 else pragma Assert
(Is_Inherited_Operation
(Prev_Op
));
2481 -- Make the overriding operation into an alias of the implicit one.
2482 -- In this fashion a call from outside ends up calling the new body
2483 -- even if non-dispatching, and a call from inside calls the over-
2484 -- riding operation because it hides the implicit one. To indicate
2485 -- that the body of Prev_Op is never called, set its dispatch table
2486 -- entity to Empty. If the overridden operation has a dispatching
2487 -- result, so does the overriding one.
2489 Set_Alias
(Prev_Op
, New_Op
);
2490 Set_DTC_Entity
(Prev_Op
, Empty
);
2491 Set_Has_Controlling_Result
(New_Op
, Has_Controlling_Result
(Prev_Op
));
2494 end Override_Dispatching_Operation
;
2500 procedure Propagate_Tag
(Control
: Node_Id
; Actual
: Node_Id
) is
2501 Call_Node
: Node_Id
;
2505 if Nkind
(Actual
) = N_Function_Call
then
2506 Call_Node
:= Actual
;
2508 elsif Nkind
(Actual
) = N_Identifier
2509 and then Nkind
(Original_Node
(Actual
)) = N_Function_Call
2511 -- Call rewritten as object declaration when stack-checking is
2512 -- enabled. Propagate tag to expression in declaration, which is
2515 Call_Node
:= Expression
(Parent
(Entity
(Actual
)));
2517 -- Ada 2005: If this is a dereference of a call to a function with a
2518 -- dispatching access-result, the tag is propagated when the dereference
2519 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
2521 elsif Nkind
(Actual
) = N_Explicit_Dereference
2522 and then Nkind
(Original_Node
(Prefix
(Actual
))) = N_Function_Call
2526 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
2527 -- and in that case we can simply return.
2529 elsif Nkind
(Actual
) = N_Attribute_Reference
then
2530 pragma Assert
(Attribute_Name
(Actual
) = Name_Input
);
2534 -- Only other possibilities are parenthesized or qualified expression,
2535 -- or an expander-generated unchecked conversion of a function call to
2536 -- a stream Input attribute.
2539 Call_Node
:= Expression
(Actual
);
2542 -- No action needed if the call has been already expanded
2544 if Is_Expanded_Dispatching_Call
(Call_Node
) then
2548 -- Do not set the Controlling_Argument if already set. This happens in
2549 -- the special case of _Input (see Exp_Attr, case Input).
2551 if No
(Controlling_Argument
(Call_Node
)) then
2552 Set_Controlling_Argument
(Call_Node
, Control
);
2555 Arg
:= First_Actual
(Call_Node
);
2556 while Present
(Arg
) loop
2557 if Is_Tag_Indeterminate
(Arg
) then
2558 Propagate_Tag
(Control
, Arg
);
2564 -- Expansion of dispatching calls is suppressed on VM targets, because
2565 -- the VM back-ends directly handle the generation of dispatching calls
2566 -- and would have to undo any expansion to an indirect call.
2568 if Tagged_Type_Expansion
then
2570 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
2573 Expand_Dispatching_Call
(Call_Node
);
2575 -- If the controlling argument is an interface type and the type
2576 -- of Call_Node differs then we must add an implicit conversion to
2577 -- force displacement of the pointer to the object to reference
2578 -- the secondary dispatch table of the interface.
2580 if Is_Interface
(Etype
(Control
))
2581 and then Etype
(Control
) /= Call_Typ
2583 -- Cannot use Convert_To because the previous call to
2584 -- Expand_Dispatching_Call leaves decorated the Call_Node
2585 -- with the type of Control.
2588 Make_Type_Conversion
(Sloc
(Call_Node
),
2590 New_Occurrence_Of
(Etype
(Control
), Sloc
(Call_Node
)),
2591 Expression
=> Relocate_Node
(Call_Node
)));
2592 Set_Etype
(Call_Node
, Etype
(Control
));
2593 Set_Analyzed
(Call_Node
);
2595 Expand_Interface_Conversion
(Call_Node
);
2599 -- Expansion of a dispatching call results in an indirect call, which in
2600 -- turn causes current values to be killed (see Resolve_Call), so on VM
2601 -- targets we do the call here to ensure consistent warnings between VM
2602 -- and non-VM targets.
2605 Kill_Current_Values
;