1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with 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. Its name was motivated by an
93 -- intermediate version of AI05-0125 where this term was proposed to
94 -- name these entities in the RM.
96 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean;
97 -- Check whether a primitive operation is inherited from an operation
98 -- declared in the visible part of its package.
100 -------------------------------
101 -- Add_Dispatching_Operation --
102 -------------------------------
104 procedure Add_Dispatching_Operation
105 (Tagged_Type
: Entity_Id
;
108 List
: constant Elist_Id
:= Primitive_Operations
(Tagged_Type
);
111 -- The dispatching operation may already be on the list, if it is the
112 -- wrapper for an inherited function of a null extension (see Exp_Ch3
113 -- for the construction of function wrappers). The list of primitive
114 -- operations must not contain duplicates.
116 -- The Default_Initial_Condition and invariant procedures are not added
117 -- to the list of primitives even when they are generated for a tagged
118 -- type. These routines must not be targets of dispatching calls and
119 -- therefore must not appear in the dispatch table because they already
120 -- utilize class-wide-precondition semantics to handle inheritance and
123 if Is_Suitable_Primitive
(New_Op
) then
124 Append_Unique_Elmt
(New_Op
, List
);
126 end Add_Dispatching_Operation
;
128 --------------------------
129 -- Covered_Interface_Op --
130 --------------------------
132 function Covered_Interface_Op
(Prim
: Entity_Id
) return Entity_Id
is
133 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
138 pragma Assert
(Is_Dispatching_Operation
(Prim
));
140 -- Although this is a dispatching primitive we must check if its
141 -- dispatching type is available because it may be the primitive
142 -- of a private type not defined as tagged in its partial view.
144 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
146 -- If the tagged type is frozen then the internal entities associated
147 -- with interfaces are available in the list of primitives of the
148 -- tagged type and can be used to speed up this search.
150 if Is_Frozen
(Tagged_Type
) then
151 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
152 while Present
(Elmt
) loop
155 if Present
(Interface_Alias
(E
))
156 and then Alias
(E
) = Prim
158 return Interface_Alias
(E
);
164 -- Otherwise we must collect all the interface primitives and check
165 -- if the Prim overrides (implements) some interface primitive.
169 Ifaces_List
: Elist_Id
;
170 Iface_Elmt
: Elmt_Id
;
172 Iface_Prim
: Entity_Id
;
175 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
176 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
177 while Present
(Iface_Elmt
) loop
178 Iface
:= Node
(Iface_Elmt
);
180 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
181 while Present
(Elmt
) loop
182 Iface_Prim
:= Node
(Elmt
);
184 if Chars
(Iface_Prim
) = Chars
(Prim
)
185 and then Is_Interface_Conformant
186 (Tagged_Type
, Iface_Prim
, Prim
)
194 Next_Elmt
(Iface_Elmt
);
201 end Covered_Interface_Op
;
203 ----------------------------------
204 -- Covered_Interface_Primitives --
205 ----------------------------------
207 function Covered_Interface_Primitives
(Prim
: Entity_Id
) return Elist_Id
is
208 Tagged_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
211 Result
: Elist_Id
:= No_Elist
;
214 pragma Assert
(Is_Dispatching_Operation
(Prim
));
216 -- Although this is a dispatching primitive we must check if its
217 -- dispatching type is available because it may be the primitive
218 -- of a private type not defined as tagged in its partial view.
220 if Present
(Tagged_Type
) and then Has_Interfaces
(Tagged_Type
) then
222 -- If the tagged type is frozen then the internal entities associated
223 -- with interfaces are available in the list of primitives of the
224 -- tagged type and can be used to speed up this search.
226 if Is_Frozen
(Tagged_Type
) then
227 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
228 while Present
(Elmt
) loop
231 if Present
(Interface_Alias
(E
))
232 and then Alias
(E
) = Prim
235 Result
:= New_Elmt_List
;
238 Append_Elmt
(Interface_Alias
(E
), Result
);
244 -- Otherwise we must collect all the interface primitives and check
245 -- whether the Prim overrides (implements) some interface primitive.
249 Ifaces_List
: Elist_Id
;
250 Iface_Elmt
: Elmt_Id
;
252 Iface_Prim
: Entity_Id
;
255 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
257 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
258 while Present
(Iface_Elmt
) loop
259 Iface
:= Node
(Iface_Elmt
);
261 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
262 while Present
(Elmt
) loop
263 Iface_Prim
:= Node
(Elmt
);
265 if Chars
(Iface_Prim
) = Chars
(Prim
)
266 and then Is_Interface_Conformant
267 (Tagged_Type
, Iface_Prim
, Prim
)
270 Result
:= New_Elmt_List
;
273 Append_Elmt
(Iface_Prim
, Result
);
279 Next_Elmt
(Iface_Elmt
);
286 end Covered_Interface_Primitives
;
288 -------------------------------
289 -- Check_Controlling_Formals --
290 -------------------------------
292 procedure Check_Controlling_Formals
297 Ctrl_Type
: Entity_Id
;
300 -- We skip the check for thunks
302 if Is_Thunk
(Subp
) then
306 Formal
:= First_Formal
(Subp
);
307 while Present
(Formal
) loop
312 if not Has_First_Controlling_Parameter_Aspect
(Typ
) then
313 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
315 -- Type with the First_Controlling_Parameter aspect: for overriding
316 -- primitives of a parent type that lacks this aspect, we cannot be
317 -- more restrictive than the overridden primitive. This also applies
318 -- to renamings of dispatching primitives. Dispatching operators can
319 -- have one or two controlling parameters, as long as one of them is
320 -- the first one, and none of the parameters have the same type as
321 -- the operator's result type.
323 -- Internal subprograms added by the frontend bypass the restrictions
324 -- of First_Controlling_Parameter aspect.
326 elsif Formal
= First_Formal
(Subp
)
327 or else Is_Internal
(Subp
)
328 or else Present
(Overridden_Operation
(Subp
))
330 (Present
(Alias
(Subp
))
331 and then Is_Dispatching_Operation
(Ultimate_Alias
(Subp
)))
333 (Ekind
(Subp
) = E_Function
334 and then Is_Operator_Name
(Chars
(Subp
)))
336 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
339 if Present
(Ctrl_Type
) then
341 -- Obtain the full type in case we are looking at an incomplete
344 if Ekind
(Ctrl_Type
) = E_Incomplete_Type
345 and then Present
(Full_View
(Ctrl_Type
))
347 Ctrl_Type
:= Full_View
(Ctrl_Type
);
350 -- When controlling type is concurrent and declared within a
351 -- generic or inside an instance use corresponding record type.
353 if Is_Concurrent_Type
(Ctrl_Type
)
354 and then Present
(Corresponding_Record_Type
(Ctrl_Type
))
356 Ctrl_Type
:= Corresponding_Record_Type
(Ctrl_Type
);
359 if Ctrl_Type
= Typ
then
360 Set_Is_Controlling_Formal
(Formal
);
362 -- Ada 2005 (AI-231): Anonymous access types that are used in
363 -- controlling parameters exclude null because it is necessary
364 -- to read the tag to dispatch, and null has no tag.
366 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
367 Set_Can_Never_Be_Null
(Etype
(Formal
));
368 Set_Is_Known_Non_Null
(Etype
(Formal
));
371 -- Check that the parameter's nominal subtype statically
372 -- matches the first subtype.
374 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
375 if not Subtypes_Statically_Match
376 (Typ
, Designated_Type
(Etype
(Formal
)))
379 ("parameter subtype does not match controlling type",
383 -- Within a predicate function, the formal may be a subtype
384 -- of a tagged type, given that the predicate is expressed
385 -- in terms of the subtype.
387 elsif not Subtypes_Statically_Match
(Typ
, Etype
(Formal
))
388 and then not Is_Predicate_Function
(Subp
)
391 ("parameter subtype does not match controlling type",
395 if Present
(Default_Value
(Formal
)) then
397 -- In Ada 2005, access parameters can have defaults
399 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
400 and then Ada_Version
< Ada_2005
403 ("default not allowed for controlling access parameter",
404 Default_Value
(Formal
));
406 elsif not Is_Tag_Indeterminate
(Default_Value
(Formal
)) then
408 ("default expression must be a tag indeterminate" &
409 " function call", Default_Value
(Formal
));
413 elsif Comes_From_Source
(Subp
) then
415 ("operation can be dispatching in only one type", Subp
);
419 Next_Formal
(Formal
);
422 -- Functions overriding parent type primitives that lack the aspect
423 -- First_Controlling_Param cannot be more restrictive than the
424 -- overridden function. This also applies to renamings of dispatching
425 -- primitives. Internal subprograms added by the frontend bypass these
428 if Ekind
(Subp
) in E_Function | E_Generic_Function
429 and then (not Has_First_Controlling_Parameter_Aspect
(Typ
)
430 or else Is_Internal
(Subp
)
432 (Present
(Overridden_Operation
(Subp
))
434 Has_Controlling_Result
(Overridden_Operation
(Subp
)))
436 (Present
(Alias
(Subp
))
438 Has_Controlling_Result
(Ultimate_Alias
(Subp
))))
440 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Subp
), Subp
);
442 if Present
(Ctrl_Type
) then
443 if Ctrl_Type
= Typ
then
444 Set_Has_Controlling_Result
(Subp
);
446 -- Check that result subtype statically matches first subtype
447 -- (Ada 2005): Subp may have a controlling access result.
449 if Subtypes_Statically_Match
(Typ
, Etype
(Subp
))
450 or else (Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
452 Subtypes_Statically_Match
453 (Typ
, Designated_Type
(Etype
(Subp
))))
459 ("result subtype does not match controlling type", Subp
);
462 elsif Comes_From_Source
(Subp
) then
464 ("operation can be dispatching in only one type", Subp
);
468 end Check_Controlling_Formals
;
470 ----------------------------
471 -- Check_Controlling_Type --
472 ----------------------------
474 function Check_Controlling_Type
476 Subp
: Entity_Id
) return Entity_Id
478 Tagged_Type
: Entity_Id
:= Empty
;
481 if Is_Tagged_Type
(T
) then
482 if Is_First_Subtype
(T
) then
485 Tagged_Type
:= Base_Type
(T
);
488 -- If the type is incomplete, it may have been declared without a
489 -- Tagged indication, but the full view may be tagged, in which case
490 -- that is the controlling type of the subprogram. This is one of the
491 -- approx. 579 places in the language where a lookahead would help.
493 elsif Ekind
(T
) = E_Incomplete_Type
494 and then Present
(Full_View
(T
))
495 and then Is_Tagged_Type
(Full_View
(T
))
497 Set_Is_Tagged_Type
(T
);
498 Tagged_Type
:= Full_View
(T
);
500 elsif Ekind
(T
) = E_Anonymous_Access_Type
501 and then Is_Tagged_Type
(Designated_Type
(T
))
503 if Ekind
(Designated_Type
(T
)) /= E_Incomplete_Type
then
504 if Is_First_Subtype
(Designated_Type
(T
)) then
505 Tagged_Type
:= Designated_Type
(T
);
507 Tagged_Type
:= Base_Type
(Designated_Type
(T
));
510 -- Ada 2005: an incomplete type can be tagged. An operation with an
511 -- access parameter of the type is dispatching.
513 elsif Scope
(Designated_Type
(T
)) = Current_Scope
then
514 Tagged_Type
:= Designated_Type
(T
);
516 -- Ada 2005 (AI-50217)
518 elsif From_Limited_With
(Designated_Type
(T
))
519 and then Has_Non_Limited_View
(Designated_Type
(T
))
520 and then Scope
(Designated_Type
(T
)) = Scope
(Subp
)
522 if Is_First_Subtype
(Non_Limited_View
(Designated_Type
(T
))) then
523 Tagged_Type
:= Non_Limited_View
(Designated_Type
(T
));
525 Tagged_Type
:= Base_Type
(Non_Limited_View
526 (Designated_Type
(T
)));
531 if No
(Tagged_Type
) or else Is_Class_Wide_Type
(Tagged_Type
) then
534 -- In the special case of a protected subprogram of a tagged protected
535 -- type that has a formal of a tagged type (or access formal whose type
536 -- designates a tagged type), such a formal is not controlling unless
537 -- it's of the protected type's corresponding record type. The latter
538 -- can occur for the special wrapper subprograms created for protected
539 -- subprograms. Such subprograms may occur in the same scope where some
540 -- formal's tagged type is declared, and we don't want formals of that
541 -- tagged type being marked as controlling, for one thing because they
542 -- aren't controlling from the language point of view, but also because
543 -- this can cause errors for access formals when conformance is checked
544 -- between the spec and body of the protected subprogram (null-exclusion
545 -- status of the formals may be set differently, which is the case that
546 -- led to adding this check).
548 elsif Is_Subprogram
(Subp
)
549 and then Present
(Protected_Subprogram
(Subp
))
550 and then Ekind
(Scope
(Protected_Subprogram
(Subp
))) = E_Protected_Type
552 Base_Type
(Tagged_Type
)
553 /= Corresponding_Record_Type
(Scope
(Protected_Subprogram
(Subp
)))
557 -- The dispatching type and the primitive operation must be defined in
558 -- the same scope, except in the case of abstract formal subprograms.
560 elsif (Scope
(Subp
) = Scope
(Tagged_Type
)
561 and then (not Is_Generic_Type
(Tagged_Type
)
562 or else not Comes_From_Source
(Subp
)))
564 (Is_Formal_Subprogram
(Subp
) and then Is_Abstract_Subprogram
(Subp
))
566 (Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Renaming_Declaration
568 Present
(Corresponding_Formal_Spec
(Parent
(Parent
(Subp
))))
570 Is_Abstract_Subprogram
(Subp
))
577 end Check_Controlling_Type
;
579 ----------------------------
580 -- Check_Dispatching_Call --
581 ----------------------------
583 procedure Check_Dispatching_Call
(N
: Node_Id
) is
584 Loc
: constant Source_Ptr
:= Sloc
(N
);
587 Control
: Node_Id
:= Empty
;
589 Subp_Entity
: Entity_Id
;
591 Indeterm_Ctrl_Type
: Entity_Id
:= Empty
;
592 -- Type of a controlling formal whose actual is a tag-indeterminate call
593 -- whose result type is different from, but is an ancestor of, the type.
595 Static_Tag
: Node_Id
:= Empty
;
596 -- If a controlling formal has a statically tagged actual, the tag of
597 -- this actual is to be used for any tag-indeterminate actual.
599 procedure Check_Direct_Call
;
600 -- In the case when the controlling actual is a class-wide type whose
601 -- root type's completion is a task or protected type, the call is in
602 -- fact direct. This routine detects the above case and modifies the
605 procedure Check_Dispatching_Context
(Call
: Node_Id
);
606 -- If the call is tag-indeterminate and the entity being called is
607 -- abstract, verify that the context is a call that will eventually
608 -- provide a tag for dispatching, or has provided one already.
610 -----------------------
611 -- Check_Direct_Call --
612 -----------------------
614 procedure Check_Direct_Call
is
615 Typ
: Entity_Id
:= Etype
(Control
);
617 -- Predefined primitives do not receive wrappers since they are built
618 -- from scratch for the corresponding record of synchronized types.
619 -- Equality is in general predefined, but is excluded from the check
620 -- when it is user-defined.
622 if Is_Predefined_Dispatching_Operation
(Subp_Entity
)
623 and then not (Is_User_Defined_Equality
(Subp_Entity
)
624 and then Comes_From_Source
(Subp_Entity
)
625 and then Nkind
(Parent
(Subp_Entity
)) =
626 N_Function_Specification
)
631 if Is_Class_Wide_Type
(Typ
) then
632 Typ
:= Root_Type
(Typ
);
635 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
636 Typ
:= Full_View
(Typ
);
639 if Is_Concurrent_Type
(Typ
)
641 Present
(Corresponding_Record_Type
(Typ
))
643 Typ
:= Corresponding_Record_Type
(Typ
);
645 -- The concurrent record's list of primitives should contain a
646 -- wrapper for the entity of the call, retrieve it.
651 Wrapper_Found
: Boolean := False;
654 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
655 while Present
(Prim_Elmt
) loop
656 Prim
:= Node
(Prim_Elmt
);
658 if Is_Primitive_Wrapper
(Prim
)
659 and then Wrapped_Entity
(Prim
) = Subp_Entity
661 Wrapper_Found
:= True;
665 Next_Elmt
(Prim_Elmt
);
668 -- A primitive declared between two views should have a
669 -- corresponding wrapper.
671 pragma Assert
(Wrapper_Found
);
673 -- Modify the call by setting the proper entity
675 Set_Entity
(Name
(N
), Prim
);
678 end Check_Direct_Call
;
680 -------------------------------
681 -- Check_Dispatching_Context --
682 -------------------------------
684 procedure Check_Dispatching_Context
(Call
: Node_Id
) is
685 Subp
: constant Entity_Id
:= Entity
(Name
(Call
));
687 procedure Abstract_Context_Error
;
688 -- Error for abstract call dispatching on result is not dispatching
690 function Has_Controlling_Current_Instance_Actual_In_DIC
691 (Call
: Node_Id
) return Boolean;
692 -- Return True if the subprogram call Call has a controlling actual
693 -- given directly by a current instance referenced within a DIC
696 ----------------------------
697 -- Abstract_Context_Error --
698 ----------------------------
700 procedure Abstract_Context_Error
is
702 if Ekind
(Subp
) = E_Function
then
704 ("call to abstract function must be dispatching", N
);
706 -- This error can occur for a procedure in the case of a call to
707 -- an abstract formal procedure with a statically tagged operand.
711 ("call to abstract procedure must be dispatching", N
);
713 end Abstract_Context_Error
;
715 ----------------------------------------
716 -- Has_Current_Instance_Actual_In_DIC --
717 ----------------------------------------
719 function Has_Controlling_Current_Instance_Actual_In_DIC
720 (Call
: Node_Id
) return Boolean
725 F
:= First_Formal
(Subp_Entity
);
726 A
:= First_Actual
(Call
);
728 while Present
(F
) loop
730 -- Return True if the actual denotes a current instance (which
731 -- will be represented by an in-mode formal of the enclosing
732 -- DIC_Procedure) passed to a controlling formal. We don't have
733 -- to worry about controlling access formals here, because its
734 -- illegal to apply Access (etc.) attributes to a current
735 -- instance within an aspect (by AI12-0068).
737 if Is_Controlling_Formal
(F
)
738 and then Nkind
(A
) = N_Identifier
739 and then Ekind
(Entity
(A
)) = E_In_Parameter
740 and then Is_Subprogram
(Scope
(Entity
(A
)))
741 and then Is_DIC_Procedure
(Scope
(Entity
(A
)))
751 end Has_Controlling_Current_Instance_Actual_In_DIC
;
755 Scop
: constant Entity_Id
:= Current_Scope_No_Loops
;
756 Typ
: constant Entity_Id
:= Etype
(Subp
);
759 -- Start of processing for Check_Dispatching_Context
762 -- Skip checking context of dispatching calls during preanalysis of
763 -- class-wide conditions since at that stage the expression is not
764 -- installed yet on its definite context.
766 if Inside_Class_Condition_Preanalysis
then
770 -- If the called subprogram is a private overriding, replace it
771 -- with its alias, which has the correct body. Verify that the
772 -- two subprograms have the same controlling type (this is not the
773 -- case for an inherited subprogram that has become abstract).
775 if Is_Abstract_Subprogram
(Subp
)
776 and then No
(Controlling_Argument
(Call
))
778 if Present
(Alias
(Subp
))
779 and then not Is_Abstract_Subprogram
(Alias
(Subp
))
780 and then No
(DTC_Entity
(Subp
))
781 and then Find_Dispatching_Type
(Subp
) =
782 Find_Dispatching_Type
(Alias
(Subp
))
784 -- Private overriding of inherited abstract operation, call is
787 Set_Entity
(Name
(N
), Alias
(Subp
));
790 -- If this is a pre/postcondition for an abstract subprogram,
791 -- it may call another abstract function that is a primitive
792 -- of an abstract type. The call is nondispatching but will be
793 -- legal in overridings of the operation. However, if the call
794 -- is tag-indeterminate we want to continue with with the error
795 -- checking below, as this case is illegal even for abstract
796 -- subprograms (see AI12-0170).
798 -- Similarly, as per AI12-0412, a nonabstract subprogram may
799 -- have a class-wide pre/postcondition that includes a call to
800 -- an abstract primitive of the subprogram's controlling type.
801 -- Certain operations (nondispatching calls, 'Access, use as
802 -- a generic actual) applied to such a nonabstract subprogram
803 -- are illegal in the case where the type is abstract (see
804 -- RM 6.1.1(18.2/5)).
806 elsif Is_Subprogram
(Scop
)
807 and then not Is_Tag_Indeterminate
(N
)
809 -- The context is an internally built helper or an indirect
810 -- call wrapper that handles class-wide preconditions
811 (Present
(Class_Preconditions_Subprogram
(Scop
))
813 -- ... or the context is a class-wide pre/postcondition.
815 (In_Pre_Post_Condition
(Call
, Class_Wide_Only
=> True)
817 -- The tagged type associated with the called
818 -- subprogram must be the same as that of the
819 -- subprogram with a class-wide aspect.
821 and then Is_Dispatching_Operation
(Scop
)
822 and then Find_Dispatching_Type
(Subp
)
823 = Find_Dispatching_Type
(Scop
)))
827 -- Similarly to the dispensation for postconditions, a call to
828 -- an abstract function within a Default_Initial_Condition aspect
829 -- can be legal when passed a current instance of the type. Such
830 -- a call will be effectively mapped to a call to a primitive of
831 -- a descendant type (see AI12-0397, as well as AI12-0170), so
832 -- doesn't need to be dispatching. We test for being within a DIC
833 -- procedure, since that's where the call will be analyzed.
835 elsif Is_Subprogram
(Scop
)
836 and then Is_DIC_Procedure
(Scop
)
837 and then Has_Controlling_Current_Instance_Actual_In_DIC
(Call
)
841 elsif Ekind
(Current_Scope
) = E_Function
842 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
843 N_Generic_Subprogram_Declaration
848 -- We need to determine whether the context of the call
849 -- provides a tag to make the call dispatching. This requires
850 -- the call to be the actual in an enclosing call, and that
851 -- actual must be controlling. If the call is an operand of
852 -- equality, the other operand must not be abstract.
854 if not Is_Tagged_Type
(Typ
)
856 (Ekind
(Typ
) = E_Anonymous_Access_Type
857 and then Is_Tagged_Type
(Designated_Type
(Typ
)))
859 Abstract_Context_Error
;
863 Par
:= Parent
(Call
);
865 if Nkind
(Par
) = N_Parameter_Association
then
869 if Nkind
(Par
) = N_Qualified_Expression
870 or else Nkind
(Par
) = N_Unchecked_Type_Conversion
875 if Nkind
(Par
) in N_Subprogram_Call
876 and then Is_Entity_Name
(Name
(Par
))
879 Enc_Subp
: constant Entity_Id
:= Entity
(Name
(Par
));
883 Ret_Type
: Entity_Id
;
886 -- Find controlling formal that can provide tag for the
887 -- tag-indeterminate actual. The corresponding actual
888 -- must be the corresponding class-wide type.
890 F
:= First_Formal
(Enc_Subp
);
891 A
:= First_Actual
(Par
);
893 -- Find controlling type of call. Dereference if function
894 -- returns an access type.
896 Ret_Type
:= Etype
(Call
);
897 if Is_Access_Type
(Etype
(Call
)) then
898 Ret_Type
:= Designated_Type
(Ret_Type
);
901 while Present
(F
) loop
902 Control
:= Etype
(A
);
904 if Is_Access_Type
(Control
) then
905 Control
:= Designated_Type
(Control
);
908 if Is_Controlling_Formal
(F
)
909 and then not (Call
= A
or else Parent
(Call
) = A
)
910 and then Control
= Class_Wide_Type
(Ret_Type
)
919 if Nkind
(Par
) = N_Function_Call
920 and then Is_Tag_Indeterminate
(Par
)
922 -- The parent may be an actual of an enclosing call
924 Check_Dispatching_Context
(Par
);
929 ("call to abstract function must be dispatching",
935 -- For equality operators, one of the operands must be
936 -- statically or dynamically tagged.
938 elsif Nkind
(Par
) in N_Op_Eq | N_Op_Ne
then
939 if N
= Right_Opnd
(Par
)
940 and then Is_Tag_Indeterminate
(Left_Opnd
(Par
))
942 Abstract_Context_Error
;
944 elsif N
= Left_Opnd
(Par
)
945 and then Is_Tag_Indeterminate
(Right_Opnd
(Par
))
947 Abstract_Context_Error
;
952 -- The left-hand side of an assignment provides the tag
954 elsif Nkind
(Par
) = N_Assignment_Statement
then
958 Abstract_Context_Error
;
962 end Check_Dispatching_Context
;
964 -- Start of processing for Check_Dispatching_Call
967 -- Find a controlling argument, if any
969 if Present
(Parameter_Associations
(N
)) then
970 Subp_Entity
:= Entity
(Name
(N
));
972 Actual
:= First_Actual
(N
);
973 Formal
:= First_Formal
(Subp_Entity
);
974 while Present
(Actual
) loop
975 Control
:= Find_Controlling_Arg
(Actual
);
976 exit when Present
(Control
);
978 -- Check for the case where the actual is a tag-indeterminate call
979 -- whose result type is different than the tagged type associated
980 -- with the containing call, but is an ancestor of the type.
982 if Is_Controlling_Formal
(Formal
)
983 and then Is_Tag_Indeterminate
(Actual
)
984 and then Base_Type
(Etype
(Actual
)) /= Base_Type
(Etype
(Formal
))
985 and then Is_Ancestor
(Etype
(Actual
), Etype
(Formal
))
987 Indeterm_Ctrl_Type
:= Etype
(Formal
);
989 -- If the formal is controlling but the actual is not, the type
990 -- of the actual is statically known, and may be used as the
991 -- controlling tag for some other tag-indeterminate actual.
993 elsif Is_Controlling_Formal
(Formal
)
994 and then Is_Entity_Name
(Actual
)
995 and then Is_Tagged_Type
(Etype
(Actual
))
997 Static_Tag
:= Etype
(Actual
);
1000 Next_Actual
(Actual
);
1001 Next_Formal
(Formal
);
1004 if Present
(Control
) then
1006 -- Verify that no controlling arguments are statically tagged
1008 if Debug_Flag_E
then
1009 Write_Str
("Found Dispatching call");
1010 Write_Int
(Int
(N
));
1014 Actual
:= First_Actual
(N
);
1015 while Present
(Actual
) loop
1016 if Actual
/= Control
then
1018 if not Is_Controlling_Actual
(Actual
) then
1019 null; -- Can be anything
1021 elsif Is_Dynamically_Tagged
(Actual
) then
1022 null; -- Valid parameter
1024 elsif Is_Tag_Indeterminate
(Actual
) then
1026 -- The tag is inherited from the enclosing call (the node
1027 -- we are currently analyzing). Explicitly expand the
1028 -- actual, since the previous call to Expand (from
1029 -- Resolve_Call) had no way of knowing about the
1030 -- required dispatching.
1032 Propagate_Tag
(Control
, Actual
);
1036 ("controlling argument is not dynamically tagged",
1042 Next_Actual
(Actual
);
1045 -- Mark call as a dispatching call
1047 Set_Controlling_Argument
(N
, Control
);
1048 Check_Restriction
(No_Dispatching_Calls
, N
);
1050 -- The dispatching call may need to be converted into a direct
1051 -- call in certain cases.
1055 -- If the call doesn't have a controlling actual but does have an
1056 -- indeterminate actual that requires dispatching treatment, then an
1057 -- object is needed that will serve as the controlling argument for
1058 -- a dispatching call on the indeterminate actual. This can occur
1059 -- in the unusual situation of a default actual given by a tag-
1060 -- indeterminate call and where the type of the call is an ancestor
1061 -- of the type associated with a containing call to an inherited
1062 -- operation (see AI-239).
1064 -- Rather than create an object of the tagged type, which would
1065 -- be problematic for various reasons (default initialization,
1066 -- discriminants), the tag of the containing call's associated
1067 -- tagged type is directly used to control the dispatching.
1069 elsif Present
(Indeterm_Ctrl_Type
) then
1070 if Present
(Static_Tag
) then
1072 Make_Attribute_Reference
(Loc
,
1074 New_Occurrence_Of
(Static_Tag
, Loc
),
1075 Attribute_Name
=> Name_Tag
);
1079 Make_Attribute_Reference
(Loc
,
1081 New_Occurrence_Of
(Indeterm_Ctrl_Type
, Loc
),
1082 Attribute_Name
=> Name_Tag
);
1087 Actual
:= First_Actual
(N
);
1088 Formal
:= First_Formal
(Subp_Entity
);
1089 while Present
(Actual
) loop
1090 if Is_Tag_Indeterminate
(Actual
)
1091 and then Is_Controlling_Formal
(Formal
)
1093 Propagate_Tag
(Control
, Actual
);
1096 Next_Actual
(Actual
);
1097 Next_Formal
(Formal
);
1100 Check_Dispatching_Context
(N
);
1102 elsif Nkind
(N
) /= N_Function_Call
then
1104 -- The call is not dispatching, so check that there aren't any
1105 -- tag-indeterminate abstract calls left among its actuals.
1107 Actual
:= First_Actual
(N
);
1108 while Present
(Actual
) loop
1109 if Is_Tag_Indeterminate
(Actual
) then
1111 -- Function call case
1113 if Nkind
(Original_Node
(Actual
)) = N_Function_Call
then
1114 Func
:= Entity
(Name
(Original_Node
(Actual
)));
1116 -- If the actual is an attribute then it can't be abstract
1117 -- (the only current case of a tag-indeterminate attribute
1118 -- is the stream Input attribute).
1120 elsif Nkind
(Original_Node
(Actual
)) = N_Attribute_Reference
1124 -- Ditto if it is an explicit dereference
1126 elsif Nkind
(Original_Node
(Actual
)) = N_Explicit_Dereference
1130 -- Only other possibility is a qualified expression whose
1131 -- constituent expression is itself a call.
1135 Entity
(Name
(Original_Node
1136 (Expression
(Original_Node
(Actual
)))));
1139 if Present
(Func
) and then Is_Abstract_Subprogram
(Func
) then
1141 ("call to abstract function must be dispatching",
1146 Next_Actual
(Actual
);
1149 Check_Dispatching_Context
(N
);
1151 elsif Nkind
(Parent
(N
)) in N_Subexpr
then
1152 Check_Dispatching_Context
(N
);
1154 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
1155 and then Is_Class_Wide_Type
(Etype
(Name
(Parent
(N
))))
1159 elsif Is_Abstract_Subprogram
(Subp_Entity
) then
1160 Check_Dispatching_Context
(N
);
1164 -- If this is a nondispatching call to a nonabstract subprogram
1165 -- and the subprogram has any Pre'Class or Post'Class aspects with
1166 -- nonstatic values, then report an error. This is specified by
1167 -- RM 6.1.1(18.2/5) (by AI12-0412).
1169 -- Skip reporting this error on helpers and indirect-call wrappers
1170 -- built to support class-wide preconditions.
1173 and then not Is_Abstract_Subprogram
(Subp_Entity
)
1175 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Subp_Entity
)
1177 (Is_Subprogram
(Current_Scope
)
1179 Present
(Class_Preconditions_Subprogram
(Current_Scope
)))
1182 ("nondispatching call to nonabstract subprogram of "
1183 & "abstract type with nonstatic class-wide "
1184 & "pre/postconditions",
1189 -- If dispatching on result, the enclosing call, if any, will
1190 -- determine the controlling argument. Otherwise this is the
1191 -- primitive operation of the root type.
1193 Check_Dispatching_Context
(N
);
1195 end Check_Dispatching_Call
;
1197 ---------------------------------
1198 -- Check_Dispatching_Operation --
1199 ---------------------------------
1201 procedure Check_Dispatching_Operation
(Subp
, Old_Subp
: Entity_Id
) is
1202 function Is_Access_To_Subprogram_Wrapper
(E
: Entity_Id
) return Boolean;
1203 -- Return True if E is an access to subprogram wrapper
1205 procedure Warn_On_Late_Primitive_After_Private_Extension
1208 -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
1209 -- if it is a public primitive defined after some private extension of
1212 -------------------------------------
1213 -- Is_Access_To_Subprogram_Wrapper --
1214 -------------------------------------
1216 function Is_Access_To_Subprogram_Wrapper
(E
: Entity_Id
) return Boolean
1218 Decl_N
: constant Node_Id
:= Unit_Declaration_Node
(E
);
1219 Par_N
: constant Node_Id
:= Parent
(List_Containing
(Decl_N
));
1222 -- Access to subprogram wrappers are declared in the freezing actions
1224 return Nkind
(Par_N
) = N_Freeze_Entity
1225 and then Ekind
(Entity
(Par_N
)) = E_Access_Subprogram_Type
;
1226 end Is_Access_To_Subprogram_Wrapper
;
1228 ----------------------------------------------------
1229 -- Warn_On_Late_Primitive_After_Private_Extension --
1230 ----------------------------------------------------
1232 procedure Warn_On_Late_Primitive_After_Private_Extension
1239 if Warn_On_Late_Primitives
1240 and then Comes_From_Source
(Prim
)
1241 and then Has_Private_Extension
(Typ
)
1242 and then Is_Package_Or_Generic_Package
(Current_Scope
)
1243 and then not In_Private_Part
(Current_Scope
)
1245 E
:= Next_Entity
(Typ
);
1247 while E
/= Prim
loop
1248 if Ekind
(E
) = E_Record_Type_With_Private
1249 and then Etype
(E
) = Typ
1251 Error_Msg_Name_1
:= Chars
(Typ
);
1252 Error_Msg_Name_2
:= Chars
(E
);
1253 Error_Msg_Sloc
:= Sloc
(E
);
1255 ("?.j?primitive of type % defined after private extension "
1257 Error_Msg_Name_1
:= Chars
(Prim
);
1258 Error_Msg_Name_2
:= Chars
(E
);
1260 ("\spec of % should appear before declaration of type %!",
1268 end Warn_On_Late_Primitive_After_Private_Extension
;
1272 Body_Is_Last_Primitive
: Boolean := False;
1273 Has_Dispatching_Parent
: Boolean := False;
1274 Ovr_Subp
: Entity_Id
:= Empty
;
1275 Tagged_Type
: Entity_Id
;
1277 -- Start of processing for Check_Dispatching_Operation
1280 if Ekind
(Subp
) not in E_Function | E_Procedure
then
1283 -- The Default_Initial_Condition procedure is not a primitive subprogram
1284 -- even if it relates to a tagged type. This routine is not meant to be
1285 -- inherited or overridden.
1287 elsif Is_DIC_Procedure
(Subp
) then
1290 -- The "partial" and "full" type invariant procedures are not primitive
1291 -- subprograms even if they relate to a tagged type. These routines are
1292 -- not meant to be inherited or overridden.
1294 elsif Is_Invariant_Procedure
(Subp
)
1295 or else Is_Partial_Invariant_Procedure
(Subp
)
1299 -- Wrappers of access to subprograms are not primitive subprograms.
1301 elsif Is_Wrapper
(Subp
)
1302 and then Is_Access_To_Subprogram_Wrapper
(Subp
)
1307 Set_Is_Dispatching_Operation
(Subp
, False);
1308 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
1310 -- Ada 2005 (AI-345): Use the corresponding record (if available).
1311 -- Required because primitives of concurrent types are attached
1312 -- to the corresponding record (not to the concurrent type).
1314 if Ada_Version
>= Ada_2005
1315 and then Present
(Tagged_Type
)
1316 and then Is_Concurrent_Type
(Tagged_Type
)
1317 and then Present
(Corresponding_Record_Type
(Tagged_Type
))
1319 Tagged_Type
:= Corresponding_Record_Type
(Tagged_Type
);
1322 -- (AI-345): The task body procedure is not a primitive of the tagged
1325 if Present
(Tagged_Type
)
1326 and then Is_Concurrent_Record_Type
(Tagged_Type
)
1327 and then Present
(Corresponding_Concurrent_Type
(Tagged_Type
))
1328 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Tagged_Type
))
1329 and then Subp
= Get_Task_Body_Procedure
1330 (Corresponding_Concurrent_Type
(Tagged_Type
))
1335 -- If Subp is derived from a dispatching operation then it should
1336 -- always be treated as dispatching. In this case various checks
1337 -- below will be bypassed. Makes sure that late declarations for
1338 -- inherited private subprograms are treated as dispatching, even
1339 -- if the associated tagged type is already frozen.
1341 Has_Dispatching_Parent
:=
1342 Present
(Alias
(Subp
))
1343 and then Is_Dispatching_Operation
(Alias
(Subp
));
1345 if No
(Tagged_Type
) then
1347 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
1348 -- with an abstract interface type unless the interface acts as a
1349 -- parent type in a derivation. If the interface type is a formal
1350 -- type then the operation is not primitive and therefore legal.
1357 E
:= First_Entity
(Subp
);
1358 while Present
(E
) loop
1360 -- For an access parameter, check designated type
1362 if Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
then
1363 Typ
:= Designated_Type
(Etype
(E
));
1368 if Comes_From_Source
(Subp
)
1369 and then Is_Interface
(Typ
)
1370 and then not Is_Class_Wide_Type
(Typ
)
1371 and then not Is_Derived_Type
(Typ
)
1372 and then not Is_Generic_Type
(Typ
)
1373 and then not In_Instance
1375 Error_Msg_N
("??declaration of& is too late!", Subp
);
1376 Error_Msg_NE
-- CODEFIX??
1377 ("\??spec should appear immediately after declaration of "
1378 & "& !", Subp
, Typ
);
1385 -- In case of functions check also the result type
1387 if Ekind
(Subp
) = E_Function
then
1388 if Is_Access_Type
(Etype
(Subp
)) then
1389 Typ
:= Designated_Type
(Etype
(Subp
));
1391 Typ
:= Etype
(Subp
);
1394 -- Report warning on non dispatching primitives of interface
1395 -- type Typ; this warning is disabled when the type has the
1396 -- aspect First_Controlling_Parameter because we will report
1397 -- an error when the interface type is frozen.
1399 if Comes_From_Source
(Subp
)
1400 and then Is_Interface
(Typ
)
1401 and then not Is_Class_Wide_Type
(Typ
)
1402 and then not Is_Derived_Type
(Typ
)
1403 and then not Is_Generic_Type
(Typ
)
1404 and then not In_Instance
1405 and then not Has_First_Controlling_Parameter_Aspect
(Typ
)
1407 Error_Msg_N
("??declaration of& is too late!", Subp
);
1409 ("\??spec should appear immediately after declaration of "
1410 & "& !", Subp
, Typ
);
1417 -- The subprograms build internally after the freezing point (such as
1418 -- init procs, interface thunks, type support subprograms, and Offset
1419 -- to top functions for accessing interface components in variable
1420 -- size tagged types) are not primitives.
1422 elsif Is_Frozen
(Tagged_Type
)
1423 and then not Comes_From_Source
(Subp
)
1424 and then not Has_Dispatching_Parent
1426 -- Complete decoration of internally built subprograms that override
1427 -- a dispatching primitive. These entities correspond with the
1430 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
1431 -- to override functions of nonabstract null extensions. These
1432 -- primitives were added to the list of primitives of the tagged
1433 -- type by Make_Controlling_Function_Wrappers. However, attribute
1434 -- Is_Dispatching_Operation must be set to true.
1436 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
1439 -- 3. Subprograms associated with stream attributes (built by
1440 -- New_Stream_Subprogram) or with the Put_Image attribute.
1442 -- 4. Wrappers built for inherited operations. We have two kinds:
1443 -- * Wrappers built for inherited operations with inherited class-
1444 -- wide conditions, where the conditions include calls to other
1445 -- overridden primitives. The wrappers include checks on these
1446 -- modified conditions (AI12-195).
1447 -- * Wrappers built for inherited operations that implement
1448 -- interface primitives that have class-wide postconditions.
1450 -- 5. Declarations built for subprograms without separate specs that
1451 -- are eligible for inlining in GNATprove (inside
1452 -- Sem_Ch6.Analyze_Subprogram_Body_Helper).
1454 if Present
(Old_Subp
)
1455 and then Present
(Overridden_Operation
(Subp
))
1456 and then Is_Dispatching_Operation
(Old_Subp
)
1459 ((Ekind
(Subp
) = E_Function
1460 and then Is_Dispatching_Operation
(Old_Subp
)
1461 and then Is_Null_Extension
(Base_Type
(Etype
(Subp
))))
1464 (Ekind
(Subp
) = E_Procedure
1465 and then Is_Dispatching_Operation
(Old_Subp
)
1466 and then Present
(Alias
(Old_Subp
))
1467 and then Is_Null_Interface_Primitive
1468 (Ultimate_Alias
(Old_Subp
)))
1470 or else Get_TSS_Name
(Subp
) in TSS_Stream_Read
1476 and then Is_Dispatch_Table_Wrapper
(Subp
))
1478 or else GNATprove_Mode
);
1480 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1481 Override_Dispatching_Operation
(Tagged_Type
, Old_Subp
, Subp
);
1482 Set_Is_Dispatching_Operation
(Subp
);
1487 -- The operation may be a child unit, whose scope is the defining
1488 -- package, but which is not a primitive operation of the type.
1490 elsif Is_Child_Unit
(Subp
) then
1493 -- If the subprogram is not defined in a package spec, the only case
1494 -- where it can be a dispatching op is when it overrides an operation
1495 -- before the freezing point of the type.
1497 elsif (not Is_Package_Or_Generic_Package
(Scope
(Subp
))
1498 or else In_Package_Body
(Scope
(Subp
)))
1499 and then not Has_Dispatching_Parent
1501 if not Comes_From_Source
(Subp
)
1502 or else (Present
(Old_Subp
) and then not Is_Frozen
(Tagged_Type
))
1506 -- If the type is already frozen, the overriding is not allowed
1507 -- except when Old_Subp is not a dispatching operation (which can
1508 -- occur when Old_Subp was inherited by an untagged type). However,
1509 -- a body with no previous spec freezes the type *after* its
1510 -- declaration, and therefore is a legal overriding (unless the type
1511 -- has already been frozen). Only the first such body is legal.
1513 elsif Present
(Old_Subp
)
1514 and then Is_Dispatching_Operation
(Old_Subp
)
1516 if Comes_From_Source
(Subp
)
1518 (Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Body
1519 or else Nkind
(Unit_Declaration_Node
(Subp
)) in N_Body_Stub
)
1522 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1523 Decl_Item
: Node_Id
;
1526 -- ??? The checks here for whether the type has been frozen
1527 -- prior to the new body are not complete. It's not simple
1528 -- to check frozenness at this point since the body has
1529 -- already caused the type to be prematurely frozen in
1530 -- Analyze_Declarations, but we're forced to recheck this
1531 -- here because of the odd rule interpretation that allows
1532 -- the overriding if the type wasn't frozen prior to the
1533 -- body. The freezing action should probably be delayed
1534 -- until after the spec is seen, but that's a tricky
1535 -- change to the delicate freezing code.
1537 -- Look at each declaration following the type up until the
1538 -- new subprogram body. If any of the declarations is a body
1539 -- then the type has been frozen already so the overriding
1540 -- primitive is illegal.
1542 Decl_Item
:= Next
(Parent
(Tagged_Type
));
1543 while Present
(Decl_Item
)
1544 and then Decl_Item
/= Subp_Body
1546 if Comes_From_Source
(Decl_Item
)
1547 and then (Nkind
(Decl_Item
) in N_Proper_Body
1548 or else Nkind
(Decl_Item
) in N_Body_Stub
)
1550 Error_Msg_N
("overriding of& is too late!", Subp
);
1552 ("\spec should appear immediately after the type!",
1560 -- If the subprogram doesn't follow in the list of
1561 -- declarations including the type then the type has
1562 -- definitely been frozen already and the body is illegal.
1564 if No
(Decl_Item
) then
1565 Error_Msg_N
("overriding of& is too late!", Subp
);
1567 ("\spec should appear immediately after the type!",
1571 -- The subprogram body declares a primitive operation.
1572 -- We must update its dispatching information here. The
1573 -- information is taken from the overridden subprogram.
1574 -- Such a late-overriding body also needs extra formals.
1575 -- We must also generate a cross-reference entry because
1576 -- references to other primitives were already created
1577 -- when type was frozen.
1579 Body_Is_Last_Primitive
:= True;
1581 if Present
(DTC_Entity
(Old_Subp
)) then
1582 Set_DTC_Entity
(Subp
, DTC_Entity
(Old_Subp
));
1583 Set_DT_Position_Value
(Subp
, DT_Position
(Old_Subp
));
1584 Create_Extra_Formals
(Subp
);
1586 if not Restriction_Active
(No_Dispatching_Calls
) then
1587 if Building_Static_DT
(Tagged_Type
) then
1589 -- If the static dispatch table has not been
1590 -- built then there is nothing else to do now;
1591 -- otherwise we notify that we cannot build the
1592 -- static dispatch table.
1594 if Has_Dispatch_Table
(Tagged_Type
) then
1596 ("overriding of& is too late for building "
1597 & " static dispatch tables!", Subp
);
1599 ("\spec should appear immediately after "
1600 & "the type!", Subp
);
1603 -- No code required to register primitives in VM
1606 elsif not Tagged_Type_Expansion
then
1610 Insert_Actions_After
(Subp_Body
,
1611 Register_Primitive
(Sloc
(Subp_Body
),
1615 -- Indicate that this is an overriding operation,
1616 -- and replace the overridden entry in the list of
1617 -- primitive operations, which is used for xref
1618 -- generation subsequently.
1620 Generate_Reference
(Tagged_Type
, Subp
, 'P', False);
1621 Override_Dispatching_Operation
1622 (Tagged_Type
, Old_Subp
, Subp
);
1623 Set_Is_Dispatching_Operation
(Subp
);
1625 -- Inherit decoration of controlling formals and
1626 -- controlling result.
1628 if Ekind
(Old_Subp
) = E_Function
1629 and then Has_Controlling_Result
(Old_Subp
)
1631 Set_Has_Controlling_Result
(Subp
);
1634 if Present
(First_Formal
(Old_Subp
)) then
1636 Old_Formal
: Entity_Id
;
1640 Formal
:= First_Formal
(Subp
);
1641 Old_Formal
:= First_Formal
(Old_Subp
);
1643 while Present
(Old_Formal
) loop
1644 Set_Is_Controlling_Formal
(Formal
,
1645 Is_Controlling_Formal
(Old_Formal
));
1647 Next_Formal
(Formal
);
1648 Next_Formal
(Old_Formal
);
1654 Check_Inherited_Conditions
(Tagged_Type
,
1655 Late_Overriding
=> True);
1661 Error_Msg_N
("overriding of& is too late!", Subp
);
1663 ("\subprogram spec should appear immediately after the type!",
1667 -- If the type is not frozen yet and we are not in the overriding
1668 -- case it looks suspiciously like an attempt to define a primitive
1669 -- operation, which requires the declaration to be in a package spec
1670 -- (3.2.3(6)). Only report cases where the type and subprogram are
1671 -- in the same declaration list (by checking the enclosing parent
1672 -- declarations), to avoid spurious warnings on subprograms in
1673 -- instance bodies when the type is declared in the instance spec
1674 -- but hasn't been frozen by the instance body.
1676 elsif not Is_Frozen
(Tagged_Type
)
1677 and then In_Same_List
(Parent
(Tagged_Type
), Parent
(Parent
(Subp
)))
1680 ("??not dispatching (must be defined in a package spec)", Subp
);
1683 -- When the type is frozen, it is legitimate to define a new
1684 -- non-primitive operation.
1690 -- Now, we are sure that the scope is a package spec. If the subprogram
1691 -- is declared after the freezing point of the type that's an error
1693 elsif Is_Frozen
(Tagged_Type
) and then not Has_Dispatching_Parent
then
1694 Error_Msg_N
("this primitive operation is declared too late", Subp
);
1696 ("??no primitive operations for& after this line",
1697 Freeze_Node
(Tagged_Type
),
1702 Check_Controlling_Formals
(Tagged_Type
, Subp
);
1704 Ovr_Subp
:= Old_Subp
;
1706 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1707 -- overridden by Subp. This only applies to source subprograms, and
1708 -- their declaration must carry an explicit overriding indicator.
1711 and then Ada_Version
>= Ada_2012
1712 and then Comes_From_Source
(Subp
)
1714 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1716 Ovr_Subp
:= Find_Hidden_Overridden_Primitive
(Subp
);
1718 -- Warn if the proper overriding indicator has not been supplied.
1720 if Present
(Ovr_Subp
)
1722 not Must_Override
(Specification
(Unit_Declaration_Node
(Subp
)))
1723 and then not In_Instance
1725 Error_Msg_NE
("missing overriding indicator for&??", Subp
, Subp
);
1729 -- Now it should be a correct primitive operation, put it in the list
1731 if Present
(Ovr_Subp
) then
1733 -- If the type has interfaces we complete this check after we set
1734 -- attribute Is_Dispatching_Operation.
1736 Check_Subtype_Conformant
(Subp
, Ovr_Subp
);
1738 -- A primitive operation with the name of a primitive controlled
1739 -- operation does not override a non-visible overriding controlled
1740 -- operation, i.e. one declared in a private part when the full
1741 -- view of a type is controlled. Conversely, it will override a
1742 -- visible operation that may be declared in a partial view when
1743 -- the full view is controlled.
1745 if Chars
(Subp
) in Name_Initialize | Name_Adjust | Name_Finalize
1746 and then Is_Controlled
(Tagged_Type
)
1747 and then not Is_Visibly_Controlled
(Tagged_Type
)
1748 and then not Is_Inherited_Public_Operation
(Ovr_Subp
)
1750 Set_Overridden_Operation
(Subp
, Empty
);
1752 -- If the subprogram specification carries an overriding
1753 -- indicator, no need for the warning: it is either redundant,
1754 -- or else an error will be reported.
1756 if Nkind
(Parent
(Subp
)) = N_Procedure_Specification
1758 (Must_Override
(Parent
(Subp
))
1759 or else Must_Not_Override
(Parent
(Subp
)))
1763 -- Here we need the warning
1767 ("operation does not override inherited&??", Subp
, Subp
);
1771 Override_Dispatching_Operation
(Tagged_Type
, Ovr_Subp
, Subp
);
1773 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1774 -- that covers abstract interface subprograms we must register it
1775 -- in all the secondary dispatch tables associated with abstract
1776 -- interfaces. We do this now only if not building static tables,
1777 -- nor when the expander is inactive (we avoid trying to register
1778 -- primitives in semantics-only mode, since the type may not have
1779 -- an associated dispatch table). Otherwise the patch code is
1780 -- emitted after those tables are built, to prevent access before
1781 -- elaboration in gigi.
1783 if Body_Is_Last_Primitive
1784 and then not Building_Static_DT
(Tagged_Type
)
1785 and then Expander_Active
1786 and then Tagged_Type_Expansion
1789 Subp_Body
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
1794 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
1795 while Present
(Elmt
) loop
1796 Prim
:= Node
(Elmt
);
1798 if Present
(Alias
(Prim
))
1799 and then Present
(Interface_Alias
(Prim
))
1800 and then Alias
(Prim
) = Subp
1802 Insert_Actions_After
(Subp_Body
,
1803 Register_Primitive
(Sloc
(Subp_Body
), Prim
=> Prim
));
1809 -- Redisplay the contents of the updated dispatch table
1811 if Debug_Flag_ZZ
then
1812 Write_Str
("Late overriding: ");
1813 Write_DT
(Tagged_Type
);
1819 -- If no old subprogram, then we add this as a dispatching operation,
1820 -- but we avoid doing this if an error was posted, to prevent annoying
1823 elsif not Error_Posted
(Subp
) then
1825 -- When aspect First_Controlling_Parameter applies, check if the
1826 -- subprogram is a primitive. Internal subprograms added by the
1827 -- frontend bypass its restrictions.
1829 if Has_First_Controlling_Parameter_Aspect
(Tagged_Type
)
1830 and then not Is_Internal
(Subp
)
1832 (Present
(Overridden_Operation
(Subp
))
1834 Is_Dispatching_Operation
(Overridden_Operation
(Subp
)))
1836 (Present
(Alias
(Subp
))
1838 Is_Dispatching_Operation
(Ultimate_Alias
(Subp
)))
1839 and then (No
(First_Formal
(Subp
))
1841 Is_Controlling_Formal
(First_Formal
(Subp
)))
1843 if Warn_On_Non_Dispatching_Primitives
then
1845 ("?_j?not a dispatching primitive of tagged type&",
1848 ("\?_j?disallowed by 'First_'Controlling_'Parameter on &",
1855 Add_Dispatching_Operation
(Tagged_Type
, Subp
);
1858 Set_Is_Dispatching_Operation
(Subp
, True);
1860 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1861 -- subtype conformance against all the interfaces covered by this
1864 if Present
(Ovr_Subp
)
1865 and then Has_Interfaces
(Tagged_Type
)
1868 Ifaces_List
: Elist_Id
;
1869 Iface_Elmt
: Elmt_Id
;
1870 Iface_Prim_Elmt
: Elmt_Id
;
1871 Iface_Prim
: Entity_Id
;
1872 Ret_Typ
: Entity_Id
;
1875 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
1877 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1878 while Present
(Iface_Elmt
) loop
1879 if not Is_Ancestor
(Node
(Iface_Elmt
), Tagged_Type
) then
1881 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
1882 while Present
(Iface_Prim_Elmt
) loop
1883 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
1885 if Is_Interface_Conformant
1886 (Tagged_Type
, Iface_Prim
, Subp
)
1888 -- Handle procedures, functions whose return type
1889 -- matches, or functions not returning interfaces
1891 if Ekind
(Subp
) = E_Procedure
1892 or else Etype
(Iface_Prim
) = Etype
(Subp
)
1893 or else not Is_Interface
(Etype
(Iface_Prim
))
1895 Check_Subtype_Conformant
1897 Old_Id
=> Iface_Prim
,
1899 Skip_Controlling_Formals
=> True);
1901 -- Handle functions returning interfaces
1903 elsif Implements_Interface
1904 (Etype
(Subp
), Etype
(Iface_Prim
))
1906 -- Temporarily force both entities to return the
1907 -- same type. Required because Subtype_Conformant
1908 -- does not handle this case.
1910 Ret_Typ
:= Etype
(Iface_Prim
);
1911 Set_Etype
(Iface_Prim
, Etype
(Subp
));
1913 Check_Subtype_Conformant
1915 Old_Id
=> Iface_Prim
,
1917 Skip_Controlling_Formals
=> True);
1919 Set_Etype
(Iface_Prim
, Ret_Typ
);
1923 Next_Elmt
(Iface_Prim_Elmt
);
1927 Next_Elmt
(Iface_Elmt
);
1932 if not Body_Is_Last_Primitive
then
1933 Set_DT_Position_Value
(Subp
, No_Uint
);
1935 elsif Has_Controlled_Component
(Tagged_Type
)
1936 and then Chars
(Subp
) in Name_Initialize
1939 | Name_Finalize_Address
1942 F_Node
: constant Node_Id
:= Freeze_Node
(Tagged_Type
);
1946 Old_Spec
: Entity_Id
;
1948 C_Names
: constant array (1 .. 4) of Name_Id
:=
1952 Name_Finalize_Address
);
1954 D_Names
: constant array (1 .. 4) of TSS_Name_Type
:=
1955 (TSS_Deep_Initialize
,
1958 TSS_Finalize_Address
);
1961 -- Remove previous controlled function which was constructed and
1962 -- analyzed when the type was frozen. This requires removing the
1963 -- body of the redefined primitive, as well as its specification
1964 -- if needed (there is no spec created for Deep_Initialize, see
1965 -- exp_ch3.adb). We must also dismantle the exception information
1966 -- that may have been generated for it when front end zero-cost
1967 -- tables are enabled.
1969 for J
in D_Names
'Range loop
1970 Old_P
:= TSS
(Tagged_Type
, D_Names
(J
));
1973 and then Chars
(Subp
) = C_Names
(J
)
1975 Old_Bod
:= Unit_Declaration_Node
(Old_P
);
1977 Set_Is_Eliminated
(Old_P
);
1978 Set_Scope
(Old_P
, Scope
(Current_Scope
));
1980 if Nkind
(Old_Bod
) = N_Subprogram_Body
1981 and then Present
(Corresponding_Spec
(Old_Bod
))
1983 Old_Spec
:= Corresponding_Spec
(Old_Bod
);
1984 Set_Has_Completion
(Old_Spec
, False);
1989 Build_Late_Proc
(Tagged_Type
, Chars
(Subp
));
1991 -- The new operation is added to the actions of the freeze node
1992 -- for the type, but this node has already been analyzed, so we
1993 -- must retrieve and analyze explicitly the new body.
1996 and then Present
(Actions
(F_Node
))
1998 Decl
:= Last
(Actions
(F_Node
));
2004 -- AI12-0279: If the Yield aspect is specified for a dispatching
2005 -- subprogram that inherits the aspect, the specified value shall
2008 if Is_Dispatching_Operation
(Subp
)
2009 and then Is_Primitive_Wrapper
(Subp
)
2010 and then Present
(Wrapped_Entity
(Subp
))
2011 and then Comes_From_Source
(Wrapped_Entity
(Subp
))
2012 and then Present
(Overridden_Operation
(Subp
))
2013 and then Has_Yield_Aspect
(Overridden_Operation
(Subp
))
2014 /= Has_Yield_Aspect
(Wrapped_Entity
(Subp
))
2017 W_Ent
: constant Entity_Id
:= Wrapped_Entity
(Subp
);
2018 W_Decl
: constant Node_Id
:= Parent
(W_Ent
);
2022 Asp
:= First
(Aspect_Specifications
(W_Decl
));
2023 while Present
(Asp
) loop
2024 if Chars
(Identifier
(Asp
)) = Name_Yield
then
2025 Error_Msg_Name_1
:= Name_Yield
;
2027 ("specification of inherited aspect% can only confirm "
2028 & "parent value", Asp
);
2034 Set_Has_Yield_Aspect
(Wrapped_Entity
(Subp
));
2038 -- For similarity with record extensions, in Ada 9X the language should
2039 -- have disallowed adding visible operations to a tagged type after
2040 -- deriving a private extension from it. Report a warning if this
2041 -- primitive is defined after a private extension of Tagged_Type.
2043 Warn_On_Late_Primitive_After_Private_Extension
(Tagged_Type
, Subp
);
2044 end Check_Dispatching_Operation
;
2046 ------------------------------------------
2047 -- Check_Operation_From_Incomplete_Type --
2048 ------------------------------------------
2050 procedure Check_Operation_From_Incomplete_Type
2054 Full
: constant Entity_Id
:= Full_View
(Typ
);
2055 Parent_Typ
: constant Entity_Id
:= Etype
(Full
);
2056 Old_Prim
: constant Elist_Id
:= Primitive_Operations
(Parent_Typ
);
2057 New_Prim
: constant Elist_Id
:= Primitive_Operations
(Full
);
2059 Prev
: Elmt_Id
:= No_Elmt
;
2061 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean;
2062 -- Check that Subp has profile of an operation derived from Parent_Subp.
2063 -- Subp must have a parameter or result type that is Typ or an access
2064 -- parameter or access result type that designates Typ.
2070 function Derives_From
(Parent_Subp
: Entity_Id
) return Boolean is
2074 if Chars
(Parent_Subp
) /= Chars
(Subp
) then
2078 -- Check that the type of controlling formals is derived from the
2079 -- parent subprogram's controlling formal type (or designated type
2080 -- if the formal type is an anonymous access type).
2082 F1
:= First_Formal
(Parent_Subp
);
2083 F2
:= First_Formal
(Subp
);
2084 while Present
(F1
) and then Present
(F2
) loop
2085 if Ekind
(Etype
(F1
)) = E_Anonymous_Access_Type
then
2086 if Ekind
(Etype
(F2
)) /= E_Anonymous_Access_Type
then
2088 elsif Designated_Type
(Etype
(F1
)) = Parent_Typ
2089 and then Designated_Type
(Etype
(F2
)) /= Full
2094 elsif Ekind
(Etype
(F2
)) = E_Anonymous_Access_Type
then
2097 elsif Etype
(F1
) = Parent_Typ
and then Etype
(F2
) /= Full
then
2105 -- Check that a controlling result type is derived from the parent
2106 -- subprogram's result type (or designated type if the result type
2107 -- is an anonymous access type).
2109 if Ekind
(Parent_Subp
) = E_Function
then
2110 if Ekind
(Subp
) /= E_Function
then
2113 elsif Ekind
(Etype
(Parent_Subp
)) = E_Anonymous_Access_Type
then
2114 if Ekind
(Etype
(Subp
)) /= E_Anonymous_Access_Type
then
2117 elsif Designated_Type
(Etype
(Parent_Subp
)) = Parent_Typ
2118 and then Designated_Type
(Etype
(Subp
)) /= Full
2123 elsif Ekind
(Etype
(Subp
)) = E_Anonymous_Access_Type
then
2126 elsif Etype
(Parent_Subp
) = Parent_Typ
2127 and then Etype
(Subp
) /= Full
2132 elsif Ekind
(Subp
) = E_Function
then
2136 return No
(F1
) and then No
(F2
);
2139 -- Start of processing for Check_Operation_From_Incomplete_Type
2142 -- The operation may override an inherited one, or may be a new one
2143 -- altogether. The inherited operation will have been hidden by the
2144 -- current one at the point of the type derivation, so it does not
2145 -- appear in the list of primitive operations of the type. We have to
2146 -- find the proper place of insertion in the list of primitive opera-
2147 -- tions by iterating over the list for the parent type.
2149 Op1
:= First_Elmt
(Old_Prim
);
2150 Op2
:= First_Elmt
(New_Prim
);
2151 while Present
(Op1
) and then Present
(Op2
) loop
2152 if Derives_From
(Node
(Op1
)) then
2155 -- Avoid adding it to the list of primitives if already there
2157 if Node
(Op2
) /= Subp
then
2158 Prepend_Elmt
(Subp
, New_Prim
);
2162 Insert_Elmt_After
(Subp
, Prev
);
2173 -- Operation is a new primitive
2175 Append_Elmt
(Subp
, New_Prim
);
2176 end Check_Operation_From_Incomplete_Type
;
2178 ---------------------------------------
2179 -- Check_Operation_From_Private_View --
2180 ---------------------------------------
2182 procedure Check_Operation_From_Private_View
(Subp
, Old_Subp
: Entity_Id
) is
2183 Tagged_Type
: Entity_Id
;
2186 if Is_Dispatching_Operation
(Alias
(Subp
)) then
2187 Set_Scope
(Subp
, Current_Scope
);
2188 Tagged_Type
:= Find_Dispatching_Type
(Subp
);
2190 -- Add Old_Subp to primitive operations if not already present
2192 if Present
(Tagged_Type
) and then Is_Tagged_Type
(Tagged_Type
) then
2193 Add_Dispatching_Operation
(Tagged_Type
, Old_Subp
);
2195 -- If Old_Subp isn't already marked as dispatching then this is
2196 -- the case of an operation of an untagged private type fulfilled
2197 -- by a tagged type that overrides an inherited dispatching
2198 -- operation, so we set the necessary dispatching attributes here.
2200 if not Is_Dispatching_Operation
(Old_Subp
) then
2202 -- If the untagged type has no discriminants, and the full
2203 -- view is constrained, there will be a spurious mismatch of
2204 -- subtypes on the controlling arguments, because the tagged
2205 -- type is the internal base type introduced in the derivation.
2206 -- Use the original type to verify conformance, rather than the
2209 if not Comes_From_Source
(Tagged_Type
)
2210 and then Has_Discriminants
(Tagged_Type
)
2216 Formal
:= First_Formal
(Old_Subp
);
2217 while Present
(Formal
) loop
2218 if Tagged_Type
= Base_Type
(Etype
(Formal
)) then
2219 Tagged_Type
:= Etype
(Formal
);
2222 Next_Formal
(Formal
);
2226 if Tagged_Type
= Base_Type
(Etype
(Old_Subp
)) then
2227 Tagged_Type
:= Etype
(Old_Subp
);
2231 Check_Controlling_Formals
(Tagged_Type
, Old_Subp
);
2232 Set_Is_Dispatching_Operation
(Old_Subp
, True);
2233 Set_DT_Position_Value
(Old_Subp
, No_Uint
);
2236 -- If the old subprogram is an explicit renaming of some other
2237 -- entity, it is not overridden by the inherited subprogram.
2238 -- Otherwise, update its alias and other attributes.
2240 if Present
(Alias
(Old_Subp
))
2241 and then Nkind
(Unit_Declaration_Node
(Old_Subp
)) /=
2242 N_Subprogram_Renaming_Declaration
2244 Set_Alias
(Old_Subp
, Alias
(Subp
));
2246 -- The derived subprogram should inherit the abstractness of
2247 -- the parent subprogram (except in the case of a function
2248 -- returning the type). This sets the abstractness properly
2249 -- for cases where a private extension may have inherited an
2250 -- abstract operation, but the full type is derived from a
2251 -- descendant type and inherits a nonabstract version.
2253 if Etype
(Subp
) /= Tagged_Type
then
2254 Set_Is_Abstract_Subprogram
2255 (Old_Subp
, Is_Abstract_Subprogram
(Alias
(Subp
)));
2260 end Check_Operation_From_Private_View
;
2262 --------------------------
2263 -- Find_Controlling_Arg --
2264 --------------------------
2266 function Find_Controlling_Arg
(N
: Node_Id
) return Node_Id
is
2267 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
2271 if Nkind
(Orig_Node
) = N_Qualified_Expression
then
2272 return Find_Controlling_Arg
(Expression
(Orig_Node
));
2275 -- Dispatching on result case. If expansion is disabled, the node still
2276 -- has the structure of a function call. However, if the function name
2277 -- is an operator and the call was given in infix form, the original
2278 -- node has no controlling result and we must examine the current node.
2280 if Nkind
(N
) = N_Function_Call
2281 and then Present
(Controlling_Argument
(N
))
2282 and then Has_Controlling_Result
(Entity
(Name
(N
)))
2284 return Controlling_Argument
(N
);
2286 -- If expansion is enabled, the call may have been transformed into
2287 -- an indirect call, and we need to recover the original node.
2289 elsif Nkind
(Orig_Node
) = N_Function_Call
2290 and then Present
(Controlling_Argument
(Orig_Node
))
2291 and then Has_Controlling_Result
(Entity
(Name
(Orig_Node
)))
2293 return Controlling_Argument
(Orig_Node
);
2295 -- Type conversions are dynamically tagged if the target type, or its
2296 -- designated type, are classwide. An interface conversion expands into
2297 -- a dereference, so test must be performed on the original node.
2299 elsif Nkind
(Orig_Node
) = N_Type_Conversion
2300 and then Nkind
(N
) = N_Explicit_Dereference
2301 and then Is_Controlling_Actual
(N
)
2304 Target_Type
: constant Entity_Id
:=
2305 Entity
(Subtype_Mark
(Orig_Node
));
2308 if Is_Class_Wide_Type
(Target_Type
) then
2311 elsif Is_Access_Type
(Target_Type
)
2312 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
2323 elsif Is_Controlling_Actual
(N
)
2325 (Nkind
(Parent
(N
)) = N_Qualified_Expression
2326 and then Is_Controlling_Actual
(Parent
(N
)))
2330 if Is_Access_Type
(Typ
) then
2332 -- In the case of an Access attribute, use the type of the prefix,
2333 -- since in the case of an actual for an access parameter, the
2334 -- attribute's type may be of a specific designated type, even
2335 -- though the prefix type is class-wide.
2337 if Nkind
(N
) = N_Attribute_Reference
then
2338 Typ
:= Etype
(Prefix
(N
));
2340 -- An allocator is dispatching if the type of qualified expression
2341 -- is class_wide, in which case this is the controlling type.
2343 elsif Nkind
(Orig_Node
) = N_Allocator
2344 and then Nkind
(Expression
(Orig_Node
)) = N_Qualified_Expression
2346 Typ
:= Etype
(Expression
(Orig_Node
));
2348 Typ
:= Designated_Type
(Typ
);
2352 if Is_Class_Wide_Type
(Typ
)
2354 (Nkind
(Parent
(N
)) = N_Qualified_Expression
2355 and then Is_Access_Type
(Etype
(N
))
2356 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(N
))))
2363 end Find_Controlling_Arg
;
2365 ---------------------------
2366 -- Find_Dispatching_Type --
2367 ---------------------------
2369 function Find_Dispatching_Type
(Subp
: Entity_Id
) return Entity_Id
is
2371 function Has_Predefined_Dispatching_Operation_Name
return Boolean;
2372 -- Determines if Subp has the name of a predefined dispatching
2375 -----------------------------------------------
2376 -- Has_Predefined_Dispatching_Operation_Name --
2377 -----------------------------------------------
2379 function Has_Predefined_Dispatching_Operation_Name
return Boolean is
2380 TSS_Name
: TSS_Name_Type
;
2383 Get_Name_String
(Chars
(Subp
));
2385 if Name_Len
> TSS_Name_Type
'Last then
2388 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
2390 if Chars
(Subp
) in Name_uAssign
2393 or else TSS_Name
= TSS_Deep_Adjust
2394 or else TSS_Name
= TSS_Deep_Finalize
2395 or else TSS_Name
= TSS_Stream_Input
2396 or else TSS_Name
= TSS_Stream_Output
2397 or else TSS_Name
= TSS_Stream_Read
2398 or else TSS_Name
= TSS_Stream_Write
2399 or else TSS_Name
= TSS_Put_Image
2401 -- Name of predefined interface type primitives
2403 or else Chars
(Subp
) in Name_uDisp_Asynchronous_Select
2404 | Name_uDisp_Conditional_Select
2405 | Name_uDisp_Get_Prim_Op_Kind
2406 | Name_uDisp_Get_Task_Id
2407 | Name_uDisp_Requeue
2408 | Name_uDisp_Timed_Select
2415 end Has_Predefined_Dispatching_Operation_Name
;
2419 A_Formal
: Entity_Id
;
2421 Ctrl_Type
: Entity_Id
;
2424 if Ekind
(Subp
) in E_Function | E_Procedure
2425 and then Present
(DTC_Entity
(Subp
))
2427 return Scope
(DTC_Entity
(Subp
));
2429 -- For subprograms internally generated by derivations of tagged types
2430 -- use the alias subprogram as a reference to locate the dispatching
2433 elsif not Comes_From_Source
(Subp
)
2434 and then Present
(Alias
(Subp
))
2435 and then Is_Dispatching_Operation
(Alias
(Subp
))
2437 if Ekind
(Alias
(Subp
)) = E_Function
2438 and then Has_Controlling_Result
(Alias
(Subp
))
2440 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2443 Formal
:= First_Formal
(Subp
);
2444 A_Formal
:= First_Formal
(Alias
(Subp
));
2445 while Present
(A_Formal
) loop
2446 if Is_Controlling_Formal
(A_Formal
) then
2447 return Check_Controlling_Type
(Etype
(Formal
), Subp
);
2450 Next_Formal
(Formal
);
2451 Next_Formal
(A_Formal
);
2454 pragma Assert
(False);
2461 Formal
:= First_Formal
(Subp
);
2462 while Present
(Formal
) loop
2463 Ctrl_Type
:= Check_Controlling_Type
(Etype
(Formal
), Subp
);
2465 if Present
(Ctrl_Type
) then
2469 Next_Formal
(Formal
);
2472 -- The subprogram may also be dispatching on result
2474 if Present
(Etype
(Subp
)) then
2475 if Is_Tagged_Type
(Etype
(Subp
))
2476 and then Has_First_Controlling_Parameter_Aspect
(Etype
(Subp
))
2478 if Present
(Overridden_Operation
(Subp
))
2479 and then Has_Controlling_Result
(Overridden_Operation
(Subp
))
2481 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2483 -- Internal subprograms added by the frontend bypass the
2484 -- restrictions of First_Controlling_Parameter aspect.
2486 elsif Is_Internal
(Subp
)
2487 and then Has_Predefined_Dispatching_Operation_Name
2489 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2492 return Check_Controlling_Type
(Etype
(Subp
), Subp
);
2497 pragma Assert
(not Is_Dispatching_Operation
(Subp
));
2499 end Find_Dispatching_Type
;
2501 --------------------------------------
2502 -- Find_Hidden_Overridden_Primitive --
2503 --------------------------------------
2505 function Find_Hidden_Overridden_Primitive
(S
: Entity_Id
) return Entity_Id
2507 Tag_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
2509 Orig_Prim
: Entity_Id
;
2511 Vis_List
: Elist_Id
;
2514 -- This Ada 2012 rule applies only for type extensions or private
2515 -- extensions, where the parent type is not in a parent unit, and
2516 -- where an operation is never declared but still inherited.
2519 or else not Is_Record_Type
(Tag_Typ
)
2520 or else Etype
(Tag_Typ
) = Tag_Typ
2521 or else In_Open_Scopes
(Scope
(Etype
(Tag_Typ
)))
2526 -- Collect the list of visible ancestor of the tagged type
2528 Vis_List
:= Visible_Ancestors
(Tag_Typ
);
2530 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2531 while Present
(Elmt
) loop
2532 Prim
:= Node
(Elmt
);
2534 -- Find an inherited hidden dispatching primitive with the name of S
2535 -- and a type-conformant profile.
2537 if Present
(Alias
(Prim
))
2538 and then Is_Hidden
(Alias
(Prim
))
2539 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Tag_Typ
2540 and then Primitive_Names_Match
(S
, Prim
)
2541 and then Type_Conformant
(S
, Prim
)
2544 Vis_Ancestor
: Elmt_Id
;
2548 -- The original corresponding operation of Prim must be an
2549 -- operation of a visible ancestor of the dispatching type S,
2550 -- and the original corresponding operation of S2 must be
2553 Orig_Prim
:= Original_Corresponding_Operation
(Prim
);
2555 if Orig_Prim
/= Prim
2556 and then not Is_Hidden
(Orig_Prim
)
2558 Vis_Ancestor
:= First_Elmt
(Vis_List
);
2559 while Present
(Vis_Ancestor
) loop
2561 First_Elmt
(Primitive_Operations
(Node
(Vis_Ancestor
)));
2562 while Present
(Elmt
) loop
2563 if Node
(Elmt
) = Orig_Prim
then
2564 Set_Overridden_Operation
(S
, Prim
);
2565 Set_Is_Ada_2022_Only
(S
,
2566 Is_Ada_2022_Only
(Prim
));
2567 Set_Alias
(Prim
, Orig_Prim
);
2574 Next_Elmt
(Vis_Ancestor
);
2584 end Find_Hidden_Overridden_Primitive
;
2586 ---------------------------------------
2587 -- Find_Primitive_Covering_Interface --
2588 ---------------------------------------
2590 function Find_Primitive_Covering_Interface
2591 (Tagged_Type
: Entity_Id
;
2592 Iface_Prim
: Entity_Id
) return Entity_Id
2594 Is_FCP_Type
: constant Boolean :=
2595 Has_First_Controlling_Parameter_Aspect
(Tagged_Type
);
2600 pragma Assert
(Is_Interface
(Find_Dispatching_Type
(Iface_Prim
))
2601 or else (Present
(Alias
(Iface_Prim
))
2604 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
2606 -- Search in the homonym chain. Done to speed up locating visible
2607 -- entities and required to catch primitives associated with the partial
2608 -- view of private types when processing the corresponding full view.
2610 E
:= Current_Entity
(Iface_Prim
);
2611 while Present
(E
) loop
2612 if Is_Subprogram
(E
)
2613 and then Is_Dispatching_Operation
(E
)
2615 -- For overriding primitives of parent or interface types that
2616 -- do not have the aspect First_Controlling_Parameter, we must
2617 -- temporarily unset this attribute to check conformance.
2619 if Ekind
(E
) = E_Function
2620 and then Is_FCP_Type
2621 and then Present
(Overridden_Operation
(E
))
2622 and then Has_Controlling_Result
(Overridden_Operation
(E
))
2624 Set_Has_First_Controlling_Parameter_Aspect
(Tagged_Type
, False);
2626 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2627 Set_Has_First_Controlling_Parameter_Aspect
2628 (Tagged_Type
, Is_FCP_Type
);
2632 Set_Has_First_Controlling_Parameter_Aspect
2633 (Tagged_Type
, Is_FCP_Type
);
2635 elsif Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2643 -- Search in the list of primitives of the type. Required to locate
2644 -- the covering primitive if the covering primitive is not visible
2645 -- (for example, non-visible inherited primitive of private type).
2647 El
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
2648 while Present
(El
) loop
2651 -- Keep separate the management of internal entities that link
2652 -- primitives with interface primitives from tagged type primitives.
2654 if No
(Interface_Alias
(E
)) then
2655 if Present
(Alias
(E
)) then
2657 -- This interface primitive has not been covered yet
2659 if Alias
(E
) = Iface_Prim
then
2662 -- The covering primitive was inherited
2664 elsif Overridden_Operation
(Ultimate_Alias
(E
))
2671 -- Check if E covers the interface primitive (includes case in
2672 -- which E is an inherited private primitive).
2674 -- For overriding primitives of parent or interface types that
2675 -- do not have the aspect First_Controlling_Parameter, we must
2676 -- temporarily unset this attribute to check conformance.
2678 if Present
(Overridden_Operation
(E
))
2679 and then Is_FCP_Type
2681 Has_First_Controlling_Parameter_Aspect
2682 (Find_Dispatching_Type
(Overridden_Operation
(E
)))
2684 Set_Has_First_Controlling_Parameter_Aspect
(Tagged_Type
, False);
2686 if Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2687 Set_Has_First_Controlling_Parameter_Aspect
2688 (Tagged_Type
, Is_FCP_Type
);
2692 Set_Has_First_Controlling_Parameter_Aspect
2693 (Tagged_Type
, Is_FCP_Type
);
2695 elsif Is_Interface_Conformant
(Tagged_Type
, Iface_Prim
, E
) then
2699 -- Use the internal entity that links the interface primitive with
2700 -- the covering primitive to locate the entity.
2702 elsif Interface_Alias
(E
) = Iface_Prim
then
2712 end Find_Primitive_Covering_Interface
;
2714 ---------------------------
2715 -- Inheritance_Utilities --
2716 ---------------------------
2718 package body Inheritance_Utilities
is
2720 ---------------------------
2721 -- Inherited_Subprograms --
2722 ---------------------------
2724 function Inherited_Subprograms
2726 No_Interfaces
: Boolean := False;
2727 Interfaces_Only
: Boolean := False;
2728 Skip_Overridden
: Boolean := False;
2729 One_Only
: Boolean := False) return Subprogram_List
2731 Result
: Subprogram_List
(1 .. 6000);
2732 -- 6000 here is intended to be infinity. We could use an expandable
2733 -- table, but it would be awfully heavy, and there is no way that we
2734 -- could reasonably exceed this value.
2737 -- Number of entries in Result
2739 Parent_Op
: Entity_Id
;
2740 -- Traverses the Overridden_Operation chain
2742 procedure Store_IS
(E
: Entity_Id
);
2743 -- Stores E in Result if not already stored
2749 procedure Store_IS
(E
: Entity_Id
) is
2751 for J
in 1 .. N
loop
2752 if E
= Result
(J
) then
2761 -- Start of processing for Inherited_Subprograms
2764 pragma Assert
(not (No_Interfaces
and Interfaces_Only
));
2766 -- When used from backends, visibility can be handled differently
2767 -- resulting in no dispatching type being found.
2770 and then Is_Dispatching_Operation
(S
)
2771 and then Present
(Find_DT
(S
))
2773 -- Deal with direct inheritance
2775 if not Interfaces_Only
then
2778 Parent_Op
:= Overridden_Operation
(Parent_Op
);
2779 exit when No
(Parent_Op
)
2780 or else No
(Find_DT
(Parent_Op
))
2781 or else (No_Interfaces
2782 and then Is_Interface
(Find_DT
(Parent_Op
)));
2784 if Is_Subprogram_Or_Generic_Subprogram
(Parent_Op
) then
2785 Store_IS
(Parent_Op
);
2794 -- Now deal with interfaces
2796 if not No_Interfaces
then
2798 Tag_Typ
: Entity_Id
;
2803 Tag_Typ
:= Find_DT
(S
);
2805 -- In the presence of limited views there may be no visible
2806 -- dispatching type. Primitives will be inherited when non-
2807 -- limited view is frozen.
2809 if No
(Tag_Typ
) then
2810 return Result
(1 .. 0);
2812 -- Prevent cascaded errors
2814 elsif Is_Concurrent_Type
(Tag_Typ
)
2815 and then No
(Corresponding_Record_Type
(Tag_Typ
))
2816 and then Serious_Errors_Detected
> 0
2818 return Result
(1 .. 0);
2821 if Is_Concurrent_Type
(Tag_Typ
) then
2822 Tag_Typ
:= Corresponding_Record_Type
(Tag_Typ
);
2825 if Present
(Tag_Typ
)
2826 and then Is_Private_Type
(Tag_Typ
)
2827 and then Present
(Full_View
(Tag_Typ
))
2829 Tag_Typ
:= Full_View
(Tag_Typ
);
2832 -- Search primitive operations of dispatching type
2834 if Present
(Tag_Typ
)
2835 and then Present
(Primitive_Operations
(Tag_Typ
))
2837 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
2838 while Present
(Elmt
) loop
2839 Prim
:= Node
(Elmt
);
2841 -- The following test eliminates some odd cases in
2842 -- which Ekind (Prim) is Void, to be investigated
2845 if not Is_Subprogram_Or_Generic_Subprogram
(Prim
) then
2848 -- For [generic] subprogram, look at interface
2851 elsif Present
(Interface_Alias
(Prim
))
2852 and then Alias
(Prim
) = S
2854 -- We have found a primitive covered by S
2856 Store_IS
(Interface_Alias
(Prim
));
2870 -- Do not keep an overridden operation if its overridding operation
2871 -- is in the results too, and it is not S. This can happen for
2872 -- inheritance between interfaces.
2874 if Skip_Overridden
then
2876 Res
: constant Subprogram_List
(1 .. N
) := Result
(1 .. N
);
2879 for J
in 1 .. N
loop
2880 for K
in 1 .. N
loop
2882 and then Res
(J
) = Overridden_Operation
(Res
(K
))
2889 Result
(M
) := Res
(J
);
2900 return Result
(1 .. N
);
2901 end Inherited_Subprograms
;
2903 ------------------------------
2904 -- Is_Overriding_Subprogram --
2905 ------------------------------
2907 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean is
2908 Inherited
: constant Subprogram_List
:=
2909 Inherited_Subprograms
(E
, One_Only
=> True);
2911 return Inherited
'Length > 0;
2912 end Is_Overriding_Subprogram
;
2913 end Inheritance_Utilities
;
2915 --------------------------------
2916 -- Inheritance_Utilities_Inst --
2917 --------------------------------
2919 package Inheritance_Utilities_Inst
is new
2920 Inheritance_Utilities
(Find_Dispatching_Type
);
2922 ---------------------------
2923 -- Inherited_Subprograms --
2924 ---------------------------
2926 function Inherited_Subprograms
2928 No_Interfaces
: Boolean := False;
2929 Interfaces_Only
: Boolean := False;
2930 Skip_Overridden
: Boolean := False;
2931 One_Only
: Boolean := False) return Subprogram_List
renames
2932 Inheritance_Utilities_Inst
.Inherited_Subprograms
;
2934 ---------------------------
2935 -- Is_Dynamically_Tagged --
2936 ---------------------------
2938 function Is_Dynamically_Tagged
(N
: Node_Id
) return Boolean is
2940 if Nkind
(N
) = N_Error
then
2943 elsif Present
(Find_Controlling_Arg
(N
)) then
2946 -- Special cases: entities, and calls that dispatch on result
2948 elsif Is_Entity_Name
(N
) then
2949 return Is_Class_Wide_Type
(Etype
(N
));
2951 elsif Nkind
(N
) = N_Function_Call
2952 and then Is_Class_Wide_Type
(Etype
(N
))
2956 -- Otherwise check whether call has controlling argument
2961 end Is_Dynamically_Tagged
;
2963 ---------------------------------
2964 -- Is_Null_Interface_Primitive --
2965 ---------------------------------
2967 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2969 return Comes_From_Source
(E
)
2970 and then Is_Dispatching_Operation
(E
)
2971 and then Ekind
(E
) = E_Procedure
2972 and then Null_Present
(Parent
(E
))
2973 and then Is_Interface
(Find_Dispatching_Type
(E
));
2974 end Is_Null_Interface_Primitive
;
2976 -----------------------------------
2977 -- Is_Inherited_Public_Operation --
2978 -----------------------------------
2980 function Is_Inherited_Public_Operation
(Op
: Entity_Id
) return Boolean is
2981 Pack_Decl
: Node_Id
;
2982 Prim
: Entity_Id
:= Op
;
2983 Scop
: Entity_Id
:= Prim
;
2986 -- Locate the ultimate non-hidden alias entity
2988 while Present
(Alias
(Prim
)) and then not Is_Hidden
(Alias
(Prim
)) loop
2989 pragma Assert
(Alias
(Prim
) /= Prim
);
2990 Prim
:= Alias
(Prim
);
2991 Scop
:= Scope
(Prim
);
2994 if Comes_From_Source
(Prim
) and then Ekind
(Scop
) = E_Package
then
2995 Pack_Decl
:= Unit_Declaration_Node
(Scop
);
2998 Nkind
(Pack_Decl
) = N_Package_Declaration
2999 and then List_Containing
(Unit_Declaration_Node
(Prim
)) =
3000 Visible_Declarations
(Specification
(Pack_Decl
));
3005 end Is_Inherited_Public_Operation
;
3007 ------------------------------
3008 -- Is_Overriding_Subprogram --
3009 ------------------------------
3011 function Is_Overriding_Subprogram
(E
: Entity_Id
) return Boolean renames
3012 Inheritance_Utilities_Inst
.Is_Overriding_Subprogram
;
3014 --------------------------
3015 -- Is_Tag_Indeterminate --
3016 --------------------------
3018 function Is_Tag_Indeterminate
(N
: Node_Id
) return Boolean is
3021 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
3024 if Nkind
(Orig_Node
) = N_Function_Call
3025 and then Is_Entity_Name
(Name
(Orig_Node
))
3027 Nam
:= Entity
(Name
(Orig_Node
));
3029 if not Has_Controlling_Result
(Nam
) then
3032 -- The function may have a controlling result, but if the return type
3033 -- is not visibly tagged, then this is not tag-indeterminate.
3035 elsif Is_Access_Type
(Etype
(Nam
))
3036 and then not Is_Tagged_Type
(Designated_Type
(Etype
(Nam
)))
3040 -- An explicit dereference means that the call has already been
3041 -- expanded and there is no tag to propagate.
3043 elsif Nkind
(N
) = N_Explicit_Dereference
then
3046 -- If there are no actuals, the call is tag-indeterminate
3048 elsif No
(Parameter_Associations
(Orig_Node
)) then
3052 Actual
:= First_Actual
(Orig_Node
);
3053 while Present
(Actual
) loop
3054 if Is_Controlling_Actual
(Actual
)
3055 and then not Is_Tag_Indeterminate
(Actual
)
3057 -- One operand is dispatching
3062 Next_Actual
(Actual
);
3068 elsif Nkind
(Orig_Node
) = N_Qualified_Expression
then
3069 return Is_Tag_Indeterminate
(Expression
(Orig_Node
));
3071 -- Case of a call to the Input attribute (possibly rewritten), which is
3072 -- always tag-indeterminate except when its prefix is a Class attribute.
3074 elsif Nkind
(Orig_Node
) = N_Attribute_Reference
3076 Get_Attribute_Id
(Attribute_Name
(Orig_Node
)) = Attribute_Input
3077 and then Nkind
(Prefix
(Orig_Node
)) /= N_Attribute_Reference
3081 -- In Ada 2005, a function that returns an anonymous access type can be
3082 -- dispatching, and the dereference of a call to such a function can
3083 -- also be tag-indeterminate if the call itself is.
3085 elsif Nkind
(Orig_Node
) = N_Explicit_Dereference
3086 and then Ada_Version
>= Ada_2005
3088 return Is_Tag_Indeterminate
(Prefix
(Orig_Node
));
3093 end Is_Tag_Indeterminate
;
3095 ------------------------------------
3096 -- Override_Dispatching_Operation --
3097 ------------------------------------
3099 procedure Override_Dispatching_Operation
3100 (Tagged_Type
: Entity_Id
;
3101 Prev_Op
: Entity_Id
;
3108 -- If there is no previous operation to override, the type declaration
3109 -- was malformed, and an error must have been emitted already.
3111 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
3112 while Present
(Elmt
) and then Node
(Elmt
) /= Prev_Op
loop
3120 -- The location of entities that come from source in the list of
3121 -- primitives of the tagged type must follow their order of occurrence
3122 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
3123 -- primitive of an interface that is not implemented by the parents of
3124 -- this tagged type (that is, it is an alias of an interface primitive
3125 -- generated by Derive_Interface_Progenitors), then we must append the
3126 -- new entity at the end of the list of primitives.
3128 if Present
(Alias
(Prev_Op
))
3129 and then Etype
(Tagged_Type
) /= Tagged_Type
3130 and then Is_Interface
(Find_Dispatching_Type
(Alias
(Prev_Op
)))
3131 and then not Is_Ancestor
(Find_Dispatching_Type
(Alias
(Prev_Op
)),
3132 Tagged_Type
, Use_Full_View
=> True)
3133 and then not Implements_Interface
3134 (Etype
(Tagged_Type
),
3135 Find_Dispatching_Type
(Alias
(Prev_Op
)))
3137 Remove_Elmt
(Primitive_Operations
(Tagged_Type
), Elmt
);
3138 Add_Dispatching_Operation
(Tagged_Type
, New_Op
);
3140 -- The new primitive replaces the overridden entity. Required to ensure
3141 -- that overriding primitive is assigned the same dispatch table slot.
3144 Replace_Elmt
(Elmt
, New_Op
);
3147 if Ada_Version
>= Ada_2005
and then Has_Interfaces
(Tagged_Type
) then
3149 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
3150 -- entities of the overridden primitive to reference New_Op, and
3151 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
3152 -- that the new operation is subtype conformant with the interface
3153 -- operations that it implements (for operations inherited from the
3154 -- parent itself, this check is made when building the derived type).
3156 -- Note: This code is executed with internally generated wrappers of
3157 -- functions with controlling result and late overridings.
3159 Elmt
:= First_Elmt
(Primitive_Operations
(Tagged_Type
));
3160 while Present
(Elmt
) loop
3161 Prim
:= Node
(Elmt
);
3163 if Prim
= New_Op
then
3166 -- Note: The check on Is_Subprogram protects the frontend against
3167 -- reading attributes in entities that are not yet fully decorated
3169 elsif Is_Subprogram
(Prim
)
3170 and then Present
(Interface_Alias
(Prim
))
3171 and then Alias
(Prim
) = Prev_Op
3173 Set_Alias
(Prim
, New_Op
);
3175 -- No further decoration needed yet for internally generated
3176 -- wrappers of controlling functions since (at this stage)
3177 -- they are not yet decorated.
3179 if not Is_Wrapper
(New_Op
) then
3180 Check_Subtype_Conformant
(New_Op
, Prim
);
3182 Set_Is_Abstract_Subprogram
(Prim
,
3183 Is_Abstract_Subprogram
(New_Op
));
3185 -- Ensure that this entity will be expanded to fill the
3186 -- corresponding entry in its dispatch table.
3188 if not Is_Abstract_Subprogram
(Prim
) then
3189 Set_Has_Delayed_Freeze
(Prim
);
3198 if not Is_Package_Or_Generic_Package
(Current_Scope
)
3199 or else not In_Private_Part
(Current_Scope
)
3201 -- Not a private primitive
3205 else pragma Assert
(Is_Inherited_Operation
(Prev_Op
));
3207 -- Make the overriding operation into an alias of the implicit one.
3208 -- In this fashion a call from outside ends up calling the new body
3209 -- even if non-dispatching, and a call from inside calls the over-
3210 -- riding operation because it hides the implicit one. To indicate
3211 -- that the body of Prev_Op is never called, set its dispatch table
3212 -- entity to Empty. If the overridden operation has a dispatching
3213 -- result, so does the overriding one.
3215 Set_Alias
(Prev_Op
, New_Op
);
3216 Set_DTC_Entity
(Prev_Op
, Empty
);
3217 Set_Has_Controlling_Result
(New_Op
, Has_Controlling_Result
(Prev_Op
));
3218 Set_Is_Ada_2022_Only
(New_Op
, Is_Ada_2022_Only
(Prev_Op
));
3220 end Override_Dispatching_Operation
;
3226 procedure Propagate_Tag
(Control
: Node_Id
; Actual
: Node_Id
) is
3227 Call_Node
: Node_Id
;
3231 if Nkind
(Actual
) = N_Function_Call
then
3232 Call_Node
:= Actual
;
3234 elsif Nkind
(Actual
) = N_Identifier
3235 and then Nkind
(Original_Node
(Actual
)) = N_Function_Call
3237 -- Call rewritten as object declaration when stack-checking is
3238 -- enabled. Propagate tag to expression in declaration, which is
3241 Call_Node
:= Expression
(Parent
(Entity
(Actual
)));
3243 -- Ada 2005: If this is a dereference of a call to a function with a
3244 -- dispatching access-result, the tag is propagated when the dereference
3245 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
3247 elsif Nkind
(Actual
) = N_Explicit_Dereference
3248 and then Nkind
(Original_Node
(Prefix
(Actual
))) = N_Function_Call
3252 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
3253 -- and in that case we can simply return.
3255 elsif Nkind
(Actual
) = N_Attribute_Reference
then
3256 pragma Assert
(Attribute_Name
(Actual
) = Name_Input
);
3260 -- Only other possibilities are parenthesized or qualified expression,
3261 -- or an expander-generated unchecked conversion of a function call to
3262 -- a stream Input attribute.
3265 Call_Node
:= Expression
(Actual
);
3268 -- No action needed if the call has been already expanded
3270 if Is_Expanded_Dispatching_Call
(Call_Node
) then
3274 -- Do not set the Controlling_Argument if already set. This happens in
3275 -- the special case of _Input (see Exp_Attr, case Input).
3277 if No
(Controlling_Argument
(Call_Node
)) then
3278 Set_Controlling_Argument
(Call_Node
, Control
);
3281 Arg
:= First_Actual
(Call_Node
);
3282 while Present
(Arg
) loop
3283 if Is_Tag_Indeterminate
(Arg
) then
3284 Propagate_Tag
(Control
, Arg
);
3290 -- Add class-wide precondition check if the target of this dispatching
3291 -- call has or inherits class-wide preconditions.
3293 Install_Class_Preconditions_Check
(Call_Node
);
3295 -- Expansion of dispatching calls is suppressed on VM targets, because
3296 -- the VM back-ends directly handle the generation of dispatching calls
3297 -- and would have to undo any expansion to an indirect call.
3299 if Tagged_Type_Expansion
then
3301 Call_Typ
: Entity_Id
:= Etype
(Call_Node
);
3302 Ctrl_Typ
: Entity_Id
:= Etype
(Control
);
3305 Expand_Dispatching_Call
(Call_Node
);
3307 if Is_Class_Wide_Type
(Call_Typ
) then
3308 Call_Typ
:= Root_Type
(Call_Typ
);
3311 if Is_Class_Wide_Type
(Ctrl_Typ
) then
3312 Ctrl_Typ
:= Root_Type
(Ctrl_Typ
);
3315 -- If the controlling argument is an interface type and the type
3316 -- of Call_Node differs then we must add an implicit conversion to
3317 -- force displacement of the pointer to the object to reference
3318 -- the secondary dispatch table of the interface.
3320 if Is_Interface
(Ctrl_Typ
)
3321 and then Ctrl_Typ
/= Call_Typ
3323 -- Cannot use Convert_To because the previous call to
3324 -- Expand_Dispatching_Call leaves decorated the Call_Node
3325 -- with the type of Control.
3328 Make_Type_Conversion
(Sloc
(Call_Node
),
3330 New_Occurrence_Of
(Etype
(Control
), Sloc
(Call_Node
)),
3331 Expression
=> Relocate_Node
(Call_Node
)));
3332 Set_Etype
(Call_Node
, Etype
(Control
));
3333 Set_Analyzed
(Call_Node
);
3335 Expand_Interface_Conversion
(Call_Node
);
3339 -- Expansion of a dispatching call results in an indirect call, which in
3340 -- turn causes current values to be killed (see Resolve_Call), so on VM
3341 -- targets we do the call here to ensure consistent warnings between VM
3342 -- and non-VM targets.
3345 Kill_Current_Values
;