1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Exp_Disp
; use Exp_Disp
;
33 with Exp_Util
; use Exp_Util
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Errout
; use Errout
;
38 with Freeze
; use Freeze
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Namet
; use Namet
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
48 with Sem_Aux
; use Sem_Aux
;
49 with Sem_Ch6
; use Sem_Ch6
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Type
; use Sem_Type
;
53 with Sem_Util
; use Sem_Util
;
54 with Snames
; use Snames
;
55 with Sinfo
; use Sinfo
;
56 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
57 with Sinfo
.Utils
; use Sinfo
.Utils
;
58 with Tbuild
; use Tbuild
;
59 with Uintp
; use Uintp
;
60 with Warnsw
; use Warnsw
;
62 package body Sem_Disp
is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 procedure Add_Dispatching_Operation
69 (Tagged_Type
: Entity_Id
;
71 -- Add New_Op in the list of primitive operations of Tagged_Type
73 function Check_Controlling_Type
75 Subp
: Entity_Id
) return Entity_Id
;
76 -- T is the tagged type of a formal parameter or the result of Subp.
77 -- If the subprogram has a controlling parameter or result that matches
78 -- the type, then returns the tagged type of that parameter or result
79 -- (returning the designated tagged type in the case of an access
80 -- parameter); otherwise returns empty.
82 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
;
83 -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
84 -- type of S that has the same name of S, a type-conformant profile, an
85 -- original corresponding operation O that is a primitive of a visible
86 -- ancestor of the dispatching type of S and O is visible at the point of
87 -- of declaration of S. If the entity is found the Alias of S is set to the
88 -- original corresponding operation S and its Overridden_Operation is set
89 -- to the found entity; otherwise return Empty.
91 -- This routine does not search for non-hidden primitives since they are
92 -- covered by the normal Ada 2005 rules.
94 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean;
95 -- Check whether a primitive operation is inherited from an operation
96 -- declared in the visible part of its package.
98 -------------------------------
99 -- Add_Dispatching_Operation --
100 -------------------------------
102 procedure Add_Dispatching_Operation
103 (Tagged_Type
: Entity_Id
;
106 List
: constant Elist_Id
:= Primitive_Operations
(Tagged_Type
);
109 -- The dispatching operation may already be on the list, if it is the
110 -- wrapper for an inherited function of a null extension (see Exp_Ch3
111 -- for the construction of function wrappers). The list of primitive
112 -- operations must not contain duplicates.
114 -- The Default_Initial_Condition and invariant procedures are not added
115 -- to the list of primitives even when they are generated for a tagged
116 -- type. These routines must not be targets of dispatching calls and
117 -- therefore must not appear in the dispatch table because they already
118 -- utilize class-wide-precondition semantics to handle inheritance and
121 if Is_Suitable_Primitive
(New_Op
) then
122 Append_Unique_Elmt
(New_Op
, List
);
124 end Add_Dispatching_Operation
;
126 --------------------------
127 -- Covered_Interface_Op --
128 --------------------------
130 function Covered_Interface_Op
(Prim
: Entity_Id
) return Entity_Id
is
131 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
136 pragma Assert
(Is_Dispatching_Operation
(Prim
));
138 -- Although this is a dispatching primitive we must check if its
139 -- dispatching type is available because it may be the primitive
140 -- of a private type not defined as tagged in its partial view.
142 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
144 -- If the tagged type is frozen then the internal entities associated
145 -- with interfaces are available in the list of primitives of the
146 -- tagged type and can be used to speed up this search.
148 if Is_Frozen
(Tagged_Type
) then
149 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
150 while Present
(Elmt
) loop
153 if Present
(Interface_Alias
(E
))
154 and then Alias
(E
) = Prim
156 return Interface_Alias
(E
);
162 -- Otherwise we must collect all the interface primitives and check
163 -- if the Prim overrides (implements) some interface primitive.
167 Ifaces_List
: Elist_Id
;
168 Iface_Elmt
: Elmt_Id
;
170 Iface_Prim
: Entity_Id
;
173 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
174 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
175 while Present
(Iface_Elmt
) loop
176 Iface
:= Node
(Iface_Elmt
);
178 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
179 while Present
(Elmt
) loop
180 Iface_Prim
:= Node
(Elmt
);
182 if Chars
(Iface_Prim
) = Chars
(Prim
)
183 and then Is_Interface_Conformant
184 (Tagged_Type
, Iface_Prim
, Prim
)
192 Next_Elmt
(Iface_Elmt
);
199 end Covered_Interface_Op
;
201 ----------------------------------
202 -- Covered_Interface_Primitives --
203 ----------------------------------
205 function Covered_Interface_Primitives
(Prim
: Entity_Id
) return Elist_Id
is
206 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
209 Result
: Elist_Id
:= No_Elist
;
212 pragma Assert
(Is_Dispatching_Operation
(Prim
));
214 -- Although this is a dispatching primitive we must check if its
215 -- dispatching type is available because it may be the primitive
216 -- of a private type not defined as tagged in its partial view.
218 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
220 -- If the tagged type is frozen then the internal entities associated
221 -- with interfaces are available in the list of primitives of the
222 -- tagged type and can be used to speed up this search.
224 if Is_Frozen
(Tagged_Type
) then
225 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
226 while Present
(Elmt
) loop
229 if Present
(Interface_Alias
(E
))
230 and then Alias
(E
) = Prim
233 Result
:= New_Elmt_List
;
236 Append_Elmt
(Interface_Alias
(E
), Result
);
242 -- Otherwise we must collect all the interface primitives and check
243 -- whether the Prim overrides (implements) some interface primitive.
247 Ifaces_List
: Elist_Id
;
248 Iface_Elmt
: Elmt_Id
;
250 Iface_Prim
: Entity_Id
;
253 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
255 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
256 while Present
(Iface_Elmt
) loop
257 Iface
:= Node
(Iface_Elmt
);
259 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
260 while Present
(Elmt
) loop
261 Iface_Prim
:= Node
(Elmt
);
263 if Chars
(Iface_Prim
) = Chars
(Prim
)
264 and then Is_Interface_Conformant
265 (Tagged_Type
, Iface_Prim
, Prim
)
268 Result
:= New_Elmt_List
;
271 Append_Elmt
(Iface_Prim
, Result
);
277 Next_Elmt
(Iface_Elmt
);
284 end Covered_Interface_Primitives
;
286 -------------------------------
287 -- Check_Controlling_Formals --
288 -------------------------------
290 procedure Check_Controlling_Formals
295 Ctrl_Type
: Entity_Id
;
298 -- We skip the check for thunks
300 if Is_Thunk
(Subp
) then
304 Formal
:= First_Formal
(Subp
);
305 while Present
(Formal
) loop
306 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
308 if Present
(Ctrl_Type
) then
310 -- Obtain the full type in case we are looking at an incomplete
313 if Ekind
(Ctrl_Type
) = E_Incomplete_Type
314 and then Present
(Full_View
(Ctrl_Type
))
316 Ctrl_Type
:= Full_View
(Ctrl_Type
);
319 -- When controlling type is concurrent and declared within a
320 -- generic or inside an instance use corresponding record type.
322 if Is_Concurrent_Type
(Ctrl_Type
)
323 and then Present
(Corresponding_Record_Type
(Ctrl_Type
))
325 Ctrl_Type
:= Corresponding_Record_Type
(Ctrl_Type
);
328 if Ctrl_Type
= Typ
then
329 Set_Is_Controlling_Formal
(Formal
);
331 -- Ada 2005 (AI-231): Anonymous access types that are used in
332 -- controlling parameters exclude null because it is necessary
333 -- to read the tag to dispatch, and null has no tag.
335 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
336 Set_Can_Never_Be_Null
(Etype
(Formal
));
337 Set_Is_Known_Non_Null
(Etype
(Formal
));
340 -- Check that the parameter's nominal subtype statically
341 -- matches the first subtype.
343 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
344 if not Subtypes_Statically_Match
345 (Typ
, Designated_Type
(Etype
(Formal
)))
348 ("parameter subtype does not match controlling type",
352 -- Within a predicate function, the formal may be a subtype
353 -- of a tagged type, given that the predicate is expressed
354 -- in terms of the subtype.
356 elsif not Subtypes_Statically_Match
(Typ
, Etype
(Formal
))
357 and then not Is_Predicate_Function
(Subp
)
360 ("parameter subtype does not match controlling type",
364 if Present
(Default_Value
(Formal
)) then
366 -- In Ada 2005, access parameters can have defaults
368 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
369 and then Ada_Version
< Ada_2005
372 ("default not allowed for controlling access parameter",
373 Default_Value
(Formal
));
375 elsif not Is_Tag_Indeterminate
(Default_Value
(Formal
)) then
377 ("default expression must be a tag indeterminate" &
378 " function call", Default_Value
(Formal
));
382 elsif Comes_From_Source
(Subp
) then
384 ("operation can be dispatching in only one type", Subp
);
388 Next_Formal
(Formal
);
391 if Ekind
(Subp
) in E_Function | E_Generic_Function
then
392 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Subp
), Subp
);
394 if Present
(Ctrl_Type
) then
395 if Ctrl_Type
= Typ
then
396 Set_Has_Controlling_Result
(Subp
);
398 -- Check that result subtype statically matches first subtype
399 -- (Ada 2005): Subp may have a controlling access result.
401 if Subtypes_Statically_Match
(Typ
, Etype
(Subp
))
402 or else (Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
404 Subtypes_Statically_Match
405 (Typ
, Designated_Type
(Etype
(Subp
))))
411 ("result subtype does not match controlling type", Subp
);
414 elsif Comes_From_Source
(Subp
) then
416 ("operation can be dispatching in only one type", Subp
);
420 end Check_Controlling_Formals
;
422 ----------------------------
423 -- Check_Controlling_Type --
424 ----------------------------
426 function Check_Controlling_Type
428 Subp
: Entity_Id
) return Entity_Id
430 Tagged_Type
: Entity_Id
:= Empty
;
433 if Is_Tagged_Type
(T
) then
434 if Is_First_Subtype
(T
) then
437 Tagged_Type
:= Base_Type
(T
);
440 -- If the type is incomplete, it may have been declared without a
441 -- Tagged indication, but the full view may be tagged, in which case
442 -- that is the controlling type of the subprogram. This is one of the
443 -- approx. 579 places in the language where a lookahead would help.
445 elsif Ekind
(T
) = E_Incomplete_Type
446 and then Present
(Full_View
(T
))
447 and then Is_Tagged_Type
(Full_View
(T
))
449 Set_Is_Tagged_Type
(T
);
450 Tagged_Type
:= Full_View
(T
);
452 elsif Ekind
(T
) = E_Anonymous_Access_Type
453 and then Is_Tagged_Type
(Designated_Type
(T
))
455 if Ekind
(Designated_Type
(T
)) /= E_Incomplete_Type
then
456 if Is_First_Subtype
(Designated_Type
(T
)) then
457 Tagged_Type
:= Designated_Type
(T
);
459 Tagged_Type
:= Base_Type
(Designated_Type
(T
));
462 -- Ada 2005: an incomplete type can be tagged. An operation with an
463 -- access parameter of the type is dispatching.
465 elsif Scope
(Designated_Type
(T
)) = Current_Scope
then
466 Tagged_Type
:= Designated_Type
(T
);
468 -- Ada 2005 (AI-50217)
470 elsif From_Limited_With
(Designated_Type
(T
))
471 and then Has_Non_Limited_View
(Designated_Type
(T
))
472 and then Scope
(Designated_Type
(T
)) = Scope
(Subp
)
474 if Is_First_Subtype
(Non_Limited_View
(Designated_Type
(T
))) then
475 Tagged_Type
:= Non_Limited_View
(Designated_Type
(T
));
477 Tagged_Type
:= Base_Type
(Non_Limited_View
478 (Designated_Type
(T
)));
483 if No
(Tagged_Type
) or else Is_Class_Wide_Type
(Tagged_Type
) then
486 -- In the special case of a protected subprogram of a tagged protected
487 -- type that has a formal of a tagged type (or access formal whose type
488 -- designates a tagged type), such a formal is not controlling unless
489 -- it's of the protected type's corresponding record type. The latter
490 -- can occur for the special wrapper subprograms created for protected
491 -- subprograms. Such subprograms may occur in the same scope where some
492 -- formal's tagged type is declared, and we don't want formals of that
493 -- tagged type being marked as controlling, for one thing because they
494 -- aren't controlling from the language point of view, but also because
495 -- this can cause errors for access formals when conformance is checked
496 -- between the spec and body of the protected subprogram (null-exclusion
497 -- status of the formals may be set differently, which is the case that
498 -- led to adding this check).
500 elsif Is_Subprogram
(Subp
)
501 and then Present
(Protected_Subprogram
(Subp
))
502 and then Ekind
(Scope
(Protected_Subprogram
(Subp
))) = E_Protected_Type
504 Base_Type
(Tagged_Type
)
505 /= Corresponding_Record_Type
(Scope
(Protected_Subprogram
(Subp
)))
509 -- The dispatching type and the primitive operation must be defined in
510 -- the same scope, except in the case of abstract formal subprograms.
512 elsif (Scope
(Subp
) = Scope
(Tagged_Type
)
513 and then (not Is_Generic_Type
(Tagged_Type
)
514 or else not Comes_From_Source
(Subp
)))
516 (Is_Formal_Subprogram
(Subp
) and then Is_Abstract_Subprogram
(Subp
))
518 (Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Renaming_Declaration
520 Present
(Corresponding_Formal_Spec
(Parent
(Parent
(Subp
))))
522 Is_Abstract_Subprogram
(Subp
))
529 end Check_Controlling_Type
;
531 ----------------------------
532 -- Check_Dispatching_Call --
533 ----------------------------
535 procedure Check_Dispatching_Call
(N
: Node_Id
) is
536 Loc
: constant Source_Ptr
:= Sloc
(N
);
539 Control
: Node_Id
:= Empty
;
541 Subp_Entity
: Entity_Id
;
543 Indeterm_Ctrl_Type
: Entity_Id
:= Empty
;
544 -- Type of a controlling formal whose actual is a tag-indeterminate call
545 -- whose result type is different from, but is an ancestor of, the type.
547 Static_Tag
: Node_Id
:= Empty
;
548 -- If a controlling formal has a statically tagged actual, the tag of
549 -- this actual is to be used for any tag-indeterminate actual.
551 procedure Check_Direct_Call
;
552 -- In the case when the controlling actual is a class-wide type whose
553 -- root type's completion is a task or protected type, the call is in
554 -- fact direct. This routine detects the above case and modifies the
557 procedure Check_Dispatching_Context
(Call
: Node_Id
);
558 -- If the call is tag-indeterminate and the entity being called is
559 -- abstract, verify that the context is a call that will eventually
560 -- provide a tag for dispatching, or has provided one already.
562 -----------------------
563 -- Check_Direct_Call --
564 -----------------------
566 procedure Check_Direct_Call
is
567 Typ
: Entity_Id
:= Etype
(Control
);
569 -- Predefined primitives do not receive wrappers since they are built
570 -- from scratch for the corresponding record of synchronized types.
571 -- Equality is in general predefined, but is excluded from the check
572 -- when it is user-defined.
574 if Is_Predefined_Dispatching_Operation
(Subp_Entity
)
575 and then not (Is_User_Defined_Equality
(Subp_Entity
)
576 and then Comes_From_Source
(Subp_Entity
)
577 and then Nkind
(Parent
(Subp_Entity
)) =
578 N_Function_Specification
)
583 if Is_Class_Wide_Type
(Typ
) then
584 Typ
:= Root_Type
(Typ
);
587 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
588 Typ
:= Full_View
(Typ
);
591 if Is_Concurrent_Type
(Typ
)
593 Present
(Corresponding_Record_Type
(Typ
))
595 Typ
:= Corresponding_Record_Type
(Typ
);
597 -- The concurrent record's list of primitives should contain a
598 -- wrapper for the entity of the call, retrieve it.
603 Wrapper_Found
: Boolean := False;
606 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
607 while Present
(Prim_Elmt
) loop
608 Prim
:= Node
(Prim_Elmt
);
610 if Is_Primitive_Wrapper
(Prim
)
611 and then Wrapped_Entity
(Prim
) = Subp_Entity
613 Wrapper_Found
:= True;
617 Next_Elmt
(Prim_Elmt
);
620 -- A primitive declared between two views should have a
621 -- corresponding wrapper.
623 pragma Assert
(Wrapper_Found
);
625 -- Modify the call by setting the proper entity
627 Set_Entity
(Name
(N
), Prim
);
630 end Check_Direct_Call
;
632 -------------------------------
633 -- Check_Dispatching_Context --
634 -------------------------------
636 procedure Check_Dispatching_Context
(Call
: Node_Id
) is
637 Subp
: constant Entity_Id
:= Entity
(Name
(Call
));
639 procedure Abstract_Context_Error
;
640 -- Error for abstract call dispatching on result is not dispatching
642 function Has_Controlling_Current_Instance_Actual_In_DIC
643 (Call
: Node_Id
) return Boolean;
644 -- Return True if the subprogram call Call has a controlling actual
645 -- given directly by a current instance referenced within a DIC
648 ----------------------------
649 -- Abstract_Context_Error --
650 ----------------------------
652 procedure Abstract_Context_Error
is
654 if Ekind
(Subp
) = E_Function
then
656 ("call to abstract function must be dispatching", N
);
658 -- This error can occur for a procedure in the case of a call to
659 -- an abstract formal procedure with a statically tagged operand.
663 ("call to abstract procedure must be dispatching", N
);
665 end Abstract_Context_Error
;
667 ----------------------------------------
668 -- Has_Current_Instance_Actual_In_DIC --
669 ----------------------------------------
671 function Has_Controlling_Current_Instance_Actual_In_DIC
672 (Call
: Node_Id
) return Boolean
677 F
:= First_Formal
(Subp_Entity
);
678 A
:= First_Actual
(Call
);
680 while Present
(F
) loop
682 -- Return True if the actual denotes a current instance (which
683 -- will be represented by an in-mode formal of the enclosing
684 -- DIC_Procedure) passed to a controlling formal. We don't have
685 -- to worry about controlling access formals here, because its
686 -- illegal to apply Access (etc.) attributes to a current
687 -- instance within an aspect (by AI12-0068).
689 if Is_Controlling_Formal
(F
)
690 and then Nkind
(A
) = N_Identifier
691 and then Ekind
(Entity
(A
)) = E_In_Parameter
692 and then Is_Subprogram
(Scope
(Entity
(A
)))
693 and then Is_DIC_Procedure
(Scope
(Entity
(A
)))
703 end Has_Controlling_Current_Instance_Actual_In_DIC
;
707 Scop
: constant Entity_Id
:= Current_Scope_No_Loops
;
708 Typ
: constant Entity_Id
:= Etype
(Subp
);
711 -- Start of processing for Check_Dispatching_Context
714 -- Skip checking context of dispatching calls during preanalysis of
715 -- class-wide conditions since at that stage the expression is not
716 -- installed yet on its definite context.
718 if Inside_Class_Condition_Preanalysis
then
722 -- If the called subprogram is a private overriding, replace it
723 -- with its alias, which has the correct body. Verify that the
724 -- two subprograms have the same controlling type (this is not the
725 -- case for an inherited subprogram that has become abstract).
727 if Is_Abstract_Subprogram
(Subp
)
728 and then No
(Controlling_Argument
(Call
))
730 if Present
(Alias
(Subp
))
731 and then not Is_Abstract_Subprogram
(Alias
(Subp
))
732 and then No
(DTC_Entity
(Subp
))
733 and then Find_Dispatching_Type
(Subp
) =
734 Find_Dispatching_Type
(Alias
(Subp
))
736 -- Private overriding of inherited abstract operation, call is
739 Set_Entity
(Name
(N
), Alias
(Subp
));
742 -- If this is a pre/postcondition for an abstract subprogram,
743 -- it may call another abstract function that is a primitive
744 -- of an abstract type. The call is nondispatching but will be
745 -- legal in overridings of the operation. However, if the call
746 -- is tag-indeterminate we want to continue with with the error
747 -- checking below, as this case is illegal even for abstract
748 -- subprograms (see AI12-0170).
750 -- Similarly, as per AI12-0412, a nonabstract subprogram may
751 -- have a class-wide pre/postcondition that includes a call to
752 -- an abstract primitive of the subprogram's controlling type.
753 -- Certain operations (nondispatching calls, 'Access, use as
754 -- a generic actual) applied to such a nonabstract subprogram
755 -- are illegal in the case where the type is abstract (see
756 -- RM 6.1.1(18.2/5)).
758 elsif Is_Subprogram
(Scop
)
759 and then not Is_Tag_Indeterminate
(N
)
761 -- The context is an internally built helper or an indirect
762 -- call wrapper that handles class-wide preconditions
763 (Present
(Class_Preconditions_Subprogram
(Scop
))
765 -- ... or the context is a class-wide pre/postcondition.
767 (In_Pre_Post_Condition
(Call
, Class_Wide_Only
=> True)
769 -- The tagged type associated with the called
770 -- subprogram must be the same as that of the
771 -- subprogram with a class-wide aspect.
773 and then Is_Dispatching_Operation
(Scop
)
774 and then Find_Dispatching_Type
(Subp
)
775 = Find_Dispatching_Type
(Scop
)))
779 -- Similarly to the dispensation for postconditions, a call to
780 -- an abstract function within a Default_Initial_Condition aspect
781 -- can be legal when passed a current instance of the type. Such
782 -- a call will be effectively mapped to a call to a primitive of
783 -- a descendant type (see AI12-0397, as well as AI12-0170), so
784 -- doesn't need to be dispatching. We test for being within a DIC
785 -- procedure, since that's where the call will be analyzed.
787 elsif Is_Subprogram
(Scop
)
788 and then Is_DIC_Procedure
(Scop
)
789 and then Has_Controlling_Current_Instance_Actual_In_DIC
(Call
)
793 elsif Ekind
(Current_Scope
) = E_Function
794 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
795 N_Generic_Subprogram_Declaration
800 -- We need to determine whether the context of the call
801 -- provides a tag to make the call dispatching. This requires
802 -- the call to be the actual in an enclosing call, and that
803 -- actual must be controlling. If the call is an operand of
804 -- equality, the other operand must not be abstract.
806 if not Is_Tagged_Type
(Typ
)
808 (Ekind
(Typ
) = E_Anonymous_Access_Type
809 and then Is_Tagged_Type
(Designated_Type
(Typ
)))
811 Abstract_Context_Error
;
815 Par
:= Parent
(Call
);
817 if Nkind
(Par
) = N_Parameter_Association
then
821 if Nkind
(Par
) = N_Qualified_Expression
822 or else Nkind
(Par
) = N_Unchecked_Type_Conversion
827 if Nkind
(Par
) in N_Subprogram_Call
828 and then Is_Entity_Name
(Name
(Par
))
831 Enc_Subp
: constant Entity_Id
:= Entity
(Name
(Par
));
835 Ret_Type
: Entity_Id
;
838 -- Find controlling formal that can provide tag for the
839 -- tag-indeterminate actual. The corresponding actual
840 -- must be the corresponding class-wide type.
842 F
:= First_Formal
(Enc_Subp
);
843 A
:= First_Actual
(Par
);
845 -- Find controlling type of call. Dereference if function
846 -- returns an access type.
848 Ret_Type
:= Etype
(Call
);
849 if Is_Access_Type
(Etype
(Call
)) then
850 Ret_Type
:= Designated_Type
(Ret_Type
);
853 while Present
(F
) loop
854 Control
:= Etype
(A
);
856 if Is_Access_Type
(Control
) then
857 Control
:= Designated_Type
(Control
);
860 if Is_Controlling_Formal
(F
)
861 and then not (Call
= A
or else Parent
(Call
) = A
)
862 and then Control
= Class_Wide_Type
(Ret_Type
)
871 if Nkind
(Par
) = N_Function_Call
872 and then Is_Tag_Indeterminate
(Par
)
874 -- The parent may be an actual of an enclosing call
876 Check_Dispatching_Context
(Par
);
881 ("call to abstract function must be dispatching",
887 -- For equality operators, one of the operands must be
888 -- statically or dynamically tagged.
890 elsif Nkind
(Par
) in N_Op_Eq | N_Op_Ne
then
891 if N
= Right_Opnd
(Par
)
892 and then Is_Tag_Indeterminate
(Left_Opnd
(Par
))
894 Abstract_Context_Error
;
896 elsif N
= Left_Opnd
(Par
)
897 and then Is_Tag_Indeterminate
(Right_Opnd
(Par
))
899 Abstract_Context_Error
;
904 -- The left-hand side of an assignment provides the tag
906 elsif Nkind
(Par
) = N_Assignment_Statement
then
910 Abstract_Context_Error
;
914 end Check_Dispatching_Context
;
916 -- Start of processing for Check_Dispatching_Call
919 -- Find a controlling argument, if any
921 if Present
(Parameter_Associations
(N
)) then
922 Subp_Entity
:= Entity
(Name
(N
));
924 Actual
:= First_Actual
(N
);
925 Formal
:= First_Formal
(Subp_Entity
);
926 while Present
(Actual
) loop
927 Control
:= Find_Controlling_Arg
(Actual
);
928 exit when Present
(Control
);
930 -- Check for the case where the actual is a tag-indeterminate call
931 -- whose result type is different than the tagged type associated
932 -- with the containing call, but is an ancestor of the type.
934 if Is_Controlling_Formal
(Formal
)
935 and then Is_Tag_Indeterminate
(Actual
)
936 and then Base_Type
(Etype
(Actual
)) /= Base_Type
(Etype
(Formal
))
937 and then Is_Ancestor
(Etype
(Actual
), Etype
(Formal
))
939 Indeterm_Ctrl_Type
:= Etype
(Formal
);
941 -- If the formal is controlling but the actual is not, the type
942 -- of the actual is statically known, and may be used as the
943 -- controlling tag for some other tag-indeterminate actual.
945 elsif Is_Controlling_Formal
(Formal
)
946 and then Is_Entity_Name
(Actual
)
947 and then Is_Tagged_Type
(Etype
(Actual
))
949 Static_Tag
:= Etype
(Actual
);
952 Next_Actual
(Actual
);
953 Next_Formal
(Formal
);
956 if Present
(Control
) then
958 -- Verify that no controlling arguments are statically tagged
961 Write_Str
("Found Dispatching call");
966 Actual
:= First_Actual
(N
);
967 while Present
(Actual
) loop
968 if Actual
/= Control
then
970 if not Is_Controlling_Actual
(Actual
) then
971 null; -- Can be anything
973 elsif Is_Dynamically_Tagged
(Actual
) then
974 null; -- Valid parameter
976 elsif Is_Tag_Indeterminate
(Actual
) then
978 -- The tag is inherited from the enclosing call (the node
979 -- we are currently analyzing). Explicitly expand the
980 -- actual, since the previous call to Expand (from
981 -- Resolve_Call) had no way of knowing about the
982 -- required dispatching.
984 Propagate_Tag
(Control
, Actual
);
988 ("controlling argument is not dynamically tagged",
994 Next_Actual
(Actual
);
997 -- Mark call as a dispatching call
999 Set_Controlling_Argument
(N
, Control
);
1000 Check_Restriction
(No_Dispatching_Calls
, N
);
1002 -- The dispatching call may need to be converted into a direct
1003 -- call in certain cases.
1007 -- If the call doesn't have a controlling actual but does have an
1008 -- indeterminate actual that requires dispatching treatment, then an
1009 -- object is needed that will serve as the controlling argument for
1010 -- a dispatching call on the indeterminate actual. This can occur
1011 -- in the unusual situation of a default actual given by a tag-
1012 -- indeterminate call and where the type of the call is an ancestor
1013 -- of the type associated with a containing call to an inherited
1014 -- operation (see AI-239).
1016 -- Rather than create an object of the tagged type, which would
1017 -- be problematic for various reasons (default initialization,
1018 -- discriminants), the tag of the containing call's associated
1019 -- tagged type is directly used to control the dispatching.
1021 elsif Present
(Indeterm_Ctrl_Type
) then
1022 if Present
(Static_Tag
) then
1024 Make_Attribute_Reference
(Loc
,
1026 New_Occurrence_Of
(Static_Tag
, Loc
),
1027 Attribute_Name
=> Name_Tag
);
1031 Make_Attribute_Reference
(Loc
,
1033 New_Occurrence_Of
(Indeterm_Ctrl_Type
, Loc
),
1034 Attribute_Name
=> Name_Tag
);
1039 Actual
:= First_Actual
(N
);
1040 Formal
:= First_Formal
(Subp_Entity
);
1041 while Present
(Actual
) loop
1042 if Is_Tag_Indeterminate
(Actual
)
1043 and then Is_Controlling_Formal
(Formal
)
1045 Propagate_Tag
(Control
, Actual
);
1048 Next_Actual
(Actual
);
1049 Next_Formal
(Formal
);
1052 Check_Dispatching_Context
(N
);
1054 elsif Nkind
(N
) /= N_Function_Call
then
1056 -- The call is not dispatching, so check that there aren't any
1057 -- tag-indeterminate abstract calls left among its actuals.
1059 Actual
:= First_Actual
(N
);
1060 while Present
(Actual
) loop
1061 if Is_Tag_Indeterminate
(Actual
) then
1063 -- Function call case
1065 if Nkind
(Original_Node
(Actual
)) = N_Function_Call
then
1066 Func
:= Entity
(Name
(Original_Node
(Actual
)));
1068 -- If the actual is an attribute then it can't be abstract
1069 -- (the only current case of a tag-indeterminate attribute
1070 -- is the stream Input attribute).
1072 elsif Nkind
(Original_Node
(Actual
)) = N_Attribute_Reference
1076 -- Ditto if it is an explicit dereference
1078 elsif Nkind
(Original_Node
(Actual
)) = N_Explicit_Dereference
1082 -- Only other possibility is a qualified expression whose
1083 -- constituent expression is itself a call.
1087 Entity
(Name
(Original_Node
1088 (Expression
(Original_Node
(Actual
)))));
1091 if Present
(Func
) and then Is_Abstract_Subprogram
(Func
) then
1093 ("call to abstract function must be dispatching",
1098 Next_Actual
(Actual
);
1101 Check_Dispatching_Context
(N
);
1103 elsif Nkind
(Parent
(N
)) in N_Subexpr
then
1104 Check_Dispatching_Context
(N
);
1106 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
1107 and then Is_Class_Wide_Type
(Etype
(Name
(Parent
(N
))))
1111 elsif Is_Abstract_Subprogram
(Subp_Entity
) then
1112 Check_Dispatching_Context
(N
);
1116 -- If this is a nondispatching call to a nonabstract subprogram
1117 -- and the subprogram has any Pre'Class or Post'Class aspects with
1118 -- nonstatic values, then report an error. This is specified by
1119 -- RM 6.1.1(18.2/5) (by AI12-0412).
1121 -- Skip reporting this error on helpers and indirect-call wrappers
1122 -- built to support class-wide preconditions.
1125 and then not Is_Abstract_Subprogram
(Subp_Entity
)
1127 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Subp_Entity
)
1129 (Is_Subprogram
(Current_Scope
)
1131 Present
(Class_Preconditions_Subprogram
(Current_Scope
)))
1134 ("nondispatching call to nonabstract subprogram of "
1135 & "abstract type with nonstatic class-wide "
1136 & "pre/postconditions",
1141 -- If dispatching on result, the enclosing call, if any, will
1142 -- determine the controlling argument. Otherwise this is the
1143 -- primitive operation of the root type.
1145 Check_Dispatching_Context
(N
);
1147 end Check_Dispatching_Call
;
1149 ---------------------------------
1150 -- Check_Dispatching_Operation --
1151 ---------------------------------
1153 procedure Check_Dispatching_Operation
(Subp
, Old_Subp
: Entity_Id
) is
1154 function Is_Access_To_Subprogram_Wrapper
(E
: Entity_Id
) return Boolean;
1155 -- Return True if E is an access to subprogram wrapper
1157 procedure Warn_On_Late_Primitive_After_Private_Extension
1160 -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
1161 -- if it is a public primitive defined after some private extension of
1164 -------------------------------------
1165 -- Is_Access_To_Subprogram_Wrapper --
1166 -------------------------------------
1168 function Is_Access_To_Subprogram_Wrapper
(E
: Entity_Id
) return Boolean
1170 Decl_N
: constant Node_Id
:= Unit_Declaration_Node
(E
);
1171 Par_N
: constant Node_Id
:= Parent
(List_Containing
(Decl_N
));
1174 -- Access to subprogram wrappers are declared in the freezing actions
1176 return Nkind
(Par_N
) = N_Freeze_Entity
1177 and then Ekind
(Entity
(Par_N
)) = E_Access_Subprogram_Type
;
1178 end Is_Access_To_Subprogram_Wrapper
;
1180 ----------------------------------------------------
1181 -- Warn_On_Late_Primitive_After_Private_Extension --
1182 ----------------------------------------------------
1184 procedure Warn_On_Late_Primitive_After_Private_Extension
1191 if Warn_On_Late_Primitives
1192 and then Comes_From_Source
(Prim
)
1193 and then Has_Private_Extension
(Typ
)
1194 and then Is_Package_Or_Generic_Package
(Current_Scope
)
1195 and then not In_Private_Part
(Current_Scope
)
1197 E
:= Next_Entity
(Typ
);
1199 while E
/= Prim
loop
1200 if Ekind
(E
) = E_Record_Type_With_Private
1201 and then Etype
(E
) = Typ
1203 Error_Msg_Name_1
:= Chars
(Typ
);
1204 Error_Msg_Name_2
:= Chars
(E
);
1205 Error_Msg_Sloc
:= Sloc
(E
);
1207 ("?.j?primitive of type % defined after private extension "
1209 Error_Msg_Name_1
:= Chars
(Prim
);
1210 Error_Msg_Name_2
:= Chars
(E
);
1212 ("\spec of % should appear before declaration of type %!",
1220 end Warn_On_Late_Primitive_After_Private_Extension
;
1224 Body_Is_Last_Primitive
: Boolean := False;
1225 Has_Dispatching_Parent
: Boolean := False;
1226 Ovr_Subp
: Entity_Id
:= Empty
;
1227 Tagged_Type
: Entity_Id
;
1229 -- Start of processing for Check_Dispatching_Operation
1232 if Ekind
(Subp
) not in E_Function | E_Procedure
then
1235 -- The Default_Initial_Condition procedure is not a primitive subprogram
1236 -- even if it relates to a tagged type. This routine is not meant to be
1237 -- inherited or overridden.
1239 elsif Is_DIC_Procedure
(Subp
) then
1242 -- The "partial" and "full" type invariant procedures are not primitive
1243 -- subprograms even if they relate to a tagged type. These routines are
1244 -- not meant to be inherited or overridden.
1246 elsif Is_Invariant_Procedure
(Subp
)
1247 or else Is_Partial_Invariant_Procedure
(Subp
)
1251 -- Wrappers of access to subprograms are not primitive subprograms.
1253 elsif Is_Wrapper
(Subp
)
1254 and then Is_Access_To_Subprogram_Wrapper
(Subp
)
1259 Set_Is_Dispatching_Operation
(Subp
, False);
1260 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1262 -- Ada 2005 (AI-345): Use the corresponding record (if available).
1263 -- Required because primitives of concurrent types are attached
1264 -- to the corresponding record (not to the concurrent type).
1266 if Ada_Version
>= Ada_2005
1267 and then Present
(Tagged_Type
)
1268 and then Is_Concurrent_Type
(Tagged_Type
)
1269 and then Present
(Corresponding_Record_Type
(Tagged_Type
))
1271 Tagged_Type
:= Corresponding_Record_Type
(Tagged_Type
);
1274 -- (AI-345): The task body procedure is not a primitive of the tagged
1277 if Present
(Tagged_Type
)
1278 and then Is_Concurrent_Record_Type
(Tagged_Type
)
1279 and then Present
(Corresponding_Concurrent_Type
(Tagged_Type
))
1280 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Tagged_Type
))
1281 and then Subp
= Get_Task_Body_Procedure
1282 (Corresponding_Concurrent_Type
(Tagged_Type
))
1287 -- If Subp is derived from a dispatching operation then it should
1288 -- always be treated as dispatching. In this case various checks
1289 -- below will be bypassed. Makes sure that late declarations for
1290 -- inherited private subprograms are treated as dispatching, even
1291 -- if the associated tagged type is already frozen.
1293 Has_Dispatching_Parent
:=
1294 Present
(Alias
(Subp
))
1295 and then Is_Dispatching_Operation
(Alias
(Subp
));
1297 if No
(Tagged_Type
) then
1299 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
1300 -- with an abstract interface type unless the interface acts as a
1301 -- parent type in a derivation. If the interface type is a formal
1302 -- type then the operation is not primitive and therefore legal.
1309 E
:= First_Entity
(Subp
);
1310 while Present
(E
) loop
1312 -- For an access parameter, check designated type
1314 if Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
then
1315 Typ
:= Designated_Type
(Etype
(E
));
1320 if Comes_From_Source
(Subp
)
1321 and then Is_Interface
(Typ
)
1322 and then not Is_Class_Wide_Type
(Typ
)
1323 and then not Is_Derived_Type
(Typ
)
1324 and then not Is_Generic_Type
(Typ
)
1325 and then not In_Instance
1327 Error_Msg_N
("??declaration of& is too late!", Subp
);
1328 Error_Msg_NE
-- CODEFIX??
1329 ("\??spec should appear immediately after declaration of "
1330 & "& !", Subp
, Typ
);
1337 -- In case of functions check also the result type
1339 if Ekind
(Subp
) = E_Function
then
1340 if Is_Access_Type
(Etype
(Subp
)) then
1341 Typ
:= Designated_Type
(Etype
(Subp
));
1343 Typ
:= Etype
(Subp
);
1346 -- The following should be better commented, especially since
1347 -- we just added several new conditions here ???
1349 if Comes_From_Source
(Subp
)
1350 and then Is_Interface
(Typ
)
1351 and then not Is_Class_Wide_Type
(Typ
)
1352 and then not Is_Derived_Type
(Typ
)
1353 and then not Is_Generic_Type
(Typ
)
1354 and then not In_Instance
1356 Error_Msg_N
("??declaration of& is too late!", Subp
);
1358 ("\??spec should appear immediately after declaration of "
1359 & "& !", Subp
, Typ
);
1366 -- The subprograms build internally after the freezing point (such as
1367 -- init procs, interface thunks, type support subprograms, and Offset
1368 -- to top functions for accessing interface components in variable
1369 -- size tagged types) are not primitives.
1371 elsif Is_Frozen
(Tagged_Type
)
1372 and then not Comes_From_Source
(Subp
)
1373 and then not Has_Dispatching_Parent
1375 -- Complete decoration of internally built subprograms that override
1376 -- a dispatching primitive. These entities correspond with the
1379 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
1380 -- to override functions of nonabstract null extensions. These
1381 -- primitives were added to the list of primitives of the tagged
1382 -- type by Make_Controlling_Function_Wrappers. However, attribute
1383 -- Is_Dispatching_Operation must be set to true.
1385 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
1388 -- 3. Subprograms associated with stream attributes (built by
1389 -- New_Stream_Subprogram) or with the Put_Image attribute.
1391 -- 4. Wrappers built for inherited operations with inherited class-
1392 -- wide conditions, where the conditions include calls to other
1393 -- overridden primitives. The wrappers include checks on these
1394 -- modified conditions. (AI12-195).
1396 -- 5. Declarations built for subprograms without separate specs that
1397 -- are eligible for inlining in GNATprove (inside
1398 -- Sem_Ch6.Analyze_Subprogram_Body_Helper).
1400 if Present
(Old_Subp
)
1401 and then Present
(Overridden_Operation
(Subp
))
1402 and then Is_Dispatching_Operation
(Old_Subp
)
1405 ((Ekind
(Subp
) = E_Function
1406 and then Is_Dispatching_Operation
(Old_Subp
)
1407 and then Is_Null_Extension
(Base_Type
(Etype
(Subp
))))
1410 (Ekind
(Subp
) = E_Procedure
1411 and then Is_Dispatching_Operation
(Old_Subp
)
1412 and then Present
(Alias
(Old_Subp
))
1413 and then Is_Null_Interface_Primitive
1414 (Ultimate_Alias
(Old_Subp
)))
1416 or else Get_TSS_Name
(Subp
) in TSS_Stream_Read
1422 and then Present
(LSP_Subprogram
(Subp
)))
1424 or else GNATprove_Mode
);
1426 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1427 Override_Dispatching_Operation
(Tagged_Type
, Old_Subp
, Subp
);
1428 Set_Is_Dispatching_Operation
(Subp
);
1433 -- The operation may be a child unit, whose scope is the defining
1434 -- package, but which is not a primitive operation of the type.
1436 elsif Is_Child_Unit
(Subp
) then
1439 -- If the subprogram is not defined in a package spec, the only case
1440 -- where it can be a dispatching op is when it overrides an operation
1441 -- before the freezing point of the type.
1443 elsif (not Is_Package_Or_Generic_Package
(Scope
(Subp
))
1444 or else In_Package_Body
(Scope
(Subp
)))
1445 and then not Has_Dispatching_Parent
1447 if not Comes_From_Source
(Subp
)
1448 or else (Present
(Old_Subp
) and then not Is_Frozen
(Tagged_Type
))
1452 -- If the type is already frozen, the overriding is not allowed
1453 -- except when Old_Subp is not a dispatching operation (which can
1454 -- occur when Old_Subp was inherited by an untagged type). However,
1455 -- a body with no previous spec freezes the type *after* its
1456 -- declaration, and therefore is a legal overriding (unless the type
1457 -- has already been frozen). Only the first such body is legal.
1459 elsif Present
(Old_Subp
)
1460 and then Is_Dispatching_Operation
(Old_Subp
)
1462 if Comes_From_Source
(Subp
)
1464 (Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Body
1465 or else Nkind
(Unit_Declaration_Node
(Subp
)) in N_Body_Stub
)
1468 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1469 Decl_Item
: Node_Id
;
1472 -- ??? The checks here for whether the type has been frozen
1473 -- prior to the new body are not complete. It's not simple
1474 -- to check frozenness at this point since the body has
1475 -- already caused the type to be prematurely frozen in
1476 -- Analyze_Declarations, but we're forced to recheck this
1477 -- here because of the odd rule interpretation that allows
1478 -- the overriding if the type wasn't frozen prior to the
1479 -- body. The freezing action should probably be delayed
1480 -- until after the spec is seen, but that's a tricky
1481 -- change to the delicate freezing code.
1483 -- Look at each declaration following the type up until the
1484 -- new subprogram body. If any of the declarations is a body
1485 -- then the type has been frozen already so the overriding
1486 -- primitive is illegal.
1488 Decl_Item
:= Next
(Parent
(Tagged_Type
));
1489 while Present
(Decl_Item
)
1490 and then Decl_Item
/= Subp_Body
1492 if Comes_From_Source
(Decl_Item
)
1493 and then (Nkind
(Decl_Item
) in N_Proper_Body
1494 or else Nkind
(Decl_Item
) in N_Body_Stub
)
1496 Error_Msg_N
("overriding of& is too late!", Subp
);
1498 ("\spec should appear immediately after the type!",
1506 -- If the subprogram doesn't follow in the list of
1507 -- declarations including the type then the type has
1508 -- definitely been frozen already and the body is illegal.
1510 if No
(Decl_Item
) then
1511 Error_Msg_N
("overriding of& is too late!", Subp
);
1513 ("\spec should appear immediately after the type!",
1518 -- The subprogram body declares a primitive operation.
1519 -- We must update its dispatching information here. The
1520 -- information is taken from the overridden subprogram.
1521 -- We must also generate a cross-reference entry because
1522 -- references to other primitives were already created
1523 -- when type was frozen.
1525 Body_Is_Last_Primitive
:= True;
1527 if Present
(DTC_Entity
(Old_Subp
)) then
1528 Set_DTC_Entity
(Subp
, DTC_Entity
(Old_Subp
));
1529 Set_DT_Position_Value
(Subp
, DT_Position
(Old_Subp
));
1531 if not Restriction_Active
(No_Dispatching_Calls
) then
1532 if Building_Static_DT
(Tagged_Type
) then
1534 -- If the static dispatch table has not been
1535 -- built then there is nothing else to do now;
1536 -- otherwise we notify that we cannot build the
1537 -- static dispatch table.
1539 if Has_Dispatch_Table
(Tagged_Type
) then
1541 ("overriding of& is too late for building "
1542 & " static dispatch tables!", Subp
);
1544 ("\spec should appear immediately after "
1545 & "the type!", Subp
);
1548 -- No code required to register primitives in VM
1551 elsif not Tagged_Type_Expansion
then
1555 Insert_Actions_After
(Subp_Body
,
1556 Register_Primitive
(Sloc
(Subp_Body
),
1560 -- Indicate that this is an overriding operation,
1561 -- and replace the overridden entry in the list of
1562 -- primitive operations, which is used for xref
1563 -- generation subsequently.
1565 Generate_Reference
(Tagged_Type
, Subp
, 'P', False);
1566 Override_Dispatching_Operation
1567 (Tagged_Type
, Old_Subp
, Subp
);
1568 Set_Is_Dispatching_Operation
(Subp
);
1570 -- Inherit decoration of controlling formals and
1571 -- controlling result.
1573 if Ekind
(Old_Subp
) = E_Function
1574 and then Has_Controlling_Result
(Old_Subp
)
1576 Set_Has_Controlling_Result
(Subp
);
1579 if Present
(First_Formal
(Old_Subp
)) then
1581 Old_Formal
: Entity_Id
;
1585 Formal
:= First_Formal
(Subp
);
1586 Old_Formal
:= First_Formal
(Old_Subp
);
1588 while Present
(Old_Formal
) loop
1589 Set_Is_Controlling_Formal
(Formal
,
1590 Is_Controlling_Formal
(Old_Formal
));
1592 Next_Formal
(Formal
);
1593 Next_Formal
(Old_Formal
);
1599 Check_Inherited_Conditions
(Tagged_Type
,
1600 Late_Overriding
=> True);
1606 Error_Msg_N
("overriding of& is too late!", Subp
);
1608 ("\subprogram spec should appear immediately after the type!",
1612 -- If the type is not frozen yet and we are not in the overriding
1613 -- case it looks suspiciously like an attempt to define a primitive
1614 -- operation, which requires the declaration to be in a package spec
1615 -- (3.2.3(6)). Only report cases where the type and subprogram are
1616 -- in the same declaration list (by checking the enclosing parent
1617 -- declarations), to avoid spurious warnings on subprograms in
1618 -- instance bodies when the type is declared in the instance spec
1619 -- but hasn't been frozen by the instance body.
1621 elsif not Is_Frozen
(Tagged_Type
)
1622 and then In_Same_List
(Parent
(Tagged_Type
), Parent
(Parent
(Subp
)))
1625 ("??not dispatching (must be defined in a package spec)", Subp
);
1628 -- When the type is frozen, it is legitimate to define a new
1629 -- non-primitive operation.
1635 -- Now, we are sure that the scope is a package spec. If the subprogram
1636 -- is declared after the freezing point of the type that's an error
1638 elsif Is_Frozen
(Tagged_Type
) and then not Has_Dispatching_Parent
then
1639 Error_Msg_N
("this primitive operation is declared too late", Subp
);
1641 ("??no primitive operations for& after this line",
1642 Freeze_Node
(Tagged_Type
),
1647 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1649 Ovr_Subp
:= Old_Subp
;
1651 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1652 -- overridden by Subp. This only applies to source subprograms, and
1653 -- their declaration must carry an explicit overriding indicator.
1656 and then Ada_Version
>= Ada_2012
1657 and then Comes_From_Source
(Subp
)
1659 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1661 Ovr_Subp
:= Find_Hidden_Overridden_Primitive
(Subp
);
1663 -- Verify that the proper overriding indicator has been supplied.
1665 if Present
(Ovr_Subp
)
1667 not Must_Override
(Specification
(Unit_Declaration_Node
(Subp
)))
1669 Error_Msg_NE
("missing overriding indicator for&", Subp
, Subp
);
1673 -- Now it should be a correct primitive operation, put it in the list
1675 if Present
(Ovr_Subp
) then
1677 -- If the type has interfaces we complete this check after we set
1678 -- attribute Is_Dispatching_Operation.
1680 Check_Subtype_Conformant
(Subp
, Ovr_Subp
);
1682 -- A primitive operation with the name of a primitive controlled
1683 -- operation does not override a non-visible overriding controlled
1684 -- operation, i.e. one declared in a private part when the full
1685 -- view of a type is controlled. Conversely, it will override a
1686 -- visible operation that may be declared in a partial view when
1687 -- the full view is controlled.
1689 if Chars
(Subp
) in Name_Initialize | Name_Adjust | Name_Finalize
1690 and then Is_Controlled
(Tagged_Type
)
1691 and then not Is_Visibly_Controlled
(Tagged_Type
)
1692 and then not Is_Inherited_Public_Operation
(Ovr_Subp
)
1694 Set_Overridden_Operation
(Subp
, Empty
);
1696 -- If the subprogram specification carries an overriding
1697 -- indicator, no need for the warning: it is either redundant,
1698 -- or else an error will be reported.
1700 if Nkind
(Parent
(Subp
)) = N_Procedure_Specification
1702 (Must_Override
(Parent
(Subp
))
1703 or else Must_Not_Override
(Parent
(Subp
)))
1707 -- Here we need the warning
1711 ("operation does not override inherited&??", Subp
, Subp
);
1715 Override_Dispatching_Operation
(Tagged_Type
, Ovr_Subp
, Subp
);
1717 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1718 -- that covers abstract interface subprograms we must register it
1719 -- in all the secondary dispatch tables associated with abstract
1720 -- interfaces. We do this now only if not building static tables,
1721 -- nor when the expander is inactive (we avoid trying to register
1722 -- primitives in semantics-only mode, since the type may not have
1723 -- an associated dispatch table). Otherwise the patch code is
1724 -- emitted after those tables are built, to prevent access before
1725 -- elaboration in gigi.
1727 if Body_Is_Last_Primitive
1728 and then not Building_Static_DT
(Tagged_Type
)
1729 and then Expander_Active
1730 and then Tagged_Type_Expansion
1733 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1738 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1739 while Present
(Elmt
) loop
1740 Prim
:= Node
(Elmt
);
1742 if Present
(Alias
(Prim
))
1743 and then Present
(Interface_Alias
(Prim
))
1744 and then Alias
(Prim
) = Subp
1746 Insert_Actions_After
(Subp_Body
,
1747 Register_Primitive
(Sloc
(Subp_Body
), Prim
=> Prim
));
1753 -- Redisplay the contents of the updated dispatch table
1755 if Debug_Flag_ZZ
then
1756 Write_Str
("Late overriding: ");
1757 Write_DT
(Tagged_Type
);
1763 -- If no old subprogram, then we add this as a dispatching operation,
1764 -- but we avoid doing this if an error was posted, to prevent annoying
1767 elsif not Error_Posted
(Subp
) then
1768 Add_Dispatching_Operation
(Tagged_Type
, Subp
);
1771 Set_Is_Dispatching_Operation
(Subp
, True);
1773 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1774 -- subtype conformance against all the interfaces covered by this
1777 if Present
(Ovr_Subp
)
1778 and then Has_Interfaces
(Tagged_Type
)
1781 Ifaces_List
: Elist_Id
;
1782 Iface_Elmt
: Elmt_Id
;
1783 Iface_Prim_Elmt
: Elmt_Id
;
1784 Iface_Prim
: Entity_Id
;
1785 Ret_Typ
: Entity_Id
;
1788 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
1790 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1791 while Present
(Iface_Elmt
) loop
1792 if not Is_Ancestor
(Node
(Iface_Elmt
), Tagged_Type
) then
1794 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
1795 while Present
(Iface_Prim_Elmt
) loop
1796 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
1798 if Is_Interface_Conformant
1799 (Tagged_Type
, Iface_Prim
, Subp
)
1801 -- Handle procedures, functions whose return type
1802 -- matches, or functions not returning interfaces
1804 if Ekind
(Subp
) = E_Procedure
1805 or else Etype
(Iface_Prim
) = Etype
(Subp
)
1806 or else not Is_Interface
(Etype
(Iface_Prim
))
1808 Check_Subtype_Conformant
1810 Old_Id
=> Iface_Prim
,
1812 Skip_Controlling_Formals
=> True);
1814 -- Handle functions returning interfaces
1816 elsif Implements_Interface
1817 (Etype
(Subp
), Etype
(Iface_Prim
))
1819 -- Temporarily force both entities to return the
1820 -- same type. Required because Subtype_Conformant
1821 -- does not handle this case.
1823 Ret_Typ
:= Etype
(Iface_Prim
);
1824 Set_Etype
(Iface_Prim
, Etype
(Subp
));
1826 Check_Subtype_Conformant
1828 Old_Id
=> Iface_Prim
,
1830 Skip_Controlling_Formals
=> True);
1832 Set_Etype
(Iface_Prim
, Ret_Typ
);
1836 Next_Elmt
(Iface_Prim_Elmt
);
1840 Next_Elmt
(Iface_Elmt
);
1845 if not Body_Is_Last_Primitive
then
1846 Set_DT_Position_Value
(Subp
, No_Uint
);
1848 elsif Has_Controlled_Component
(Tagged_Type
)
1849 and then Chars
(Subp
) in Name_Initialize
1852 | Name_Finalize_Address
1855 F_Node
: constant Node_Id
:= Freeze_Node
(Tagged_Type
);
1859 Old_Spec
: Entity_Id
;
1861 C_Names
: constant array (1 .. 4) of Name_Id
:=
1865 Name_Finalize_Address
);
1867 D_Names
: constant array (1 .. 4) of TSS_Name_Type
:=
1868 (TSS_Deep_Initialize
,
1871 TSS_Finalize_Address
);
1874 -- Remove previous controlled function which was constructed and
1875 -- analyzed when the type was frozen. This requires removing the
1876 -- body of the redefined primitive, as well as its specification
1877 -- if needed (there is no spec created for Deep_Initialize, see
1878 -- exp_ch3.adb). We must also dismantle the exception information
1879 -- that may have been generated for it when front end zero-cost
1880 -- tables are enabled.
1882 for J
in D_Names
'Range loop
1883 Old_P
:= TSS
(Tagged_Type
, D_Names
(J
));
1886 and then Chars
(Subp
) = C_Names
(J
)
1888 Old_Bod
:= Unit_Declaration_Node
(Old_P
);
1890 Set_Is_Eliminated
(Old_P
);
1891 Set_Scope
(Old_P
, Scope
(Current_Scope
));
1893 if Nkind
(Old_Bod
) = N_Subprogram_Body
1894 and then Present
(Corresponding_Spec
(Old_Bod
))
1896 Old_Spec
:= Corresponding_Spec
(Old_Bod
);
1897 Set_Has_Completion
(Old_Spec
, False);
1902 Build_Late_Proc
(Tagged_Type
, Chars
(Subp
));
1904 -- The new operation is added to the actions of the freeze node
1905 -- for the type, but this node has already been analyzed, so we
1906 -- must retrieve and analyze explicitly the new body.
1909 and then Present
(Actions
(F_Node
))
1911 Decl
:= Last
(Actions
(F_Node
));
1917 -- AI12-0279: If the Yield aspect is specified for a dispatching
1918 -- subprogram that inherits the aspect, the specified value shall
1921 if Is_Dispatching_Operation
(Subp
)
1922 and then Is_Primitive_Wrapper
(Subp
)
1923 and then Present
(Wrapped_Entity
(Subp
))
1924 and then Comes_From_Source
(Wrapped_Entity
(Subp
))
1925 and then Present
(Overridden_Operation
(Subp
))
1926 and then Has_Yield_Aspect
(Overridden_Operation
(Subp
))
1927 /= Has_Yield_Aspect
(Wrapped_Entity
(Subp
))
1930 W_Ent
: constant Entity_Id
:= Wrapped_Entity
(Subp
);
1931 W_Decl
: constant Node_Id
:= Parent
(W_Ent
);
1935 if Present
(Aspect_Specifications
(W_Decl
)) then
1936 Asp
:= First
(Aspect_Specifications
(W_Decl
));
1937 while Present
(Asp
) loop
1938 if Chars
(Identifier
(Asp
)) = Name_Yield
then
1939 Error_Msg_Name_1
:= Name_Yield
;
1941 ("specification of inherited aspect% can only confirm "
1942 & "parent value", Asp
);
1949 Set_Has_Yield_Aspect
(Wrapped_Entity
(Subp
));
1953 -- For similarity with record extensions, in Ada 9X the language should
1954 -- have disallowed adding visible operations to a tagged type after
1955 -- deriving a private extension from it. Report a warning if this
1956 -- primitive is defined after a private extension of Tagged_Type.
1958 Warn_On_Late_Primitive_After_Private_Extension
(Tagged_Type
, Subp
);
1959 end Check_Dispatching_Operation
;
1961 ------------------------------------------
1962 -- Check_Operation_From_Incomplete_Type --
1963 ------------------------------------------
1965 procedure Check_Operation_From_Incomplete_Type
1969 Full
: constant Entity_Id
:= Full_View
(Typ
);
1970 Parent_Typ
: constant Entity_Id
:= Etype
(Full
);
1971 Old_Prim
: constant Elist_Id
:= Primitive_Operations
(Parent_Typ
);
1972 New_Prim
: constant Elist_Id
:= Primitive_Operations
(Full
);
1974 Prev
: Elmt_Id
:= No_Elmt
;
1976 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean;
1977 -- Check that Subp has profile of an operation derived from Parent_Subp.
1978 -- Subp must have a parameter or result type that is Typ or an access
1979 -- parameter or access result type that designates Typ.
1985 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean is
1989 if Chars
(Parent_Subp
) /= Chars
(Subp
) then
1993 -- Check that the type of controlling formals is derived from the
1994 -- parent subprogram's controlling formal type (or designated type
1995 -- if the formal type is an anonymous access type).
1997 F1
:= First_Formal
(Parent_Subp
);
1998 F2
:= First_Formal
(Subp
);
1999 while Present
(F1
) and then Present
(F2
) loop
2000 if Ekind
(Etype
(F1
)) = E_Anonymous_Access_Type
then
2001 if Ekind
(Etype
(F2
)) /= E_Anonymous_Access_Type
then
2003 elsif Designated_Type
(Etype
(F1
)) = Parent_Typ
2004 and then Designated_Type
(Etype
(F2
)) /= Full
2009 elsif Ekind
(Etype
(F2
)) = E_Anonymous_Access_Type
then
2012 elsif Etype
(F1
) = Parent_Typ
and then Etype
(F2
) /= Full
then
2020 -- Check that a controlling result type is derived from the parent
2021 -- subprogram's result type (or designated type if the result type
2022 -- is an anonymous access type).
2024 if Ekind
(Parent_Subp
) = E_Function
then
2025 if Ekind
(Subp
) /= E_Function
then
2028 elsif Ekind
(Etype
(Parent_Subp
)) = E_Anonymous_Access_Type
then
2029 if Ekind
(Etype
(Subp
)) /= E_Anonymous_Access_Type
then
2032 elsif Designated_Type
(Etype
(Parent_Subp
)) = Parent_Typ
2033 and then Designated_Type
(Etype
(Subp
)) /= Full
2038 elsif Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
then
2041 elsif Etype
(Parent_Subp
) = Parent_Typ
2042 and then Etype
(Subp
) /= Full
2047 elsif Ekind
(Subp
) = E_Function
then
2051 return No
(F1
) and then No
(F2
);
2054 -- Start of processing for Check_Operation_From_Incomplete_Type
2057 -- The operation may override an inherited one, or may be a new one
2058 -- altogether. The inherited operation will have been hidden by the
2059 -- current one at the point of the type derivation, so it does not
2060 -- appear in the list of primitive operations of the type. We have to
2061 -- find the proper place of insertion in the list of primitive opera-
2062 -- tions by iterating over the list for the parent type.
2064 Op1
:= First_Elmt
(Old_Prim
);
2065 Op2
:= First_Elmt
(New_Prim
);
2066 while Present
(Op1
) and then Present
(Op2
) loop
2067 if Derives_From
(Node
(Op1
)) then
2070 -- Avoid adding it to the list of primitives if already there
2072 if Node
(Op2
) /= Subp
then
2073 Prepend_Elmt
(Subp
, New_Prim
);
2077 Insert_Elmt_After
(Subp
, Prev
);
2088 -- Operation is a new primitive
2090 Append_Elmt
(Subp
, New_Prim
);
2091 end Check_Operation_From_Incomplete_Type
;
2093 ---------------------------------------
2094 -- Check_Operation_From_Private_View --
2095 ---------------------------------------
2097 procedure Check_Operation_From_Private_View
(Subp
, Old_Subp
: Entity_Id
) is
2098 Tagged_Type
: Entity_Id
;
2101 if Is_Dispatching_Operation
(Alias
(Subp
)) then
2102 Set_Scope
(Subp
, Current_Scope
);
2103 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
2105 -- Add Old_Subp to primitive operations if not already present
2107 if Present
(Tagged_Type
) and then Is_Tagged_Type
(Tagged_Type
) then
2108 Add_Dispatching_Operation
(Tagged_Type
, Old_Subp
);
2110 -- If Old_Subp isn't already marked as dispatching then this is
2111 -- the case of an operation of an untagged private type fulfilled
2112 -- by a tagged type that overrides an inherited dispatching
2113 -- operation, so we set the necessary dispatching attributes here.
2115 if not Is_Dispatching_Operation
(Old_Subp
) then
2117 -- If the untagged type has no discriminants, and the full
2118 -- view is constrained, there will be a spurious mismatch of
2119 -- subtypes on the controlling arguments, because the tagged
2120 -- type is the internal base type introduced in the derivation.
2121 -- Use the original type to verify conformance, rather than the
2124 if not Comes_From_Source
(Tagged_Type
)
2125 and then Has_Discriminants
(Tagged_Type
)
2131 Formal
:= First_Formal
(Old_Subp
);
2132 while Present
(Formal
) loop
2133 if Tagged_Type
= Base_Type
(Etype
(Formal
)) then
2134 Tagged_Type
:= Etype
(Formal
);
2137 Next_Formal
(Formal
);
2141 if Tagged_Type
= Base_Type
(Etype
(Old_Subp
)) then
2142 Tagged_Type
:= Etype
(Old_Subp
);
2146 Check_Controlling_Formals
(Tagged_Type
, Old_Subp
);
2147 Set_Is_Dispatching_Operation
(Old_Subp
, True);
2148 Set_DT_Position_Value
(Old_Subp
, No_Uint
);
2151 -- If the old subprogram is an explicit renaming of some other
2152 -- entity, it is not overridden by the inherited subprogram.
2153 -- Otherwise, update its alias and other attributes.
2155 if Present
(Alias
(Old_Subp
))
2156 and then Nkind
(Unit_Declaration_Node
(Old_Subp
)) /=
2157 N_Subprogram_Renaming_Declaration
2159 Set_Alias
(Old_Subp
, Alias
(Subp
));
2161 -- The derived subprogram should inherit the abstractness of
2162 -- the parent subprogram (except in the case of a function
2163 -- returning the type). This sets the abstractness properly
2164 -- for cases where a private extension may have inherited an
2165 -- abstract operation, but the full type is derived from a
2166 -- descendant type and inherits a nonabstract version.
2168 if Etype
(Subp
) /= Tagged_Type
then
2169 Set_Is_Abstract_Subprogram
2170 (Old_Subp
, Is_Abstract_Subprogram
(Alias
(Subp
)));
2175 end Check_Operation_From_Private_View
;
2177 --------------------------
2178 -- Find_Controlling_Arg --
2179 --------------------------
2181 function Find_Controlling_Arg
(N
: Node_Id
) return Node_Id
is
2182 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2186 if Nkind
(Orig_Node
) = N_Qualified_Expression
then
2187 return Find_Controlling_Arg
(Expression
(Orig_Node
));
2190 -- Dispatching on result case. If expansion is disabled, the node still
2191 -- has the structure of a function call. However, if the function name
2192 -- is an operator and the call was given in infix form, the original
2193 -- node has no controlling result and we must examine the current node.
2195 if Nkind
(N
) = N_Function_Call
2196 and then Present
(Controlling_Argument
(N
))
2197 and then Has_Controlling_Result
(Entity
(Name
(N
)))
2199 return Controlling_Argument
(N
);
2201 -- If expansion is enabled, the call may have been transformed into
2202 -- an indirect call, and we need to recover the original node.
2204 elsif Nkind
(Orig_Node
) = N_Function_Call
2205 and then Present
(Controlling_Argument
(Orig_Node
))
2206 and then Has_Controlling_Result
(Entity
(Name
(Orig_Node
)))
2208 return Controlling_Argument
(Orig_Node
);
2210 -- Type conversions are dynamically tagged if the target type, or its
2211 -- designated type, are classwide. An interface conversion expands into
2212 -- a dereference, so test must be performed on the original node.
2214 elsif Nkind
(Orig_Node
) = N_Type_Conversion
2215 and then Nkind
(N
) = N_Explicit_Dereference
2216 and then Is_Controlling_Actual
(N
)
2219 Target_Type
: constant Entity_Id
:=
2220 Entity
(Subtype_Mark
(Orig_Node
));
2223 if Is_Class_Wide_Type
(Target_Type
) then
2226 elsif Is_Access_Type
(Target_Type
)
2227 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
2238 elsif Is_Controlling_Actual
(N
)
2240 (Nkind
(Parent
(N
)) = N_Qualified_Expression
2241 and then Is_Controlling_Actual
(Parent
(N
)))
2245 if Is_Access_Type
(Typ
) then
2247 -- In the case of an Access attribute, use the type of the prefix,
2248 -- since in the case of an actual for an access parameter, the
2249 -- attribute's type may be of a specific designated type, even
2250 -- though the prefix type is class-wide.
2252 if Nkind
(N
) = N_Attribute_Reference
then
2253 Typ
:= Etype
(Prefix
(N
));
2255 -- An allocator is dispatching if the type of qualified expression
2256 -- is class_wide, in which case this is the controlling type.
2258 elsif Nkind
(Orig_Node
) = N_Allocator
2259 and then Nkind
(Expression
(Orig_Node
)) = N_Qualified_Expression
2261 Typ
:= Etype
(Expression
(Orig_Node
));
2263 Typ
:= Designated_Type
(Typ
);
2267 if Is_Class_Wide_Type
(Typ
)
2269 (Nkind
(Parent
(N
)) = N_Qualified_Expression
2270 and then Is_Access_Type
(Etype
(N
))
2271 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(N
))))
2278 end Find_Controlling_Arg
;
2280 ---------------------------
2281 -- Find_Dispatching_Type --
2282 ---------------------------
2284 function Find_Dispatching_Type
(Subp
: Entity_Id
) return Entity_Id
is
2285 A_Formal
: Entity_Id
;
2287 Ctrl_Type
: Entity_Id
;
2290 if Ekind
(Subp
) in E_Function | E_Procedure
2291 and then Present
(DTC_Entity
(Subp
))
2293 return Scope
(DTC_Entity
(Subp
));
2295 -- For subprograms internally generated by derivations of tagged types
2296 -- use the alias subprogram as a reference to locate the dispatching
2299 elsif not Comes_From_Source
(Subp
)
2300 and then Present
(Alias
(Subp
))
2301 and then Is_Dispatching_Operation
(Alias
(Subp
))
2303 if Ekind
(Alias
(Subp
)) = E_Function
2304 and then Has_Controlling_Result
(Alias
(Subp
))
2306 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2309 Formal
:= First_Formal
(Subp
);
2310 A_Formal
:= First_Formal
(Alias
(Subp
));
2311 while Present
(A_Formal
) loop
2312 if Is_Controlling_Formal
(A_Formal
) then
2313 return Check_Controlling_Type
(Etype
(Formal
), Subp
);
2316 Next_Formal
(Formal
);
2317 Next_Formal
(A_Formal
);
2320 pragma Assert
(False);
2327 Formal
:= First_Formal
(Subp
);
2328 while Present
(Formal
) loop
2329 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
2331 if Present
(Ctrl_Type
) then
2335 Next_Formal
(Formal
);
2338 -- The subprogram may also be dispatching on result
2340 if Present
(Etype
(Subp
)) then
2341 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2345 pragma Assert
(not Is_Dispatching_Operation
(Subp
));
2347 end Find_Dispatching_Type
;
2349 --------------------------------------
2350 -- Find_Hidden_Overridden_Primitive --
2351 --------------------------------------
2353 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
2355 Tag_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
2357 Orig_Prim
: Entity_Id
;
2359 Vis_List
: Elist_Id
;
2362 -- This Ada 2012 rule applies only for type extensions or private
2363 -- extensions, where the parent type is not in a parent unit, and
2364 -- where an operation is never declared but still inherited.
2367 or else not Is_Record_Type
(Tag_Typ
)
2368 or else Etype
(Tag_Typ
) = Tag_Typ
2369 or else In_Open_Scopes
(Scope
(Etype
(Tag_Typ
)))
2374 -- Collect the list of visible ancestor of the tagged type
2376 Vis_List
:= Visible_Ancestors
(Tag_Typ
);
2378 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2379 while Present
(Elmt
) loop
2380 Prim
:= Node
(Elmt
);
2382 -- Find an inherited hidden dispatching primitive with the name of S
2383 -- and a type-conformant profile.
2385 if Present
(Alias
(Prim
))
2386 and then Is_Hidden
(Alias
(Prim
))
2387 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Tag_Typ
2388 and then Primitive_Names_Match
(S
, Prim
)
2389 and then Type_Conformant
(S
, Prim
)
2392 Vis_Ancestor
: Elmt_Id
;
2396 -- The original corresponding operation of Prim must be an
2397 -- operation of a visible ancestor of the dispatching type S,
2398 -- and the original corresponding operation of S2 must be
2401 Orig_Prim
:= Original_Corresponding_Operation
(Prim
);
2403 if Orig_Prim
/= Prim
2404 and then Is_Immediately_Visible
(Orig_Prim
)
2406 Vis_Ancestor
:= First_Elmt
(Vis_List
);
2407 while Present
(Vis_Ancestor
) loop
2409 First_Elmt
(Primitive_Operations
(Node
(Vis_Ancestor
)));
2410 while Present
(Elmt
) loop
2411 if Node
(Elmt
) = Orig_Prim
then
2412 Set_Overridden_Operation
(S
, Prim
);
2413 Set_Is_Ada_2022_Only
(S
,
2414 Is_Ada_2022_Only
(Prim
));
2415 Set_Alias
(Prim
, Orig_Prim
);
2422 Next_Elmt
(Vis_Ancestor
);
2432 end Find_Hidden_Overridden_Primitive
;
2434 ---------------------------------------
2435 -- Find_Primitive_Covering_Interface --
2436 ---------------------------------------
2438 function Find_Primitive_Covering_Interface
2439 (Tagged_Type
: Entity_Id
;
2440 Iface_Prim
: Entity_Id
) return Entity_Id
2446 pragma Assert
(Is_Interface
(Find_Dispatching_Type
(Iface_Prim
))
2447 or else (Present
(Alias
(Iface_Prim
))
2450 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
2452 -- Search in the homonym chain. Done to speed up locating visible
2453 -- entities and required to catch primitives associated with the partial
2454 -- view of private types when processing the corresponding full view.
2456 E
:= Current_Entity
(Iface_Prim
);
2457 while Present
(E
) loop
2458 if Is_Subprogram
(E
)
2459 and then Is_Dispatching_Operation
(E
)
2460 and then Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
)
2468 -- Search in the list of primitives of the type. Required to locate
2469 -- the covering primitive if the covering primitive is not visible
2470 -- (for example, non-visible inherited primitive of private type).
2472 El
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2473 while Present
(El
) loop
2476 -- Keep separate the management of internal entities that link
2477 -- primitives with interface primitives from tagged type primitives.
2479 if No
(Interface_Alias
(E
)) then
2480 if Present
(Alias
(E
)) then
2482 -- This interface primitive has not been covered yet
2484 if Alias
(E
) = Iface_Prim
then
2487 -- The covering primitive was inherited
2489 elsif Overridden_Operation
(Ultimate_Alias
(E
))
2496 -- Check if E covers the interface primitive (includes case in
2497 -- which E is an inherited private primitive).
2499 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2503 -- Use the internal entity that links the interface primitive with
2504 -- the covering primitive to locate the entity.
2506 elsif Interface_Alias
(E
) = Iface_Prim
then
2516 end Find_Primitive_Covering_Interface
;
2518 ---------------------------
2519 -- Inheritance_Utilities --
2520 ---------------------------
2522 package body Inheritance_Utilities
is
2524 ---------------------------
2525 -- Inherited_Subprograms --
2526 ---------------------------
2528 function Inherited_Subprograms
2530 No_Interfaces
: Boolean := False;
2531 Interfaces_Only
: Boolean := False;
2532 Skip_Overridden
: Boolean := False;
2533 One_Only
: Boolean := False) return Subprogram_List
2535 Result
: Subprogram_List
(1 .. 6000);
2536 -- 6000 here is intended to be infinity. We could use an expandable
2537 -- table, but it would be awfully heavy, and there is no way that we
2538 -- could reasonably exceed this value.
2541 -- Number of entries in Result
2543 Parent_Op
: Entity_Id
;
2544 -- Traverses the Overridden_Operation chain
2546 procedure Store_IS
(E
: Entity_Id
);
2547 -- Stores E in Result if not already stored
2553 procedure Store_IS
(E
: Entity_Id
) is
2555 for J
in 1 .. N
loop
2556 if E
= Result
(J
) then
2565 -- Start of processing for Inherited_Subprograms
2568 pragma Assert
(not (No_Interfaces
and Interfaces_Only
));
2570 -- When used from backends, visibility can be handled differently
2571 -- resulting in no dispatching type being found.
2574 and then Is_Dispatching_Operation
(S
)
2575 and then Present
(Find_DT
(S
))
2577 -- Deal with direct inheritance
2579 if not Interfaces_Only
then
2582 Parent_Op
:= Overridden_Operation
(Parent_Op
);
2583 exit when No
(Parent_Op
)
2584 or else (No_Interfaces
2585 and then Is_Interface
(Find_DT
(Parent_Op
)));
2587 if Is_Subprogram_Or_Generic_Subprogram
(Parent_Op
) then
2588 Store_IS
(Parent_Op
);
2597 -- Now deal with interfaces
2599 if not No_Interfaces
then
2601 Tag_Typ
: Entity_Id
;
2606 Tag_Typ
:= Find_DT
(S
);
2608 -- In the presence of limited views there may be no visible
2609 -- dispatching type. Primitives will be inherited when non-
2610 -- limited view is frozen.
2612 if No
(Tag_Typ
) then
2613 return Result
(1 .. 0);
2615 -- Prevent cascaded errors
2617 elsif Is_Concurrent_Type
(Tag_Typ
)
2618 and then No
(Corresponding_Record_Type
(Tag_Typ
))
2619 and then Serious_Errors_Detected
> 0
2621 return Result
(1 .. 0);
2624 if Is_Concurrent_Type
(Tag_Typ
) then
2625 Tag_Typ
:= Corresponding_Record_Type
(Tag_Typ
);
2628 if Present
(Tag_Typ
)
2629 and then Is_Private_Type
(Tag_Typ
)
2630 and then Present
(Full_View
(Tag_Typ
))
2632 Tag_Typ
:= Full_View
(Tag_Typ
);
2635 -- Search primitive operations of dispatching type
2637 if Present
(Tag_Typ
)
2638 and then Present
(Primitive_Operations
(Tag_Typ
))
2640 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2641 while Present
(Elmt
) loop
2642 Prim
:= Node
(Elmt
);
2644 -- The following test eliminates some odd cases in
2645 -- which Ekind (Prim) is Void, to be investigated
2648 if not Is_Subprogram_Or_Generic_Subprogram
(Prim
) then
2651 -- For [generic] subprogram, look at interface
2654 elsif Present
(Interface_Alias
(Prim
))
2655 and then Alias
(Prim
) = S
2657 -- We have found a primitive covered by S
2659 Store_IS
(Interface_Alias
(Prim
));
2673 -- Do not keep an overridden operation if its overridding operation
2674 -- is in the results too, and it is not S. This can happen for
2675 -- inheritance between interfaces.
2677 if Skip_Overridden
then
2679 Res
: constant Subprogram_List
(1 .. N
) := Result
(1 .. N
);
2682 for J
in 1 .. N
loop
2683 for K
in 1 .. N
loop
2685 and then Res
(J
) = Overridden_Operation
(Res
(K
))
2692 Result
(M
) := Res
(J
);
2703 return Result
(1 .. N
);
2704 end Inherited_Subprograms
;
2706 ------------------------------
2707 -- Is_Overriding_Subprogram --
2708 ------------------------------
2710 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean is
2711 Inherited
: constant Subprogram_List
:=
2712 Inherited_Subprograms
(E
, One_Only
=> True);
2714 return Inherited
'Length > 0;
2715 end Is_Overriding_Subprogram
;
2716 end Inheritance_Utilities
;
2718 --------------------------------
2719 -- Inheritance_Utilities_Inst --
2720 --------------------------------
2722 package Inheritance_Utilities_Inst
is new
2723 Inheritance_Utilities
(Find_Dispatching_Type
);
2725 ---------------------------
2726 -- Inherited_Subprograms --
2727 ---------------------------
2729 function Inherited_Subprograms
2731 No_Interfaces
: Boolean := False;
2732 Interfaces_Only
: Boolean := False;
2733 Skip_Overridden
: Boolean := False;
2734 One_Only
: Boolean := False) return Subprogram_List
renames
2735 Inheritance_Utilities_Inst
.Inherited_Subprograms
;
2737 ---------------------------
2738 -- Is_Dynamically_Tagged --
2739 ---------------------------
2741 function Is_Dynamically_Tagged
(N
: Node_Id
) return Boolean is
2743 if Nkind
(N
) = N_Error
then
2746 elsif Present
(Find_Controlling_Arg
(N
)) then
2749 -- Special cases: entities, and calls that dispatch on result
2751 elsif Is_Entity_Name
(N
) then
2752 return Is_Class_Wide_Type
(Etype
(N
));
2754 elsif Nkind
(N
) = N_Function_Call
2755 and then Is_Class_Wide_Type
(Etype
(N
))
2759 -- Otherwise check whether call has controlling argument
2764 end Is_Dynamically_Tagged
;
2766 ---------------------------------
2767 -- Is_Null_Interface_Primitive --
2768 ---------------------------------
2770 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2772 return Comes_From_Source
(E
)
2773 and then Is_Dispatching_Operation
(E
)
2774 and then Ekind
(E
) = E_Procedure
2775 and then Null_Present
(Parent
(E
))
2776 and then Is_Interface
(Find_Dispatching_Type
(E
));
2777 end Is_Null_Interface_Primitive
;
2779 -----------------------------------
2780 -- Is_Inherited_Public_Operation --
2781 -----------------------------------
2783 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean is
2784 Pack_Decl
: Node_Id
;
2785 Prim
: Entity_Id
:= Op
;
2786 Scop
: Entity_Id
:= Prim
;
2789 -- Locate the ultimate non-hidden alias entity
2791 while Present
(Alias
(Prim
)) and then not Is_Hidden
(Alias
(Prim
)) loop
2792 pragma Assert
(Alias
(Prim
) /= Prim
);
2793 Prim
:= Alias
(Prim
);
2794 Scop
:= Scope
(Prim
);
2797 if Comes_From_Source
(Prim
) and then Ekind
(Scop
) = E_Package
then
2798 Pack_Decl
:= Unit_Declaration_Node
(Scop
);
2801 Nkind
(Pack_Decl
) = N_Package_Declaration
2802 and then List_Containing
(Unit_Declaration_Node
(Prim
)) =
2803 Visible_Declarations
(Specification
(Pack_Decl
));
2808 end Is_Inherited_Public_Operation
;
2810 ------------------------------
2811 -- Is_Overriding_Subprogram --
2812 ------------------------------
2814 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean renames
2815 Inheritance_Utilities_Inst
.Is_Overriding_Subprogram
;
2817 --------------------------
2818 -- Is_Tag_Indeterminate --
2819 --------------------------
2821 function Is_Tag_Indeterminate
(N
: Node_Id
) return Boolean is
2824 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2827 if Nkind
(Orig_Node
) = N_Function_Call
2828 and then Is_Entity_Name
(Name
(Orig_Node
))
2830 Nam
:= Entity
(Name
(Orig_Node
));
2832 if not Has_Controlling_Result
(Nam
) then
2835 -- The function may have a controlling result, but if the return type
2836 -- is not visibly tagged, then this is not tag-indeterminate.
2838 elsif Is_Access_Type
(Etype
(Nam
))
2839 and then not Is_Tagged_Type
(Designated_Type
(Etype
(Nam
)))
2843 -- An explicit dereference means that the call has already been
2844 -- expanded and there is no tag to propagate.
2846 elsif Nkind
(N
) = N_Explicit_Dereference
then
2849 -- If there are no actuals, the call is tag-indeterminate
2851 elsif No
(Parameter_Associations
(Orig_Node
)) then
2855 Actual
:= First_Actual
(Orig_Node
);
2856 while Present
(Actual
) loop
2857 if Is_Controlling_Actual
(Actual
)
2858 and then not Is_Tag_Indeterminate
(Actual
)
2860 -- One operand is dispatching
2865 Next_Actual
(Actual
);
2871 elsif Nkind
(Orig_Node
) = N_Qualified_Expression
then
2872 return Is_Tag_Indeterminate
(Expression
(Orig_Node
));
2874 -- Case of a call to the Input attribute (possibly rewritten), which is
2875 -- always tag-indeterminate except when its prefix is a Class attribute.
2877 elsif Nkind
(Orig_Node
) = N_Attribute_Reference
2879 Get_Attribute_Id
(Attribute_Name
(Orig_Node
)) = Attribute_Input
2880 and then Nkind
(Prefix
(Orig_Node
)) /= N_Attribute_Reference
2884 -- In Ada 2005, a function that returns an anonymous access type can be
2885 -- dispatching, and the dereference of a call to such a function can
2886 -- also be tag-indeterminate if the call itself is.
2888 elsif Nkind
(Orig_Node
) = N_Explicit_Dereference
2889 and then Ada_Version
>= Ada_2005
2891 return Is_Tag_Indeterminate
(Prefix
(Orig_Node
));
2896 end Is_Tag_Indeterminate
;
2898 ------------------------------------
2899 -- Override_Dispatching_Operation --
2900 ------------------------------------
2902 procedure Override_Dispatching_Operation
2903 (Tagged_Type
: Entity_Id
;
2904 Prev_Op
: Entity_Id
;
2911 -- If there is no previous operation to override, the type declaration
2912 -- was malformed, and an error must have been emitted already.
2914 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2915 while Present
(Elmt
) and then Node
(Elmt
) /= Prev_Op
loop
2923 -- The location of entities that come from source in the list of
2924 -- primitives of the tagged type must follow their order of occurrence
2925 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
2926 -- primitive of an interface that is not implemented by the parents of
2927 -- this tagged type (that is, it is an alias of an interface primitive
2928 -- generated by Derive_Interface_Progenitors), then we must append the
2929 -- new entity at the end of the list of primitives.
2931 if Present
(Alias
(Prev_Op
))
2932 and then Etype
(Tagged_Type
) /= Tagged_Type
2933 and then Is_Interface
(Find_Dispatching_Type
(Alias
(Prev_Op
)))
2934 and then not Is_Ancestor
(Find_Dispatching_Type
(Alias
(Prev_Op
)),
2935 Tagged_Type
, Use_Full_View
=> True)
2936 and then not Implements_Interface
2937 (Etype
(Tagged_Type
),
2938 Find_Dispatching_Type
(Alias
(Prev_Op
)))
2940 Remove_Elmt
(Primitive_Operations
(Tagged_Type
), Elmt
);
2941 Add_Dispatching_Operation
(Tagged_Type
, New_Op
);
2943 -- The new primitive replaces the overridden entity. Required to ensure
2944 -- that overriding primitive is assigned the same dispatch table slot.
2947 Replace_Elmt
(Elmt
, New_Op
);
2950 if Ada_Version
>= Ada_2005
and then Has_Interfaces
(Tagged_Type
) then
2952 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
2953 -- entities of the overridden primitive to reference New_Op, and
2954 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
2955 -- that the new operation is subtype conformant with the interface
2956 -- operations that it implements (for operations inherited from the
2957 -- parent itself, this check is made when building the derived type).
2959 -- Note: This code is executed with internally generated wrappers of
2960 -- functions with controlling result and late overridings.
2962 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2963 while Present
(Elmt
) loop
2964 Prim
:= Node
(Elmt
);
2966 if Prim
= New_Op
then
2969 -- Note: The check on Is_Subprogram protects the frontend against
2970 -- reading attributes in entities that are not yet fully decorated
2972 elsif Is_Subprogram
(Prim
)
2973 and then Present
(Interface_Alias
(Prim
))
2974 and then Alias
(Prim
) = Prev_Op
2976 Set_Alias
(Prim
, New_Op
);
2978 -- No further decoration needed yet for internally generated
2979 -- wrappers of controlling functions since (at this stage)
2980 -- they are not yet decorated.
2982 if not Is_Wrapper
(New_Op
) then
2983 Check_Subtype_Conformant
(New_Op
, Prim
);
2985 Set_Is_Abstract_Subprogram
(Prim
,
2986 Is_Abstract_Subprogram
(New_Op
));
2988 -- Ensure that this entity will be expanded to fill the
2989 -- corresponding entry in its dispatch table.
2991 if not Is_Abstract_Subprogram
(Prim
) then
2992 Set_Has_Delayed_Freeze
(Prim
);
3001 if not Is_Package_Or_Generic_Package
(Current_Scope
)
3002 or else not In_Private_Part
(Current_Scope
)
3004 -- Not a private primitive
3008 else pragma Assert
(Is_Inherited_Operation
(Prev_Op
));
3010 -- Make the overriding operation into an alias of the implicit one.
3011 -- In this fashion a call from outside ends up calling the new body
3012 -- even if non-dispatching, and a call from inside calls the over-
3013 -- riding operation because it hides the implicit one. To indicate
3014 -- that the body of Prev_Op is never called, set its dispatch table
3015 -- entity to Empty. If the overridden operation has a dispatching
3016 -- result, so does the overriding one.
3018 Set_Alias
(Prev_Op
, New_Op
);
3019 Set_DTC_Entity
(Prev_Op
, Empty
);
3020 Set_Has_Controlling_Result
(New_Op
, Has_Controlling_Result
(Prev_Op
));
3021 Set_Is_Ada_2022_Only
(New_Op
, Is_Ada_2022_Only
(Prev_Op
));
3023 end Override_Dispatching_Operation
;
3029 procedure Propagate_Tag
(Control
: Node_Id
; Actual
: Node_Id
) is
3030 Call_Node
: Node_Id
;
3034 if Nkind
(Actual
) = N_Function_Call
then
3035 Call_Node
:= Actual
;
3037 elsif Nkind
(Actual
) = N_Identifier
3038 and then Nkind
(Original_Node
(Actual
)) = N_Function_Call
3040 -- Call rewritten as object declaration when stack-checking is
3041 -- enabled. Propagate tag to expression in declaration, which is
3044 Call_Node
:= Expression
(Parent
(Entity
(Actual
)));
3046 -- Ada 2005: If this is a dereference of a call to a function with a
3047 -- dispatching access-result, the tag is propagated when the dereference
3048 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
3050 elsif Nkind
(Actual
) = N_Explicit_Dereference
3051 and then Nkind
(Original_Node
(Prefix
(Actual
))) = N_Function_Call
3055 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
3056 -- and in that case we can simply return.
3058 elsif Nkind
(Actual
) = N_Attribute_Reference
then
3059 pragma Assert
(Attribute_Name
(Actual
) = Name_Input
);
3063 -- Only other possibilities are parenthesized or qualified expression,
3064 -- or an expander-generated unchecked conversion of a function call to
3065 -- a stream Input attribute.
3068 Call_Node
:= Expression
(Actual
);
3071 -- No action needed if the call has been already expanded
3073 if Is_Expanded_Dispatching_Call
(Call_Node
) then
3077 -- Do not set the Controlling_Argument if already set. This happens in
3078 -- the special case of _Input (see Exp_Attr, case Input).
3080 if No
(Controlling_Argument
(Call_Node
)) then
3081 Set_Controlling_Argument
(Call_Node
, Control
);
3084 Arg
:= First_Actual
(Call_Node
);
3085 while Present
(Arg
) loop
3086 if Is_Tag_Indeterminate
(Arg
) then
3087 Propagate_Tag
(Control
, Arg
);
3093 -- Add class-wide precondition check if the target of this dispatching
3094 -- call has or inherits class-wide preconditions.
3096 Install_Class_Preconditions_Check
(Call_Node
);
3098 -- Expansion of dispatching calls is suppressed on VM targets, because
3099 -- the VM back-ends directly handle the generation of dispatching calls
3100 -- and would have to undo any expansion to an indirect call.
3102 if Tagged_Type_Expansion
then
3104 Call_Typ
: Entity_Id
:= Etype
(Call_Node
);
3105 Ctrl_Typ
: Entity_Id
:= Etype
(Control
);
3108 Expand_Dispatching_Call
(Call_Node
);
3110 if Is_Class_Wide_Type
(Call_Typ
) then
3111 Call_Typ
:= Root_Type
(Call_Typ
);
3114 if Is_Class_Wide_Type
(Ctrl_Typ
) then
3115 Ctrl_Typ
:= Root_Type
(Ctrl_Typ
);
3118 -- If the controlling argument is an interface type and the type
3119 -- of Call_Node differs then we must add an implicit conversion to
3120 -- force displacement of the pointer to the object to reference
3121 -- the secondary dispatch table of the interface.
3123 if Is_Interface
(Ctrl_Typ
)
3124 and then Ctrl_Typ
/= Call_Typ
3126 -- Cannot use Convert_To because the previous call to
3127 -- Expand_Dispatching_Call leaves decorated the Call_Node
3128 -- with the type of Control.
3131 Make_Type_Conversion
(Sloc
(Call_Node
),
3133 New_Occurrence_Of
(Etype
(Control
), Sloc
(Call_Node
)),
3134 Expression
=> Relocate_Node
(Call_Node
)));
3135 Set_Etype
(Call_Node
, Etype
(Control
));
3136 Set_Analyzed
(Call_Node
);
3138 Expand_Interface_Conversion
(Call_Node
);
3142 -- Expansion of a dispatching call results in an indirect call, which in
3143 -- turn causes current values to be killed (see Resolve_Call), so on VM
3144 -- targets we do the call here to ensure consistent warnings between VM
3145 -- and non-VM targets.
3148 Kill_Current_Values
;