RISC-V: Add testcases for unsigned scalar .SAT_ADD IMM form 4
[official-gcc.git] / gcc / ada / sem_disp.adb
blobfe822290e453b57221ad57f9f264dbf6e98cef59
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ D I S P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
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;
43 with Opt; use Opt;
44 with Output; use Output;
45 with Restrict; use Restrict;
46 with Rident; use Rident;
47 with Sem; use Sem;
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;
70 New_Op : Entity_Id);
71 -- Add New_Op in the list of primitive operations of Tagged_Type
73 function Check_Controlling_Type
74 (T : Entity_Id;
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;
106 New_Op : Entity_Id)
108 List : constant Elist_Id := Primitive_Operations (Tagged_Type);
110 begin
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
121 -- overriding.
123 if Is_Suitable_Primitive (New_Op) then
124 Append_Unique_Elmt (New_Op, List);
125 end if;
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);
134 Elmt : Elmt_Id;
135 E : Entity_Id;
137 begin
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
153 E := Node (Elmt);
155 if Present (Interface_Alias (E))
156 and then Alias (E) = Prim
157 then
158 return Interface_Alias (E);
159 end if;
161 Next_Elmt (Elmt);
162 end loop;
164 -- Otherwise we must collect all the interface primitives and check
165 -- if the Prim overrides (implements) some interface primitive.
167 else
168 declare
169 Ifaces_List : Elist_Id;
170 Iface_Elmt : Elmt_Id;
171 Iface : Entity_Id;
172 Iface_Prim : Entity_Id;
174 begin
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)
187 then
188 return Iface_Prim;
189 end if;
191 Next_Elmt (Elmt);
192 end loop;
194 Next_Elmt (Iface_Elmt);
195 end loop;
196 end;
197 end if;
198 end if;
200 return Empty;
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);
209 Elmt : Elmt_Id;
210 E : Entity_Id;
211 Result : Elist_Id := No_Elist;
213 begin
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
229 E := Node (Elmt);
231 if Present (Interface_Alias (E))
232 and then Alias (E) = Prim
233 then
234 if No (Result) then
235 Result := New_Elmt_List;
236 end if;
238 Append_Elmt (Interface_Alias (E), Result);
239 end if;
241 Next_Elmt (Elmt);
242 end loop;
244 -- Otherwise we must collect all the interface primitives and check
245 -- whether the Prim overrides (implements) some interface primitive.
247 else
248 declare
249 Ifaces_List : Elist_Id;
250 Iface_Elmt : Elmt_Id;
251 Iface : Entity_Id;
252 Iface_Prim : Entity_Id;
254 begin
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)
268 then
269 if No (Result) then
270 Result := New_Elmt_List;
271 end if;
273 Append_Elmt (Iface_Prim, Result);
274 end if;
276 Next_Elmt (Elmt);
277 end loop;
279 Next_Elmt (Iface_Elmt);
280 end loop;
281 end;
282 end if;
283 end if;
285 return Result;
286 end Covered_Interface_Primitives;
288 -------------------------------
289 -- Check_Controlling_Formals --
290 -------------------------------
292 procedure Check_Controlling_Formals
293 (Typ : Entity_Id;
294 Subp : Entity_Id)
296 Formal : Entity_Id;
297 Ctrl_Type : Entity_Id;
299 begin
300 -- We skip the check for thunks
302 if Is_Thunk (Subp) then
303 return;
304 end if;
306 Formal := First_Formal (Subp);
307 while Present (Formal) loop
308 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
310 if Present (Ctrl_Type) then
312 -- Obtain the full type in case we are looking at an incomplete
313 -- view.
315 if Ekind (Ctrl_Type) = E_Incomplete_Type
316 and then Present (Full_View (Ctrl_Type))
317 then
318 Ctrl_Type := Full_View (Ctrl_Type);
319 end if;
321 -- When controlling type is concurrent and declared within a
322 -- generic or inside an instance use corresponding record type.
324 if Is_Concurrent_Type (Ctrl_Type)
325 and then Present (Corresponding_Record_Type (Ctrl_Type))
326 then
327 Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
328 end if;
330 if Ctrl_Type = Typ then
331 Set_Is_Controlling_Formal (Formal);
333 -- Ada 2005 (AI-231): Anonymous access types that are used in
334 -- controlling parameters exclude null because it is necessary
335 -- to read the tag to dispatch, and null has no tag.
337 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
338 Set_Can_Never_Be_Null (Etype (Formal));
339 Set_Is_Known_Non_Null (Etype (Formal));
340 end if;
342 -- Check that the parameter's nominal subtype statically
343 -- matches the first subtype.
345 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
346 if not Subtypes_Statically_Match
347 (Typ, Designated_Type (Etype (Formal)))
348 then
349 Error_Msg_N
350 ("parameter subtype does not match controlling type",
351 Formal);
352 end if;
354 -- Within a predicate function, the formal may be a subtype
355 -- of a tagged type, given that the predicate is expressed
356 -- in terms of the subtype.
358 elsif not Subtypes_Statically_Match (Typ, Etype (Formal))
359 and then not Is_Predicate_Function (Subp)
360 then
361 Error_Msg_N
362 ("parameter subtype does not match controlling type",
363 Formal);
364 end if;
366 if Present (Default_Value (Formal)) then
368 -- In Ada 2005, access parameters can have defaults
370 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
371 and then Ada_Version < Ada_2005
372 then
373 Error_Msg_N
374 ("default not allowed for controlling access parameter",
375 Default_Value (Formal));
377 elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
378 Error_Msg_N
379 ("default expression must be a tag indeterminate" &
380 " function call", Default_Value (Formal));
381 end if;
382 end if;
384 elsif Comes_From_Source (Subp) then
385 Error_Msg_N
386 ("operation can be dispatching in only one type", Subp);
387 end if;
388 end if;
390 Next_Formal (Formal);
391 end loop;
393 if Ekind (Subp) in E_Function | E_Generic_Function then
394 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
396 if Present (Ctrl_Type) then
397 if Ctrl_Type = Typ then
398 Set_Has_Controlling_Result (Subp);
400 -- Check that result subtype statically matches first subtype
401 -- (Ada 2005): Subp may have a controlling access result.
403 if Subtypes_Statically_Match (Typ, Etype (Subp))
404 or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
405 and then
406 Subtypes_Statically_Match
407 (Typ, Designated_Type (Etype (Subp))))
408 then
409 null;
411 else
412 Error_Msg_N
413 ("result subtype does not match controlling type", Subp);
414 end if;
416 elsif Comes_From_Source (Subp) then
417 Error_Msg_N
418 ("operation can be dispatching in only one type", Subp);
419 end if;
420 end if;
421 end if;
422 end Check_Controlling_Formals;
424 ----------------------------
425 -- Check_Controlling_Type --
426 ----------------------------
428 function Check_Controlling_Type
429 (T : Entity_Id;
430 Subp : Entity_Id) return Entity_Id
432 Tagged_Type : Entity_Id := Empty;
434 begin
435 if Is_Tagged_Type (T) then
436 if Is_First_Subtype (T) then
437 Tagged_Type := T;
438 else
439 Tagged_Type := Base_Type (T);
440 end if;
442 -- If the type is incomplete, it may have been declared without a
443 -- Tagged indication, but the full view may be tagged, in which case
444 -- that is the controlling type of the subprogram. This is one of the
445 -- approx. 579 places in the language where a lookahead would help.
447 elsif Ekind (T) = E_Incomplete_Type
448 and then Present (Full_View (T))
449 and then Is_Tagged_Type (Full_View (T))
450 then
451 Set_Is_Tagged_Type (T);
452 Tagged_Type := Full_View (T);
454 elsif Ekind (T) = E_Anonymous_Access_Type
455 and then Is_Tagged_Type (Designated_Type (T))
456 then
457 if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
458 if Is_First_Subtype (Designated_Type (T)) then
459 Tagged_Type := Designated_Type (T);
460 else
461 Tagged_Type := Base_Type (Designated_Type (T));
462 end if;
464 -- Ada 2005: an incomplete type can be tagged. An operation with an
465 -- access parameter of the type is dispatching.
467 elsif Scope (Designated_Type (T)) = Current_Scope then
468 Tagged_Type := Designated_Type (T);
470 -- Ada 2005 (AI-50217)
472 elsif From_Limited_With (Designated_Type (T))
473 and then Has_Non_Limited_View (Designated_Type (T))
474 and then Scope (Designated_Type (T)) = Scope (Subp)
475 then
476 if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
477 Tagged_Type := Non_Limited_View (Designated_Type (T));
478 else
479 Tagged_Type := Base_Type (Non_Limited_View
480 (Designated_Type (T)));
481 end if;
482 end if;
483 end if;
485 if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then
486 return Empty;
488 -- In the special case of a protected subprogram of a tagged protected
489 -- type that has a formal of a tagged type (or access formal whose type
490 -- designates a tagged type), such a formal is not controlling unless
491 -- it's of the protected type's corresponding record type. The latter
492 -- can occur for the special wrapper subprograms created for protected
493 -- subprograms. Such subprograms may occur in the same scope where some
494 -- formal's tagged type is declared, and we don't want formals of that
495 -- tagged type being marked as controlling, for one thing because they
496 -- aren't controlling from the language point of view, but also because
497 -- this can cause errors for access formals when conformance is checked
498 -- between the spec and body of the protected subprogram (null-exclusion
499 -- status of the formals may be set differently, which is the case that
500 -- led to adding this check).
502 elsif Is_Subprogram (Subp)
503 and then Present (Protected_Subprogram (Subp))
504 and then Ekind (Scope (Protected_Subprogram (Subp))) = E_Protected_Type
505 and then
506 Base_Type (Tagged_Type)
507 /= Corresponding_Record_Type (Scope (Protected_Subprogram (Subp)))
508 then
509 return Empty;
511 -- The dispatching type and the primitive operation must be defined in
512 -- the same scope, except in the case of abstract formal subprograms.
514 elsif (Scope (Subp) = Scope (Tagged_Type)
515 and then (not Is_Generic_Type (Tagged_Type)
516 or else not Comes_From_Source (Subp)))
517 or else
518 (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
519 or else
520 (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
521 and then
522 Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
523 and then
524 Is_Abstract_Subprogram (Subp))
525 then
526 return Tagged_Type;
528 else
529 return Empty;
530 end if;
531 end Check_Controlling_Type;
533 ----------------------------
534 -- Check_Dispatching_Call --
535 ----------------------------
537 procedure Check_Dispatching_Call (N : Node_Id) is
538 Loc : constant Source_Ptr := Sloc (N);
539 Actual : Node_Id;
540 Formal : Entity_Id;
541 Control : Node_Id := Empty;
542 Func : Entity_Id;
543 Subp_Entity : Entity_Id;
545 Indeterm_Ctrl_Type : Entity_Id := Empty;
546 -- Type of a controlling formal whose actual is a tag-indeterminate call
547 -- whose result type is different from, but is an ancestor of, the type.
549 Static_Tag : Node_Id := Empty;
550 -- If a controlling formal has a statically tagged actual, the tag of
551 -- this actual is to be used for any tag-indeterminate actual.
553 procedure Check_Direct_Call;
554 -- In the case when the controlling actual is a class-wide type whose
555 -- root type's completion is a task or protected type, the call is in
556 -- fact direct. This routine detects the above case and modifies the
557 -- call accordingly.
559 procedure Check_Dispatching_Context (Call : Node_Id);
560 -- If the call is tag-indeterminate and the entity being called is
561 -- abstract, verify that the context is a call that will eventually
562 -- provide a tag for dispatching, or has provided one already.
564 -----------------------
565 -- Check_Direct_Call --
566 -----------------------
568 procedure Check_Direct_Call is
569 Typ : Entity_Id := Etype (Control);
570 begin
571 -- Predefined primitives do not receive wrappers since they are built
572 -- from scratch for the corresponding record of synchronized types.
573 -- Equality is in general predefined, but is excluded from the check
574 -- when it is user-defined.
576 if Is_Predefined_Dispatching_Operation (Subp_Entity)
577 and then not (Is_User_Defined_Equality (Subp_Entity)
578 and then Comes_From_Source (Subp_Entity)
579 and then Nkind (Parent (Subp_Entity)) =
580 N_Function_Specification)
581 then
582 return;
583 end if;
585 if Is_Class_Wide_Type (Typ) then
586 Typ := Root_Type (Typ);
587 end if;
589 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
590 Typ := Full_View (Typ);
591 end if;
593 if Is_Concurrent_Type (Typ)
594 and then
595 Present (Corresponding_Record_Type (Typ))
596 then
597 Typ := Corresponding_Record_Type (Typ);
599 -- The concurrent record's list of primitives should contain a
600 -- wrapper for the entity of the call, retrieve it.
602 declare
603 Prim : Entity_Id;
604 Prim_Elmt : Elmt_Id;
605 Wrapper_Found : Boolean := False;
607 begin
608 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
609 while Present (Prim_Elmt) loop
610 Prim := Node (Prim_Elmt);
612 if Is_Primitive_Wrapper (Prim)
613 and then Wrapped_Entity (Prim) = Subp_Entity
614 then
615 Wrapper_Found := True;
616 exit;
617 end if;
619 Next_Elmt (Prim_Elmt);
620 end loop;
622 -- A primitive declared between two views should have a
623 -- corresponding wrapper.
625 pragma Assert (Wrapper_Found);
627 -- Modify the call by setting the proper entity
629 Set_Entity (Name (N), Prim);
630 end;
631 end if;
632 end Check_Direct_Call;
634 -------------------------------
635 -- Check_Dispatching_Context --
636 -------------------------------
638 procedure Check_Dispatching_Context (Call : Node_Id) is
639 Subp : constant Entity_Id := Entity (Name (Call));
641 procedure Abstract_Context_Error;
642 -- Error for abstract call dispatching on result is not dispatching
644 function Has_Controlling_Current_Instance_Actual_In_DIC
645 (Call : Node_Id) return Boolean;
646 -- Return True if the subprogram call Call has a controlling actual
647 -- given directly by a current instance referenced within a DIC
648 -- aspect.
650 ----------------------------
651 -- Abstract_Context_Error --
652 ----------------------------
654 procedure Abstract_Context_Error is
655 begin
656 if Ekind (Subp) = E_Function then
657 Error_Msg_N
658 ("call to abstract function must be dispatching", N);
660 -- This error can occur for a procedure in the case of a call to
661 -- an abstract formal procedure with a statically tagged operand.
663 else
664 Error_Msg_N
665 ("call to abstract procedure must be dispatching", N);
666 end if;
667 end Abstract_Context_Error;
669 ----------------------------------------
670 -- Has_Current_Instance_Actual_In_DIC --
671 ----------------------------------------
673 function Has_Controlling_Current_Instance_Actual_In_DIC
674 (Call : Node_Id) return Boolean
676 A : Node_Id;
677 F : Entity_Id;
678 begin
679 F := First_Formal (Subp_Entity);
680 A := First_Actual (Call);
682 while Present (F) loop
684 -- Return True if the actual denotes a current instance (which
685 -- will be represented by an in-mode formal of the enclosing
686 -- DIC_Procedure) passed to a controlling formal. We don't have
687 -- to worry about controlling access formals here, because its
688 -- illegal to apply Access (etc.) attributes to a current
689 -- instance within an aspect (by AI12-0068).
691 if Is_Controlling_Formal (F)
692 and then Nkind (A) = N_Identifier
693 and then Ekind (Entity (A)) = E_In_Parameter
694 and then Is_Subprogram (Scope (Entity (A)))
695 and then Is_DIC_Procedure (Scope (Entity (A)))
696 then
697 return True;
698 end if;
700 Next_Formal (F);
701 Next_Actual (A);
702 end loop;
704 return False;
705 end Has_Controlling_Current_Instance_Actual_In_DIC;
707 -- Local variables
709 Scop : constant Entity_Id := Current_Scope_No_Loops;
710 Typ : constant Entity_Id := Etype (Subp);
711 Par : Node_Id;
713 -- Start of processing for Check_Dispatching_Context
715 begin
716 -- Skip checking context of dispatching calls during preanalysis of
717 -- class-wide conditions since at that stage the expression is not
718 -- installed yet on its definite context.
720 if Inside_Class_Condition_Preanalysis then
721 return;
722 end if;
724 -- If the called subprogram is a private overriding, replace it
725 -- with its alias, which has the correct body. Verify that the
726 -- two subprograms have the same controlling type (this is not the
727 -- case for an inherited subprogram that has become abstract).
729 if Is_Abstract_Subprogram (Subp)
730 and then No (Controlling_Argument (Call))
731 then
732 if Present (Alias (Subp))
733 and then not Is_Abstract_Subprogram (Alias (Subp))
734 and then No (DTC_Entity (Subp))
735 and then Find_Dispatching_Type (Subp) =
736 Find_Dispatching_Type (Alias (Subp))
737 then
738 -- Private overriding of inherited abstract operation, call is
739 -- legal.
741 Set_Entity (Name (N), Alias (Subp));
742 return;
744 -- If this is a pre/postcondition for an abstract subprogram,
745 -- it may call another abstract function that is a primitive
746 -- of an abstract type. The call is nondispatching but will be
747 -- legal in overridings of the operation. However, if the call
748 -- is tag-indeterminate we want to continue with with the error
749 -- checking below, as this case is illegal even for abstract
750 -- subprograms (see AI12-0170).
752 -- Similarly, as per AI12-0412, a nonabstract subprogram may
753 -- have a class-wide pre/postcondition that includes a call to
754 -- an abstract primitive of the subprogram's controlling type.
755 -- Certain operations (nondispatching calls, 'Access, use as
756 -- a generic actual) applied to such a nonabstract subprogram
757 -- are illegal in the case where the type is abstract (see
758 -- RM 6.1.1(18.2/5)).
760 elsif Is_Subprogram (Scop)
761 and then not Is_Tag_Indeterminate (N)
762 and then
763 -- The context is an internally built helper or an indirect
764 -- call wrapper that handles class-wide preconditions
765 (Present (Class_Preconditions_Subprogram (Scop))
767 -- ... or the context is a class-wide pre/postcondition.
768 or else
769 (In_Pre_Post_Condition (Call, Class_Wide_Only => True)
771 -- The tagged type associated with the called
772 -- subprogram must be the same as that of the
773 -- subprogram with a class-wide aspect.
775 and then Is_Dispatching_Operation (Scop)
776 and then Find_Dispatching_Type (Subp)
777 = Find_Dispatching_Type (Scop)))
778 then
779 null;
781 -- Similarly to the dispensation for postconditions, a call to
782 -- an abstract function within a Default_Initial_Condition aspect
783 -- can be legal when passed a current instance of the type. Such
784 -- a call will be effectively mapped to a call to a primitive of
785 -- a descendant type (see AI12-0397, as well as AI12-0170), so
786 -- doesn't need to be dispatching. We test for being within a DIC
787 -- procedure, since that's where the call will be analyzed.
789 elsif Is_Subprogram (Scop)
790 and then Is_DIC_Procedure (Scop)
791 and then Has_Controlling_Current_Instance_Actual_In_DIC (Call)
792 then
793 null;
795 elsif Ekind (Current_Scope) = E_Function
796 and then Nkind (Unit_Declaration_Node (Scop)) =
797 N_Generic_Subprogram_Declaration
798 then
799 null;
801 else
802 -- We need to determine whether the context of the call
803 -- provides a tag to make the call dispatching. This requires
804 -- the call to be the actual in an enclosing call, and that
805 -- actual must be controlling. If the call is an operand of
806 -- equality, the other operand must not be abstract.
808 if not Is_Tagged_Type (Typ)
809 and then not
810 (Ekind (Typ) = E_Anonymous_Access_Type
811 and then Is_Tagged_Type (Designated_Type (Typ)))
812 then
813 Abstract_Context_Error;
814 return;
815 end if;
817 Par := Parent (Call);
819 if Nkind (Par) = N_Parameter_Association then
820 Par := Parent (Par);
821 end if;
823 if Nkind (Par) = N_Qualified_Expression
824 or else Nkind (Par) = N_Unchecked_Type_Conversion
825 then
826 Par := Parent (Par);
827 end if;
829 if Nkind (Par) in N_Subprogram_Call
830 and then Is_Entity_Name (Name (Par))
831 then
832 declare
833 Enc_Subp : constant Entity_Id := Entity (Name (Par));
834 A : Node_Id;
835 F : Entity_Id;
836 Control : Entity_Id;
837 Ret_Type : Entity_Id;
839 begin
840 -- Find controlling formal that can provide tag for the
841 -- tag-indeterminate actual. The corresponding actual
842 -- must be the corresponding class-wide type.
844 F := First_Formal (Enc_Subp);
845 A := First_Actual (Par);
847 -- Find controlling type of call. Dereference if function
848 -- returns an access type.
850 Ret_Type := Etype (Call);
851 if Is_Access_Type (Etype (Call)) then
852 Ret_Type := Designated_Type (Ret_Type);
853 end if;
855 while Present (F) loop
856 Control := Etype (A);
858 if Is_Access_Type (Control) then
859 Control := Designated_Type (Control);
860 end if;
862 if Is_Controlling_Formal (F)
863 and then not (Call = A or else Parent (Call) = A)
864 and then Control = Class_Wide_Type (Ret_Type)
865 then
866 return;
867 end if;
869 Next_Formal (F);
870 Next_Actual (A);
871 end loop;
873 if Nkind (Par) = N_Function_Call
874 and then Is_Tag_Indeterminate (Par)
875 then
876 -- The parent may be an actual of an enclosing call
878 Check_Dispatching_Context (Par);
879 return;
881 else
882 Error_Msg_N
883 ("call to abstract function must be dispatching",
884 Call);
885 return;
886 end if;
887 end;
889 -- For equality operators, one of the operands must be
890 -- statically or dynamically tagged.
892 elsif Nkind (Par) in N_Op_Eq | N_Op_Ne then
893 if N = Right_Opnd (Par)
894 and then Is_Tag_Indeterminate (Left_Opnd (Par))
895 then
896 Abstract_Context_Error;
898 elsif N = Left_Opnd (Par)
899 and then Is_Tag_Indeterminate (Right_Opnd (Par))
900 then
901 Abstract_Context_Error;
902 end if;
904 return;
906 -- The left-hand side of an assignment provides the tag
908 elsif Nkind (Par) = N_Assignment_Statement then
909 return;
911 else
912 Abstract_Context_Error;
913 end if;
914 end if;
915 end if;
916 end Check_Dispatching_Context;
918 -- Start of processing for Check_Dispatching_Call
920 begin
921 -- Find a controlling argument, if any
923 if Present (Parameter_Associations (N)) then
924 Subp_Entity := Entity (Name (N));
926 Actual := First_Actual (N);
927 Formal := First_Formal (Subp_Entity);
928 while Present (Actual) loop
929 Control := Find_Controlling_Arg (Actual);
930 exit when Present (Control);
932 -- Check for the case where the actual is a tag-indeterminate call
933 -- whose result type is different than the tagged type associated
934 -- with the containing call, but is an ancestor of the type.
936 if Is_Controlling_Formal (Formal)
937 and then Is_Tag_Indeterminate (Actual)
938 and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
939 and then Is_Ancestor (Etype (Actual), Etype (Formal))
940 then
941 Indeterm_Ctrl_Type := Etype (Formal);
943 -- If the formal is controlling but the actual is not, the type
944 -- of the actual is statically known, and may be used as the
945 -- controlling tag for some other tag-indeterminate actual.
947 elsif Is_Controlling_Formal (Formal)
948 and then Is_Entity_Name (Actual)
949 and then Is_Tagged_Type (Etype (Actual))
950 then
951 Static_Tag := Etype (Actual);
952 end if;
954 Next_Actual (Actual);
955 Next_Formal (Formal);
956 end loop;
958 if Present (Control) then
960 -- Verify that no controlling arguments are statically tagged
962 if Debug_Flag_E then
963 Write_Str ("Found Dispatching call");
964 Write_Int (Int (N));
965 Write_Eol;
966 end if;
968 Actual := First_Actual (N);
969 while Present (Actual) loop
970 if Actual /= Control then
972 if not Is_Controlling_Actual (Actual) then
973 null; -- Can be anything
975 elsif Is_Dynamically_Tagged (Actual) then
976 null; -- Valid parameter
978 elsif Is_Tag_Indeterminate (Actual) then
980 -- The tag is inherited from the enclosing call (the node
981 -- we are currently analyzing). Explicitly expand the
982 -- actual, since the previous call to Expand (from
983 -- Resolve_Call) had no way of knowing about the
984 -- required dispatching.
986 Propagate_Tag (Control, Actual);
988 else
989 Error_Msg_N
990 ("controlling argument is not dynamically tagged",
991 Actual);
992 return;
993 end if;
994 end if;
996 Next_Actual (Actual);
997 end loop;
999 -- Mark call as a dispatching call
1001 Set_Controlling_Argument (N, Control);
1002 Check_Restriction (No_Dispatching_Calls, N);
1004 -- The dispatching call may need to be converted into a direct
1005 -- call in certain cases.
1007 Check_Direct_Call;
1009 -- If the call doesn't have a controlling actual but does have an
1010 -- indeterminate actual that requires dispatching treatment, then an
1011 -- object is needed that will serve as the controlling argument for
1012 -- a dispatching call on the indeterminate actual. This can occur
1013 -- in the unusual situation of a default actual given by a tag-
1014 -- indeterminate call and where the type of the call is an ancestor
1015 -- of the type associated with a containing call to an inherited
1016 -- operation (see AI-239).
1018 -- Rather than create an object of the tagged type, which would
1019 -- be problematic for various reasons (default initialization,
1020 -- discriminants), the tag of the containing call's associated
1021 -- tagged type is directly used to control the dispatching.
1023 elsif Present (Indeterm_Ctrl_Type) then
1024 if Present (Static_Tag) then
1025 Control :=
1026 Make_Attribute_Reference (Loc,
1027 Prefix =>
1028 New_Occurrence_Of (Static_Tag, Loc),
1029 Attribute_Name => Name_Tag);
1031 else
1032 Control :=
1033 Make_Attribute_Reference (Loc,
1034 Prefix =>
1035 New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
1036 Attribute_Name => Name_Tag);
1037 end if;
1039 Analyze (Control);
1041 Actual := First_Actual (N);
1042 Formal := First_Formal (Subp_Entity);
1043 while Present (Actual) loop
1044 if Is_Tag_Indeterminate (Actual)
1045 and then Is_Controlling_Formal (Formal)
1046 then
1047 Propagate_Tag (Control, Actual);
1048 end if;
1050 Next_Actual (Actual);
1051 Next_Formal (Formal);
1052 end loop;
1054 Check_Dispatching_Context (N);
1056 elsif Nkind (N) /= N_Function_Call then
1058 -- The call is not dispatching, so check that there aren't any
1059 -- tag-indeterminate abstract calls left among its actuals.
1061 Actual := First_Actual (N);
1062 while Present (Actual) loop
1063 if Is_Tag_Indeterminate (Actual) then
1065 -- Function call case
1067 if Nkind (Original_Node (Actual)) = N_Function_Call then
1068 Func := Entity (Name (Original_Node (Actual)));
1070 -- If the actual is an attribute then it can't be abstract
1071 -- (the only current case of a tag-indeterminate attribute
1072 -- is the stream Input attribute).
1074 elsif Nkind (Original_Node (Actual)) = N_Attribute_Reference
1075 then
1076 Func := Empty;
1078 -- Ditto if it is an explicit dereference
1080 elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference
1081 then
1082 Func := Empty;
1084 -- Only other possibility is a qualified expression whose
1085 -- constituent expression is itself a call.
1087 else
1088 Func :=
1089 Entity (Name (Original_Node
1090 (Expression (Original_Node (Actual)))));
1091 end if;
1093 if Present (Func) and then Is_Abstract_Subprogram (Func) then
1094 Error_Msg_N
1095 ("call to abstract function must be dispatching",
1096 Actual);
1097 end if;
1098 end if;
1100 Next_Actual (Actual);
1101 end loop;
1103 Check_Dispatching_Context (N);
1105 elsif Nkind (Parent (N)) in N_Subexpr then
1106 Check_Dispatching_Context (N);
1108 elsif Nkind (Parent (N)) = N_Assignment_Statement
1109 and then Is_Class_Wide_Type (Etype (Name (Parent (N))))
1110 then
1111 return;
1113 elsif Is_Abstract_Subprogram (Subp_Entity) then
1114 Check_Dispatching_Context (N);
1115 return;
1116 end if;
1118 -- If this is a nondispatching call to a nonabstract subprogram
1119 -- and the subprogram has any Pre'Class or Post'Class aspects with
1120 -- nonstatic values, then report an error. This is specified by
1121 -- RM 6.1.1(18.2/5) (by AI12-0412).
1123 -- Skip reporting this error on helpers and indirect-call wrappers
1124 -- built to support class-wide preconditions.
1126 if No (Control)
1127 and then not Is_Abstract_Subprogram (Subp_Entity)
1128 and then
1129 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp_Entity)
1130 and then not
1131 (Is_Subprogram (Current_Scope)
1132 and then
1133 Present (Class_Preconditions_Subprogram (Current_Scope)))
1134 then
1135 Error_Msg_N
1136 ("nondispatching call to nonabstract subprogram of "
1137 & "abstract type with nonstatic class-wide "
1138 & "pre/postconditions",
1140 end if;
1142 else
1143 -- If dispatching on result, the enclosing call, if any, will
1144 -- determine the controlling argument. Otherwise this is the
1145 -- primitive operation of the root type.
1147 Check_Dispatching_Context (N);
1148 end if;
1149 end Check_Dispatching_Call;
1151 ---------------------------------
1152 -- Check_Dispatching_Operation --
1153 ---------------------------------
1155 procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
1156 function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean;
1157 -- Return True if E is an access to subprogram wrapper
1159 procedure Warn_On_Late_Primitive_After_Private_Extension
1160 (Typ : Entity_Id;
1161 Prim : Entity_Id);
1162 -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
1163 -- if it is a public primitive defined after some private extension of
1164 -- the tagged type.
1166 -------------------------------------
1167 -- Is_Access_To_Subprogram_Wrapper --
1168 -------------------------------------
1170 function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean
1172 Decl_N : constant Node_Id := Unit_Declaration_Node (E);
1173 Par_N : constant Node_Id := Parent (List_Containing (Decl_N));
1175 begin
1176 -- Access to subprogram wrappers are declared in the freezing actions
1178 return Nkind (Par_N) = N_Freeze_Entity
1179 and then Ekind (Entity (Par_N)) = E_Access_Subprogram_Type;
1180 end Is_Access_To_Subprogram_Wrapper;
1182 ----------------------------------------------------
1183 -- Warn_On_Late_Primitive_After_Private_Extension --
1184 ----------------------------------------------------
1186 procedure Warn_On_Late_Primitive_After_Private_Extension
1187 (Typ : Entity_Id;
1188 Prim : Entity_Id)
1190 E : Entity_Id;
1192 begin
1193 if Warn_On_Late_Primitives
1194 and then Comes_From_Source (Prim)
1195 and then Has_Private_Extension (Typ)
1196 and then Is_Package_Or_Generic_Package (Current_Scope)
1197 and then not In_Private_Part (Current_Scope)
1198 then
1199 E := Next_Entity (Typ);
1201 while E /= Prim loop
1202 if Ekind (E) = E_Record_Type_With_Private
1203 and then Etype (E) = Typ
1204 then
1205 Error_Msg_Name_1 := Chars (Typ);
1206 Error_Msg_Name_2 := Chars (E);
1207 Error_Msg_Sloc := Sloc (E);
1208 Error_Msg_N
1209 ("?.j?primitive of type % defined after private extension "
1210 & "% #?", Prim);
1211 Error_Msg_Name_1 := Chars (Prim);
1212 Error_Msg_Name_2 := Chars (E);
1213 Error_Msg_N
1214 ("\spec of % should appear before declaration of type %!",
1215 Prim);
1216 exit;
1217 end if;
1219 Next_Entity (E);
1220 end loop;
1221 end if;
1222 end Warn_On_Late_Primitive_After_Private_Extension;
1224 -- Local variables
1226 Body_Is_Last_Primitive : Boolean := False;
1227 Has_Dispatching_Parent : Boolean := False;
1228 Ovr_Subp : Entity_Id := Empty;
1229 Tagged_Type : Entity_Id;
1231 -- Start of processing for Check_Dispatching_Operation
1233 begin
1234 if Ekind (Subp) not in E_Function | E_Procedure then
1235 return;
1237 -- The Default_Initial_Condition procedure is not a primitive subprogram
1238 -- even if it relates to a tagged type. This routine is not meant to be
1239 -- inherited or overridden.
1241 elsif Is_DIC_Procedure (Subp) then
1242 return;
1244 -- The "partial" and "full" type invariant procedures are not primitive
1245 -- subprograms even if they relate to a tagged type. These routines are
1246 -- not meant to be inherited or overridden.
1248 elsif Is_Invariant_Procedure (Subp)
1249 or else Is_Partial_Invariant_Procedure (Subp)
1250 then
1251 return;
1253 -- Wrappers of access to subprograms are not primitive subprograms.
1255 elsif Is_Wrapper (Subp)
1256 and then Is_Access_To_Subprogram_Wrapper (Subp)
1257 then
1258 return;
1259 end if;
1261 Set_Is_Dispatching_Operation (Subp, False);
1262 Tagged_Type := Find_Dispatching_Type (Subp);
1264 -- Ada 2005 (AI-345): Use the corresponding record (if available).
1265 -- Required because primitives of concurrent types are attached
1266 -- to the corresponding record (not to the concurrent type).
1268 if Ada_Version >= Ada_2005
1269 and then Present (Tagged_Type)
1270 and then Is_Concurrent_Type (Tagged_Type)
1271 and then Present (Corresponding_Record_Type (Tagged_Type))
1272 then
1273 Tagged_Type := Corresponding_Record_Type (Tagged_Type);
1274 end if;
1276 -- (AI-345): The task body procedure is not a primitive of the tagged
1277 -- type
1279 if Present (Tagged_Type)
1280 and then Is_Concurrent_Record_Type (Tagged_Type)
1281 and then Present (Corresponding_Concurrent_Type (Tagged_Type))
1282 and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type))
1283 and then Subp = Get_Task_Body_Procedure
1284 (Corresponding_Concurrent_Type (Tagged_Type))
1285 then
1286 return;
1287 end if;
1289 -- If Subp is derived from a dispatching operation then it should
1290 -- always be treated as dispatching. In this case various checks
1291 -- below will be bypassed. Makes sure that late declarations for
1292 -- inherited private subprograms are treated as dispatching, even
1293 -- if the associated tagged type is already frozen.
1295 Has_Dispatching_Parent :=
1296 Present (Alias (Subp))
1297 and then Is_Dispatching_Operation (Alias (Subp));
1299 if No (Tagged_Type) then
1301 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
1302 -- with an abstract interface type unless the interface acts as a
1303 -- parent type in a derivation. If the interface type is a formal
1304 -- type then the operation is not primitive and therefore legal.
1306 declare
1307 E : Entity_Id;
1308 Typ : Entity_Id;
1310 begin
1311 E := First_Entity (Subp);
1312 while Present (E) loop
1314 -- For an access parameter, check designated type
1316 if Ekind (Etype (E)) = E_Anonymous_Access_Type then
1317 Typ := Designated_Type (Etype (E));
1318 else
1319 Typ := Etype (E);
1320 end if;
1322 if Comes_From_Source (Subp)
1323 and then Is_Interface (Typ)
1324 and then not Is_Class_Wide_Type (Typ)
1325 and then not Is_Derived_Type (Typ)
1326 and then not Is_Generic_Type (Typ)
1327 and then not In_Instance
1328 then
1329 Error_Msg_N ("??declaration of& is too late!", Subp);
1330 Error_Msg_NE -- CODEFIX??
1331 ("\??spec should appear immediately after declaration of "
1332 & "& !", Subp, Typ);
1333 exit;
1334 end if;
1336 Next_Entity (E);
1337 end loop;
1339 -- In case of functions check also the result type
1341 if Ekind (Subp) = E_Function then
1342 if Is_Access_Type (Etype (Subp)) then
1343 Typ := Designated_Type (Etype (Subp));
1344 else
1345 Typ := Etype (Subp);
1346 end if;
1348 -- The following should be better commented, especially since
1349 -- we just added several new conditions here ???
1351 if Comes_From_Source (Subp)
1352 and then Is_Interface (Typ)
1353 and then not Is_Class_Wide_Type (Typ)
1354 and then not Is_Derived_Type (Typ)
1355 and then not Is_Generic_Type (Typ)
1356 and then not In_Instance
1357 then
1358 Error_Msg_N ("??declaration of& is too late!", Subp);
1359 Error_Msg_NE
1360 ("\??spec should appear immediately after declaration of "
1361 & "& !", Subp, Typ);
1362 end if;
1363 end if;
1364 end;
1366 return;
1368 -- The subprograms build internally after the freezing point (such as
1369 -- init procs, interface thunks, type support subprograms, and Offset
1370 -- to top functions for accessing interface components in variable
1371 -- size tagged types) are not primitives.
1373 elsif Is_Frozen (Tagged_Type)
1374 and then not Comes_From_Source (Subp)
1375 and then not Has_Dispatching_Parent
1376 then
1377 -- Complete decoration of internally built subprograms that override
1378 -- a dispatching primitive. These entities correspond with the
1379 -- following cases:
1381 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
1382 -- to override functions of nonabstract null extensions. These
1383 -- primitives were added to the list of primitives of the tagged
1384 -- type by Make_Controlling_Function_Wrappers. However, attribute
1385 -- Is_Dispatching_Operation must be set to true.
1387 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
1388 -- primitives.
1390 -- 3. Subprograms associated with stream attributes (built by
1391 -- New_Stream_Subprogram) or with the Put_Image attribute.
1393 -- 4. Wrappers built for inherited operations. We have two kinds:
1394 -- * Wrappers built for inherited operations with inherited class-
1395 -- wide conditions, where the conditions include calls to other
1396 -- overridden primitives. The wrappers include checks on these
1397 -- modified conditions (AI12-195).
1398 -- * Wrappers built for inherited operations that implement
1399 -- interface primitives that have class-wide postconditions.
1401 -- 5. Declarations built for subprograms without separate specs that
1402 -- are eligible for inlining in GNATprove (inside
1403 -- Sem_Ch6.Analyze_Subprogram_Body_Helper).
1405 if Present (Old_Subp)
1406 and then Present (Overridden_Operation (Subp))
1407 and then Is_Dispatching_Operation (Old_Subp)
1408 then
1409 pragma Assert
1410 ((Ekind (Subp) = E_Function
1411 and then Is_Dispatching_Operation (Old_Subp)
1412 and then Is_Null_Extension (Base_Type (Etype (Subp))))
1414 or else
1415 (Ekind (Subp) = E_Procedure
1416 and then Is_Dispatching_Operation (Old_Subp)
1417 and then Present (Alias (Old_Subp))
1418 and then Is_Null_Interface_Primitive
1419 (Ultimate_Alias (Old_Subp)))
1421 or else Get_TSS_Name (Subp) in TSS_Stream_Read
1422 | TSS_Stream_Write
1423 | TSS_Put_Image
1425 or else
1426 (Is_Wrapper (Subp)
1427 and then Is_Dispatch_Table_Wrapper (Subp))
1429 or else GNATprove_Mode);
1431 Check_Controlling_Formals (Tagged_Type, Subp);
1432 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
1433 Set_Is_Dispatching_Operation (Subp);
1434 end if;
1436 return;
1438 -- The operation may be a child unit, whose scope is the defining
1439 -- package, but which is not a primitive operation of the type.
1441 elsif Is_Child_Unit (Subp) then
1442 return;
1444 -- If the subprogram is not defined in a package spec, the only case
1445 -- where it can be a dispatching op is when it overrides an operation
1446 -- before the freezing point of the type.
1448 elsif (not Is_Package_Or_Generic_Package (Scope (Subp))
1449 or else In_Package_Body (Scope (Subp)))
1450 and then not Has_Dispatching_Parent
1451 then
1452 if not Comes_From_Source (Subp)
1453 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
1454 then
1455 null;
1457 -- If the type is already frozen, the overriding is not allowed
1458 -- except when Old_Subp is not a dispatching operation (which can
1459 -- occur when Old_Subp was inherited by an untagged type). However,
1460 -- a body with no previous spec freezes the type *after* its
1461 -- declaration, and therefore is a legal overriding (unless the type
1462 -- has already been frozen). Only the first such body is legal.
1464 elsif Present (Old_Subp)
1465 and then Is_Dispatching_Operation (Old_Subp)
1466 then
1467 if Comes_From_Source (Subp)
1468 and then
1469 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
1470 or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
1471 then
1472 declare
1473 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
1474 Decl_Item : Node_Id;
1476 begin
1477 -- ??? The checks here for whether the type has been frozen
1478 -- prior to the new body are not complete. It's not simple
1479 -- to check frozenness at this point since the body has
1480 -- already caused the type to be prematurely frozen in
1481 -- Analyze_Declarations, but we're forced to recheck this
1482 -- here because of the odd rule interpretation that allows
1483 -- the overriding if the type wasn't frozen prior to the
1484 -- body. The freezing action should probably be delayed
1485 -- until after the spec is seen, but that's a tricky
1486 -- change to the delicate freezing code.
1488 -- Look at each declaration following the type up until the
1489 -- new subprogram body. If any of the declarations is a body
1490 -- then the type has been frozen already so the overriding
1491 -- primitive is illegal.
1493 Decl_Item := Next (Parent (Tagged_Type));
1494 while Present (Decl_Item)
1495 and then Decl_Item /= Subp_Body
1496 loop
1497 if Comes_From_Source (Decl_Item)
1498 and then (Nkind (Decl_Item) in N_Proper_Body
1499 or else Nkind (Decl_Item) in N_Body_Stub)
1500 then
1501 Error_Msg_N ("overriding of& is too late!", Subp);
1502 Error_Msg_N
1503 ("\spec should appear immediately after the type!",
1504 Subp);
1505 exit;
1506 end if;
1508 Next (Decl_Item);
1509 end loop;
1511 -- If the subprogram doesn't follow in the list of
1512 -- declarations including the type then the type has
1513 -- definitely been frozen already and the body is illegal.
1515 if No (Decl_Item) then
1516 Error_Msg_N ("overriding of& is too late!", Subp);
1517 Error_Msg_N
1518 ("\spec should appear immediately after the type!",
1519 Subp);
1521 else
1522 -- The subprogram body declares a primitive operation.
1523 -- We must update its dispatching information here. The
1524 -- information is taken from the overridden subprogram.
1525 -- Such a late-overriding body also needs extra formals.
1526 -- We must also generate a cross-reference entry because
1527 -- references to other primitives were already created
1528 -- when type was frozen.
1530 Body_Is_Last_Primitive := True;
1532 if Present (DTC_Entity (Old_Subp)) then
1533 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
1534 Set_DT_Position_Value (Subp, DT_Position (Old_Subp));
1535 Create_Extra_Formals (Subp);
1537 if not Restriction_Active (No_Dispatching_Calls) then
1538 if Building_Static_DT (Tagged_Type) then
1540 -- If the static dispatch table has not been
1541 -- built then there is nothing else to do now;
1542 -- otherwise we notify that we cannot build the
1543 -- static dispatch table.
1545 if Has_Dispatch_Table (Tagged_Type) then
1546 Error_Msg_N
1547 ("overriding of& is too late for building "
1548 & " static dispatch tables!", Subp);
1549 Error_Msg_N
1550 ("\spec should appear immediately after "
1551 & "the type!", Subp);
1552 end if;
1554 -- No code required to register primitives in VM
1555 -- targets
1557 elsif not Tagged_Type_Expansion then
1558 null;
1560 else
1561 Insert_Actions_After (Subp_Body,
1562 Register_Primitive (Sloc (Subp_Body),
1563 Prim => Subp));
1564 end if;
1566 -- Indicate that this is an overriding operation,
1567 -- and replace the overridden entry in the list of
1568 -- primitive operations, which is used for xref
1569 -- generation subsequently.
1571 Generate_Reference (Tagged_Type, Subp, 'P', False);
1572 Override_Dispatching_Operation
1573 (Tagged_Type, Old_Subp, Subp);
1574 Set_Is_Dispatching_Operation (Subp);
1576 -- Inherit decoration of controlling formals and
1577 -- controlling result.
1579 if Ekind (Old_Subp) = E_Function
1580 and then Has_Controlling_Result (Old_Subp)
1581 then
1582 Set_Has_Controlling_Result (Subp);
1583 end if;
1585 if Present (First_Formal (Old_Subp)) then
1586 declare
1587 Old_Formal : Entity_Id;
1588 Formal : Entity_Id;
1590 begin
1591 Formal := First_Formal (Subp);
1592 Old_Formal := First_Formal (Old_Subp);
1594 while Present (Old_Formal) loop
1595 Set_Is_Controlling_Formal (Formal,
1596 Is_Controlling_Formal (Old_Formal));
1598 Next_Formal (Formal);
1599 Next_Formal (Old_Formal);
1600 end loop;
1601 end;
1602 end if;
1603 end if;
1605 Check_Inherited_Conditions (Tagged_Type,
1606 Late_Overriding => True);
1607 end if;
1608 end if;
1609 end;
1611 else
1612 Error_Msg_N ("overriding of& is too late!", Subp);
1613 Error_Msg_N
1614 ("\subprogram spec should appear immediately after the type!",
1615 Subp);
1616 end if;
1618 -- If the type is not frozen yet and we are not in the overriding
1619 -- case it looks suspiciously like an attempt to define a primitive
1620 -- operation, which requires the declaration to be in a package spec
1621 -- (3.2.3(6)). Only report cases where the type and subprogram are
1622 -- in the same declaration list (by checking the enclosing parent
1623 -- declarations), to avoid spurious warnings on subprograms in
1624 -- instance bodies when the type is declared in the instance spec
1625 -- but hasn't been frozen by the instance body.
1627 elsif not Is_Frozen (Tagged_Type)
1628 and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp)))
1629 then
1630 Error_Msg_N
1631 ("??not dispatching (must be defined in a package spec)", Subp);
1632 return;
1634 -- When the type is frozen, it is legitimate to define a new
1635 -- non-primitive operation.
1637 else
1638 return;
1639 end if;
1641 -- Now, we are sure that the scope is a package spec. If the subprogram
1642 -- is declared after the freezing point of the type that's an error
1644 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
1645 Error_Msg_N ("this primitive operation is declared too late", Subp);
1646 Error_Msg_NE
1647 ("??no primitive operations for& after this line",
1648 Freeze_Node (Tagged_Type),
1649 Tagged_Type);
1650 return;
1651 end if;
1653 Check_Controlling_Formals (Tagged_Type, Subp);
1655 Ovr_Subp := Old_Subp;
1657 -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1658 -- overridden by Subp. This only applies to source subprograms, and
1659 -- their declaration must carry an explicit overriding indicator.
1661 if No (Ovr_Subp)
1662 and then Ada_Version >= Ada_2012
1663 and then Comes_From_Source (Subp)
1664 and then
1665 Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration
1666 then
1667 Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp);
1669 -- Verify that the proper overriding indicator has been supplied.
1671 if Present (Ovr_Subp)
1672 and then
1673 not Must_Override (Specification (Unit_Declaration_Node (Subp)))
1674 then
1675 Error_Msg_NE ("missing overriding indicator for&", Subp, Subp);
1676 end if;
1677 end if;
1679 -- Now it should be a correct primitive operation, put it in the list
1681 if Present (Ovr_Subp) then
1683 -- If the type has interfaces we complete this check after we set
1684 -- attribute Is_Dispatching_Operation.
1686 Check_Subtype_Conformant (Subp, Ovr_Subp);
1688 -- A primitive operation with the name of a primitive controlled
1689 -- operation does not override a non-visible overriding controlled
1690 -- operation, i.e. one declared in a private part when the full
1691 -- view of a type is controlled. Conversely, it will override a
1692 -- visible operation that may be declared in a partial view when
1693 -- the full view is controlled.
1695 if Chars (Subp) in Name_Initialize | Name_Adjust | Name_Finalize
1696 and then Is_Controlled (Tagged_Type)
1697 and then not Is_Visibly_Controlled (Tagged_Type)
1698 and then not Is_Inherited_Public_Operation (Ovr_Subp)
1699 then
1700 Set_Overridden_Operation (Subp, Empty);
1702 -- If the subprogram specification carries an overriding
1703 -- indicator, no need for the warning: it is either redundant,
1704 -- or else an error will be reported.
1706 if Nkind (Parent (Subp)) = N_Procedure_Specification
1707 and then
1708 (Must_Override (Parent (Subp))
1709 or else Must_Not_Override (Parent (Subp)))
1710 then
1711 null;
1713 -- Here we need the warning
1715 else
1716 Error_Msg_NE
1717 ("operation does not override inherited&??", Subp, Subp);
1718 end if;
1720 else
1721 Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp);
1723 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1724 -- that covers abstract interface subprograms we must register it
1725 -- in all the secondary dispatch tables associated with abstract
1726 -- interfaces. We do this now only if not building static tables,
1727 -- nor when the expander is inactive (we avoid trying to register
1728 -- primitives in semantics-only mode, since the type may not have
1729 -- an associated dispatch table). Otherwise the patch code is
1730 -- emitted after those tables are built, to prevent access before
1731 -- elaboration in gigi.
1733 if Body_Is_Last_Primitive
1734 and then not Building_Static_DT (Tagged_Type)
1735 and then Expander_Active
1736 and then Tagged_Type_Expansion
1737 then
1738 declare
1739 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
1740 Elmt : Elmt_Id;
1741 Prim : Node_Id;
1743 begin
1744 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1745 while Present (Elmt) loop
1746 Prim := Node (Elmt);
1748 if Present (Alias (Prim))
1749 and then Present (Interface_Alias (Prim))
1750 and then Alias (Prim) = Subp
1751 then
1752 Insert_Actions_After (Subp_Body,
1753 Register_Primitive (Sloc (Subp_Body), Prim => Prim));
1754 end if;
1756 Next_Elmt (Elmt);
1757 end loop;
1759 -- Redisplay the contents of the updated dispatch table
1761 if Debug_Flag_ZZ then
1762 Write_Str ("Late overriding: ");
1763 Write_DT (Tagged_Type);
1764 end if;
1765 end;
1766 end if;
1767 end if;
1769 -- If no old subprogram, then we add this as a dispatching operation,
1770 -- but we avoid doing this if an error was posted, to prevent annoying
1771 -- cascaded errors.
1773 elsif not Error_Posted (Subp) then
1774 Add_Dispatching_Operation (Tagged_Type, Subp);
1775 end if;
1777 Set_Is_Dispatching_Operation (Subp, True);
1779 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1780 -- subtype conformance against all the interfaces covered by this
1781 -- primitive.
1783 if Present (Ovr_Subp)
1784 and then Has_Interfaces (Tagged_Type)
1785 then
1786 declare
1787 Ifaces_List : Elist_Id;
1788 Iface_Elmt : Elmt_Id;
1789 Iface_Prim_Elmt : Elmt_Id;
1790 Iface_Prim : Entity_Id;
1791 Ret_Typ : Entity_Id;
1793 begin
1794 Collect_Interfaces (Tagged_Type, Ifaces_List);
1796 Iface_Elmt := First_Elmt (Ifaces_List);
1797 while Present (Iface_Elmt) loop
1798 if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
1799 Iface_Prim_Elmt :=
1800 First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
1801 while Present (Iface_Prim_Elmt) loop
1802 Iface_Prim := Node (Iface_Prim_Elmt);
1804 if Is_Interface_Conformant
1805 (Tagged_Type, Iface_Prim, Subp)
1806 then
1807 -- Handle procedures, functions whose return type
1808 -- matches, or functions not returning interfaces
1810 if Ekind (Subp) = E_Procedure
1811 or else Etype (Iface_Prim) = Etype (Subp)
1812 or else not Is_Interface (Etype (Iface_Prim))
1813 then
1814 Check_Subtype_Conformant
1815 (New_Id => Subp,
1816 Old_Id => Iface_Prim,
1817 Err_Loc => Subp,
1818 Skip_Controlling_Formals => True);
1820 -- Handle functions returning interfaces
1822 elsif Implements_Interface
1823 (Etype (Subp), Etype (Iface_Prim))
1824 then
1825 -- Temporarily force both entities to return the
1826 -- same type. Required because Subtype_Conformant
1827 -- does not handle this case.
1829 Ret_Typ := Etype (Iface_Prim);
1830 Set_Etype (Iface_Prim, Etype (Subp));
1832 Check_Subtype_Conformant
1833 (New_Id => Subp,
1834 Old_Id => Iface_Prim,
1835 Err_Loc => Subp,
1836 Skip_Controlling_Formals => True);
1838 Set_Etype (Iface_Prim, Ret_Typ);
1839 end if;
1840 end if;
1842 Next_Elmt (Iface_Prim_Elmt);
1843 end loop;
1844 end if;
1846 Next_Elmt (Iface_Elmt);
1847 end loop;
1848 end;
1849 end if;
1851 if not Body_Is_Last_Primitive then
1852 Set_DT_Position_Value (Subp, No_Uint);
1854 elsif Has_Controlled_Component (Tagged_Type)
1855 and then Chars (Subp) in Name_Initialize
1856 | Name_Adjust
1857 | Name_Finalize
1858 | Name_Finalize_Address
1859 then
1860 declare
1861 F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
1862 Decl : Node_Id;
1863 Old_P : Entity_Id;
1864 Old_Bod : Node_Id;
1865 Old_Spec : Entity_Id;
1867 C_Names : constant array (1 .. 4) of Name_Id :=
1868 (Name_Initialize,
1869 Name_Adjust,
1870 Name_Finalize,
1871 Name_Finalize_Address);
1873 D_Names : constant array (1 .. 4) of TSS_Name_Type :=
1874 (TSS_Deep_Initialize,
1875 TSS_Deep_Adjust,
1876 TSS_Deep_Finalize,
1877 TSS_Finalize_Address);
1879 begin
1880 -- Remove previous controlled function which was constructed and
1881 -- analyzed when the type was frozen. This requires removing the
1882 -- body of the redefined primitive, as well as its specification
1883 -- if needed (there is no spec created for Deep_Initialize, see
1884 -- exp_ch3.adb). We must also dismantle the exception information
1885 -- that may have been generated for it when front end zero-cost
1886 -- tables are enabled.
1888 for J in D_Names'Range loop
1889 Old_P := TSS (Tagged_Type, D_Names (J));
1891 if Present (Old_P)
1892 and then Chars (Subp) = C_Names (J)
1893 then
1894 Old_Bod := Unit_Declaration_Node (Old_P);
1895 Remove (Old_Bod);
1896 Set_Is_Eliminated (Old_P);
1897 Set_Scope (Old_P, Scope (Current_Scope));
1899 if Nkind (Old_Bod) = N_Subprogram_Body
1900 and then Present (Corresponding_Spec (Old_Bod))
1901 then
1902 Old_Spec := Corresponding_Spec (Old_Bod);
1903 Set_Has_Completion (Old_Spec, False);
1904 end if;
1905 end if;
1906 end loop;
1908 Build_Late_Proc (Tagged_Type, Chars (Subp));
1910 -- The new operation is added to the actions of the freeze node
1911 -- for the type, but this node has already been analyzed, so we
1912 -- must retrieve and analyze explicitly the new body.
1914 if Present (F_Node)
1915 and then Present (Actions (F_Node))
1916 then
1917 Decl := Last (Actions (F_Node));
1918 Analyze (Decl);
1919 end if;
1920 end;
1921 end if;
1923 -- AI12-0279: If the Yield aspect is specified for a dispatching
1924 -- subprogram that inherits the aspect, the specified value shall
1925 -- be confirming.
1927 if Is_Dispatching_Operation (Subp)
1928 and then Is_Primitive_Wrapper (Subp)
1929 and then Present (Wrapped_Entity (Subp))
1930 and then Comes_From_Source (Wrapped_Entity (Subp))
1931 and then Present (Overridden_Operation (Subp))
1932 and then Has_Yield_Aspect (Overridden_Operation (Subp))
1933 /= Has_Yield_Aspect (Wrapped_Entity (Subp))
1934 then
1935 declare
1936 W_Ent : constant Entity_Id := Wrapped_Entity (Subp);
1937 W_Decl : constant Node_Id := Parent (W_Ent);
1938 Asp : Node_Id;
1940 begin
1941 Asp := First (Aspect_Specifications (W_Decl));
1942 while Present (Asp) loop
1943 if Chars (Identifier (Asp)) = Name_Yield then
1944 Error_Msg_Name_1 := Name_Yield;
1945 Error_Msg_N
1946 ("specification of inherited aspect% can only confirm "
1947 & "parent value", Asp);
1948 end if;
1950 Next (Asp);
1951 end loop;
1953 Set_Has_Yield_Aspect (Wrapped_Entity (Subp));
1954 end;
1955 end if;
1957 -- For similarity with record extensions, in Ada 9X the language should
1958 -- have disallowed adding visible operations to a tagged type after
1959 -- deriving a private extension from it. Report a warning if this
1960 -- primitive is defined after a private extension of Tagged_Type.
1962 Warn_On_Late_Primitive_After_Private_Extension (Tagged_Type, Subp);
1963 end Check_Dispatching_Operation;
1965 ------------------------------------------
1966 -- Check_Operation_From_Incomplete_Type --
1967 ------------------------------------------
1969 procedure Check_Operation_From_Incomplete_Type
1970 (Subp : Entity_Id;
1971 Typ : Entity_Id)
1973 Full : constant Entity_Id := Full_View (Typ);
1974 Parent_Typ : constant Entity_Id := Etype (Full);
1975 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
1976 New_Prim : constant Elist_Id := Primitive_Operations (Full);
1977 Op1, Op2 : Elmt_Id;
1978 Prev : Elmt_Id := No_Elmt;
1980 function Derives_From (Parent_Subp : Entity_Id) return Boolean;
1981 -- Check that Subp has profile of an operation derived from Parent_Subp.
1982 -- Subp must have a parameter or result type that is Typ or an access
1983 -- parameter or access result type that designates Typ.
1985 ------------------
1986 -- Derives_From --
1987 ------------------
1989 function Derives_From (Parent_Subp : Entity_Id) return Boolean is
1990 F1, F2 : Entity_Id;
1992 begin
1993 if Chars (Parent_Subp) /= Chars (Subp) then
1994 return False;
1995 end if;
1997 -- Check that the type of controlling formals is derived from the
1998 -- parent subprogram's controlling formal type (or designated type
1999 -- if the formal type is an anonymous access type).
2001 F1 := First_Formal (Parent_Subp);
2002 F2 := First_Formal (Subp);
2003 while Present (F1) and then Present (F2) loop
2004 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
2005 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
2006 return False;
2007 elsif Designated_Type (Etype (F1)) = Parent_Typ
2008 and then Designated_Type (Etype (F2)) /= Full
2009 then
2010 return False;
2011 end if;
2013 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
2014 return False;
2016 elsif Etype (F1) = Parent_Typ and then Etype (F2) /= Full then
2017 return False;
2018 end if;
2020 Next_Formal (F1);
2021 Next_Formal (F2);
2022 end loop;
2024 -- Check that a controlling result type is derived from the parent
2025 -- subprogram's result type (or designated type if the result type
2026 -- is an anonymous access type).
2028 if Ekind (Parent_Subp) = E_Function then
2029 if Ekind (Subp) /= E_Function then
2030 return False;
2032 elsif Ekind (Etype (Parent_Subp)) = E_Anonymous_Access_Type then
2033 if Ekind (Etype (Subp)) /= E_Anonymous_Access_Type then
2034 return False;
2036 elsif Designated_Type (Etype (Parent_Subp)) = Parent_Typ
2037 and then Designated_Type (Etype (Subp)) /= Full
2038 then
2039 return False;
2040 end if;
2042 elsif Ekind (Etype (Subp)) = E_Anonymous_Access_Type then
2043 return False;
2045 elsif Etype (Parent_Subp) = Parent_Typ
2046 and then Etype (Subp) /= Full
2047 then
2048 return False;
2049 end if;
2051 elsif Ekind (Subp) = E_Function then
2052 return False;
2053 end if;
2055 return No (F1) and then No (F2);
2056 end Derives_From;
2058 -- Start of processing for Check_Operation_From_Incomplete_Type
2060 begin
2061 -- The operation may override an inherited one, or may be a new one
2062 -- altogether. The inherited operation will have been hidden by the
2063 -- current one at the point of the type derivation, so it does not
2064 -- appear in the list of primitive operations of the type. We have to
2065 -- find the proper place of insertion in the list of primitive opera-
2066 -- tions by iterating over the list for the parent type.
2068 Op1 := First_Elmt (Old_Prim);
2069 Op2 := First_Elmt (New_Prim);
2070 while Present (Op1) and then Present (Op2) loop
2071 if Derives_From (Node (Op1)) then
2072 if No (Prev) then
2074 -- Avoid adding it to the list of primitives if already there
2076 if Node (Op2) /= Subp then
2077 Prepend_Elmt (Subp, New_Prim);
2078 end if;
2080 else
2081 Insert_Elmt_After (Subp, Prev);
2082 end if;
2084 return;
2085 end if;
2087 Prev := Op2;
2088 Next_Elmt (Op1);
2089 Next_Elmt (Op2);
2090 end loop;
2092 -- Operation is a new primitive
2094 Append_Elmt (Subp, New_Prim);
2095 end Check_Operation_From_Incomplete_Type;
2097 ---------------------------------------
2098 -- Check_Operation_From_Private_View --
2099 ---------------------------------------
2101 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
2102 Tagged_Type : Entity_Id;
2104 begin
2105 if Is_Dispatching_Operation (Alias (Subp)) then
2106 Set_Scope (Subp, Current_Scope);
2107 Tagged_Type := Find_Dispatching_Type (Subp);
2109 -- Add Old_Subp to primitive operations if not already present
2111 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
2112 Add_Dispatching_Operation (Tagged_Type, Old_Subp);
2114 -- If Old_Subp isn't already marked as dispatching then this is
2115 -- the case of an operation of an untagged private type fulfilled
2116 -- by a tagged type that overrides an inherited dispatching
2117 -- operation, so we set the necessary dispatching attributes here.
2119 if not Is_Dispatching_Operation (Old_Subp) then
2121 -- If the untagged type has no discriminants, and the full
2122 -- view is constrained, there will be a spurious mismatch of
2123 -- subtypes on the controlling arguments, because the tagged
2124 -- type is the internal base type introduced in the derivation.
2125 -- Use the original type to verify conformance, rather than the
2126 -- base type.
2128 if not Comes_From_Source (Tagged_Type)
2129 and then Has_Discriminants (Tagged_Type)
2130 then
2131 declare
2132 Formal : Entity_Id;
2134 begin
2135 Formal := First_Formal (Old_Subp);
2136 while Present (Formal) loop
2137 if Tagged_Type = Base_Type (Etype (Formal)) then
2138 Tagged_Type := Etype (Formal);
2139 end if;
2141 Next_Formal (Formal);
2142 end loop;
2143 end;
2145 if Tagged_Type = Base_Type (Etype (Old_Subp)) then
2146 Tagged_Type := Etype (Old_Subp);
2147 end if;
2148 end if;
2150 Check_Controlling_Formals (Tagged_Type, Old_Subp);
2151 Set_Is_Dispatching_Operation (Old_Subp, True);
2152 Set_DT_Position_Value (Old_Subp, No_Uint);
2153 end if;
2155 -- If the old subprogram is an explicit renaming of some other
2156 -- entity, it is not overridden by the inherited subprogram.
2157 -- Otherwise, update its alias and other attributes.
2159 if Present (Alias (Old_Subp))
2160 and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
2161 N_Subprogram_Renaming_Declaration
2162 then
2163 Set_Alias (Old_Subp, Alias (Subp));
2165 -- The derived subprogram should inherit the abstractness of
2166 -- the parent subprogram (except in the case of a function
2167 -- returning the type). This sets the abstractness properly
2168 -- for cases where a private extension may have inherited an
2169 -- abstract operation, but the full type is derived from a
2170 -- descendant type and inherits a nonabstract version.
2172 if Etype (Subp) /= Tagged_Type then
2173 Set_Is_Abstract_Subprogram
2174 (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
2175 end if;
2176 end if;
2177 end if;
2178 end if;
2179 end Check_Operation_From_Private_View;
2181 --------------------------
2182 -- Find_Controlling_Arg --
2183 --------------------------
2185 function Find_Controlling_Arg (N : Node_Id) return Node_Id is
2186 Orig_Node : constant Node_Id := Original_Node (N);
2187 Typ : Entity_Id;
2189 begin
2190 if Nkind (Orig_Node) = N_Qualified_Expression then
2191 return Find_Controlling_Arg (Expression (Orig_Node));
2192 end if;
2194 -- Dispatching on result case. If expansion is disabled, the node still
2195 -- has the structure of a function call. However, if the function name
2196 -- is an operator and the call was given in infix form, the original
2197 -- node has no controlling result and we must examine the current node.
2199 if Nkind (N) = N_Function_Call
2200 and then Present (Controlling_Argument (N))
2201 and then Has_Controlling_Result (Entity (Name (N)))
2202 then
2203 return Controlling_Argument (N);
2205 -- If expansion is enabled, the call may have been transformed into
2206 -- an indirect call, and we need to recover the original node.
2208 elsif Nkind (Orig_Node) = N_Function_Call
2209 and then Present (Controlling_Argument (Orig_Node))
2210 and then Has_Controlling_Result (Entity (Name (Orig_Node)))
2211 then
2212 return Controlling_Argument (Orig_Node);
2214 -- Type conversions are dynamically tagged if the target type, or its
2215 -- designated type, are classwide. An interface conversion expands into
2216 -- a dereference, so test must be performed on the original node.
2218 elsif Nkind (Orig_Node) = N_Type_Conversion
2219 and then Nkind (N) = N_Explicit_Dereference
2220 and then Is_Controlling_Actual (N)
2221 then
2222 declare
2223 Target_Type : constant Entity_Id :=
2224 Entity (Subtype_Mark (Orig_Node));
2226 begin
2227 if Is_Class_Wide_Type (Target_Type) then
2228 return N;
2230 elsif Is_Access_Type (Target_Type)
2231 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
2232 then
2233 return N;
2235 else
2236 return Empty;
2237 end if;
2238 end;
2240 -- Normal case
2242 elsif Is_Controlling_Actual (N)
2243 or else
2244 (Nkind (Parent (N)) = N_Qualified_Expression
2245 and then Is_Controlling_Actual (Parent (N)))
2246 then
2247 Typ := Etype (N);
2249 if Is_Access_Type (Typ) then
2251 -- In the case of an Access attribute, use the type of the prefix,
2252 -- since in the case of an actual for an access parameter, the
2253 -- attribute's type may be of a specific designated type, even
2254 -- though the prefix type is class-wide.
2256 if Nkind (N) = N_Attribute_Reference then
2257 Typ := Etype (Prefix (N));
2259 -- An allocator is dispatching if the type of qualified expression
2260 -- is class_wide, in which case this is the controlling type.
2262 elsif Nkind (Orig_Node) = N_Allocator
2263 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
2264 then
2265 Typ := Etype (Expression (Orig_Node));
2266 else
2267 Typ := Designated_Type (Typ);
2268 end if;
2269 end if;
2271 if Is_Class_Wide_Type (Typ)
2272 or else
2273 (Nkind (Parent (N)) = N_Qualified_Expression
2274 and then Is_Access_Type (Etype (N))
2275 and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
2276 then
2277 return N;
2278 end if;
2279 end if;
2281 return Empty;
2282 end Find_Controlling_Arg;
2284 ---------------------------
2285 -- Find_Dispatching_Type --
2286 ---------------------------
2288 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
2289 A_Formal : Entity_Id;
2290 Formal : Entity_Id;
2291 Ctrl_Type : Entity_Id;
2293 begin
2294 if Ekind (Subp) in E_Function | E_Procedure
2295 and then Present (DTC_Entity (Subp))
2296 then
2297 return Scope (DTC_Entity (Subp));
2299 -- For subprograms internally generated by derivations of tagged types
2300 -- use the alias subprogram as a reference to locate the dispatching
2301 -- type of Subp.
2303 elsif not Comes_From_Source (Subp)
2304 and then Present (Alias (Subp))
2305 and then Is_Dispatching_Operation (Alias (Subp))
2306 then
2307 if Ekind (Alias (Subp)) = E_Function
2308 and then Has_Controlling_Result (Alias (Subp))
2309 then
2310 return Check_Controlling_Type (Etype (Subp), Subp);
2312 else
2313 Formal := First_Formal (Subp);
2314 A_Formal := First_Formal (Alias (Subp));
2315 while Present (A_Formal) loop
2316 if Is_Controlling_Formal (A_Formal) then
2317 return Check_Controlling_Type (Etype (Formal), Subp);
2318 end if;
2320 Next_Formal (Formal);
2321 Next_Formal (A_Formal);
2322 end loop;
2324 pragma Assert (False);
2325 return Empty;
2326 end if;
2328 -- General case
2330 else
2331 Formal := First_Formal (Subp);
2332 while Present (Formal) loop
2333 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
2335 if Present (Ctrl_Type) then
2336 return Ctrl_Type;
2337 end if;
2339 Next_Formal (Formal);
2340 end loop;
2342 -- The subprogram may also be dispatching on result
2344 if Present (Etype (Subp)) then
2345 return Check_Controlling_Type (Etype (Subp), Subp);
2346 end if;
2347 end if;
2349 pragma Assert (not Is_Dispatching_Operation (Subp));
2350 return Empty;
2351 end Find_Dispatching_Type;
2353 --------------------------------------
2354 -- Find_Hidden_Overridden_Primitive --
2355 --------------------------------------
2357 function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id
2359 Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S);
2360 Elmt : Elmt_Id;
2361 Orig_Prim : Entity_Id;
2362 Prim : Entity_Id;
2363 Vis_List : Elist_Id;
2365 begin
2366 -- This Ada 2012 rule applies only for type extensions or private
2367 -- extensions, where the parent type is not in a parent unit, and
2368 -- where an operation is never declared but still inherited.
2370 if No (Tag_Typ)
2371 or else not Is_Record_Type (Tag_Typ)
2372 or else Etype (Tag_Typ) = Tag_Typ
2373 or else In_Open_Scopes (Scope (Etype (Tag_Typ)))
2374 then
2375 return Empty;
2376 end if;
2378 -- Collect the list of visible ancestor of the tagged type
2380 Vis_List := Visible_Ancestors (Tag_Typ);
2382 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
2383 while Present (Elmt) loop
2384 Prim := Node (Elmt);
2386 -- Find an inherited hidden dispatching primitive with the name of S
2387 -- and a type-conformant profile.
2389 if Present (Alias (Prim))
2390 and then Is_Hidden (Alias (Prim))
2391 and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ
2392 and then Primitive_Names_Match (S, Prim)
2393 and then Type_Conformant (S, Prim)
2394 then
2395 declare
2396 Vis_Ancestor : Elmt_Id;
2397 Elmt : Elmt_Id;
2399 begin
2400 -- The original corresponding operation of Prim must be an
2401 -- operation of a visible ancestor of the dispatching type S,
2402 -- and the original corresponding operation of S2 must be
2403 -- visible.
2405 Orig_Prim := Original_Corresponding_Operation (Prim);
2407 if Orig_Prim /= Prim
2408 and then not Is_Hidden (Orig_Prim)
2409 then
2410 Vis_Ancestor := First_Elmt (Vis_List);
2411 while Present (Vis_Ancestor) loop
2412 Elmt :=
2413 First_Elmt (Primitive_Operations (Node (Vis_Ancestor)));
2414 while Present (Elmt) loop
2415 if Node (Elmt) = Orig_Prim then
2416 Set_Overridden_Operation (S, Prim);
2417 Set_Is_Ada_2022_Only (S,
2418 Is_Ada_2022_Only (Prim));
2419 Set_Alias (Prim, Orig_Prim);
2420 return Prim;
2421 end if;
2423 Next_Elmt (Elmt);
2424 end loop;
2426 Next_Elmt (Vis_Ancestor);
2427 end loop;
2428 end if;
2429 end;
2430 end if;
2432 Next_Elmt (Elmt);
2433 end loop;
2435 return Empty;
2436 end Find_Hidden_Overridden_Primitive;
2438 ---------------------------------------
2439 -- Find_Primitive_Covering_Interface --
2440 ---------------------------------------
2442 function Find_Primitive_Covering_Interface
2443 (Tagged_Type : Entity_Id;
2444 Iface_Prim : Entity_Id) return Entity_Id
2446 E : Entity_Id;
2447 El : Elmt_Id;
2449 begin
2450 pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
2451 or else (Present (Alias (Iface_Prim))
2452 and then
2453 Is_Interface
2454 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
2456 -- Search in the homonym chain. Done to speed up locating visible
2457 -- entities and required to catch primitives associated with the partial
2458 -- view of private types when processing the corresponding full view.
2460 E := Current_Entity (Iface_Prim);
2461 while Present (E) loop
2462 if Is_Subprogram (E)
2463 and then Is_Dispatching_Operation (E)
2464 and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
2465 then
2466 return E;
2467 end if;
2469 E := Homonym (E);
2470 end loop;
2472 -- Search in the list of primitives of the type. Required to locate
2473 -- the covering primitive if the covering primitive is not visible
2474 -- (for example, non-visible inherited primitive of private type).
2476 El := First_Elmt (Primitive_Operations (Tagged_Type));
2477 while Present (El) loop
2478 E := Node (El);
2480 -- Keep separate the management of internal entities that link
2481 -- primitives with interface primitives from tagged type primitives.
2483 if No (Interface_Alias (E)) then
2484 if Present (Alias (E)) then
2486 -- This interface primitive has not been covered yet
2488 if Alias (E) = Iface_Prim then
2489 return E;
2491 -- The covering primitive was inherited
2493 elsif Overridden_Operation (Ultimate_Alias (E))
2494 = Iface_Prim
2495 then
2496 return E;
2497 end if;
2498 end if;
2500 -- Check if E covers the interface primitive (includes case in
2501 -- which E is an inherited private primitive).
2503 if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
2504 return E;
2505 end if;
2507 -- Use the internal entity that links the interface primitive with
2508 -- the covering primitive to locate the entity.
2510 elsif Interface_Alias (E) = Iface_Prim then
2511 return Alias (E);
2512 end if;
2514 Next_Elmt (El);
2515 end loop;
2517 -- Not found
2519 return Empty;
2520 end Find_Primitive_Covering_Interface;
2522 ---------------------------
2523 -- Inheritance_Utilities --
2524 ---------------------------
2526 package body Inheritance_Utilities is
2528 ---------------------------
2529 -- Inherited_Subprograms --
2530 ---------------------------
2532 function Inherited_Subprograms
2533 (S : Entity_Id;
2534 No_Interfaces : Boolean := False;
2535 Interfaces_Only : Boolean := False;
2536 Skip_Overridden : Boolean := False;
2537 One_Only : Boolean := False) return Subprogram_List
2539 Result : Subprogram_List (1 .. 6000);
2540 -- 6000 here is intended to be infinity. We could use an expandable
2541 -- table, but it would be awfully heavy, and there is no way that we
2542 -- could reasonably exceed this value.
2544 N : Nat := 0;
2545 -- Number of entries in Result
2547 Parent_Op : Entity_Id;
2548 -- Traverses the Overridden_Operation chain
2550 procedure Store_IS (E : Entity_Id);
2551 -- Stores E in Result if not already stored
2553 --------------
2554 -- Store_IS --
2555 --------------
2557 procedure Store_IS (E : Entity_Id) is
2558 begin
2559 for J in 1 .. N loop
2560 if E = Result (J) then
2561 return;
2562 end if;
2563 end loop;
2565 N := N + 1;
2566 Result (N) := E;
2567 end Store_IS;
2569 -- Start of processing for Inherited_Subprograms
2571 begin
2572 pragma Assert (not (No_Interfaces and Interfaces_Only));
2574 -- When used from backends, visibility can be handled differently
2575 -- resulting in no dispatching type being found.
2577 if Present (S)
2578 and then Is_Dispatching_Operation (S)
2579 and then Present (Find_DT (S))
2580 then
2581 -- Deal with direct inheritance
2583 if not Interfaces_Only then
2584 Parent_Op := S;
2585 loop
2586 Parent_Op := Overridden_Operation (Parent_Op);
2587 exit when No (Parent_Op)
2588 or else No (Find_DT (Parent_Op))
2589 or else (No_Interfaces
2590 and then Is_Interface (Find_DT (Parent_Op)));
2592 if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then
2593 Store_IS (Parent_Op);
2595 if One_Only then
2596 goto Done;
2597 end if;
2598 end if;
2599 end loop;
2600 end if;
2602 -- Now deal with interfaces
2604 if not No_Interfaces then
2605 declare
2606 Tag_Typ : Entity_Id;
2607 Prim : Entity_Id;
2608 Elmt : Elmt_Id;
2610 begin
2611 Tag_Typ := Find_DT (S);
2613 -- In the presence of limited views there may be no visible
2614 -- dispatching type. Primitives will be inherited when non-
2615 -- limited view is frozen.
2617 if No (Tag_Typ) then
2618 return Result (1 .. 0);
2620 -- Prevent cascaded errors
2622 elsif Is_Concurrent_Type (Tag_Typ)
2623 and then No (Corresponding_Record_Type (Tag_Typ))
2624 and then Serious_Errors_Detected > 0
2625 then
2626 return Result (1 .. 0);
2627 end if;
2629 if Is_Concurrent_Type (Tag_Typ) then
2630 Tag_Typ := Corresponding_Record_Type (Tag_Typ);
2631 end if;
2633 if Present (Tag_Typ)
2634 and then Is_Private_Type (Tag_Typ)
2635 and then Present (Full_View (Tag_Typ))
2636 then
2637 Tag_Typ := Full_View (Tag_Typ);
2638 end if;
2640 -- Search primitive operations of dispatching type
2642 if Present (Tag_Typ)
2643 and then Present (Primitive_Operations (Tag_Typ))
2644 then
2645 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
2646 while Present (Elmt) loop
2647 Prim := Node (Elmt);
2649 -- The following test eliminates some odd cases in
2650 -- which Ekind (Prim) is Void, to be investigated
2651 -- further ???
2653 if not Is_Subprogram_Or_Generic_Subprogram (Prim) then
2654 null;
2656 -- For [generic] subprogram, look at interface
2657 -- alias.
2659 elsif Present (Interface_Alias (Prim))
2660 and then Alias (Prim) = S
2661 then
2662 -- We have found a primitive covered by S
2664 Store_IS (Interface_Alias (Prim));
2666 if One_Only then
2667 goto Done;
2668 end if;
2669 end if;
2671 Next_Elmt (Elmt);
2672 end loop;
2673 end if;
2674 end;
2675 end if;
2676 end if;
2678 -- Do not keep an overridden operation if its overridding operation
2679 -- is in the results too, and it is not S. This can happen for
2680 -- inheritance between interfaces.
2682 if Skip_Overridden then
2683 declare
2684 Res : constant Subprogram_List (1 .. N) := Result (1 .. N);
2685 M : Nat := 0;
2686 begin
2687 for J in 1 .. N loop
2688 for K in 1 .. N loop
2689 if Res (K) /= S
2690 and then Res (J) = Overridden_Operation (Res (K))
2691 then
2692 goto Skip;
2693 end if;
2694 end loop;
2696 M := M + 1;
2697 Result (M) := Res (J);
2699 <<Skip>>
2700 end loop;
2702 N := M;
2703 end;
2704 end if;
2706 <<Done>>
2708 return Result (1 .. N);
2709 end Inherited_Subprograms;
2711 ------------------------------
2712 -- Is_Overriding_Subprogram --
2713 ------------------------------
2715 function Is_Overriding_Subprogram (E : Entity_Id) return Boolean is
2716 Inherited : constant Subprogram_List :=
2717 Inherited_Subprograms (E, One_Only => True);
2718 begin
2719 return Inherited'Length > 0;
2720 end Is_Overriding_Subprogram;
2721 end Inheritance_Utilities;
2723 --------------------------------
2724 -- Inheritance_Utilities_Inst --
2725 --------------------------------
2727 package Inheritance_Utilities_Inst is new
2728 Inheritance_Utilities (Find_Dispatching_Type);
2730 ---------------------------
2731 -- Inherited_Subprograms --
2732 ---------------------------
2734 function Inherited_Subprograms
2735 (S : Entity_Id;
2736 No_Interfaces : Boolean := False;
2737 Interfaces_Only : Boolean := False;
2738 Skip_Overridden : Boolean := False;
2739 One_Only : Boolean := False) return Subprogram_List renames
2740 Inheritance_Utilities_Inst.Inherited_Subprograms;
2742 ---------------------------
2743 -- Is_Dynamically_Tagged --
2744 ---------------------------
2746 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
2747 begin
2748 if Nkind (N) = N_Error then
2749 return False;
2751 elsif Present (Find_Controlling_Arg (N)) then
2752 return True;
2754 -- Special cases: entities, and calls that dispatch on result
2756 elsif Is_Entity_Name (N) then
2757 return Is_Class_Wide_Type (Etype (N));
2759 elsif Nkind (N) = N_Function_Call
2760 and then Is_Class_Wide_Type (Etype (N))
2761 then
2762 return True;
2764 -- Otherwise check whether call has controlling argument
2766 else
2767 return False;
2768 end if;
2769 end Is_Dynamically_Tagged;
2771 ---------------------------------
2772 -- Is_Null_Interface_Primitive --
2773 ---------------------------------
2775 function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
2776 begin
2777 return Comes_From_Source (E)
2778 and then Is_Dispatching_Operation (E)
2779 and then Ekind (E) = E_Procedure
2780 and then Null_Present (Parent (E))
2781 and then Is_Interface (Find_Dispatching_Type (E));
2782 end Is_Null_Interface_Primitive;
2784 -----------------------------------
2785 -- Is_Inherited_Public_Operation --
2786 -----------------------------------
2788 function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is
2789 Pack_Decl : Node_Id;
2790 Prim : Entity_Id := Op;
2791 Scop : Entity_Id := Prim;
2793 begin
2794 -- Locate the ultimate non-hidden alias entity
2796 while Present (Alias (Prim)) and then not Is_Hidden (Alias (Prim)) loop
2797 pragma Assert (Alias (Prim) /= Prim);
2798 Prim := Alias (Prim);
2799 Scop := Scope (Prim);
2800 end loop;
2802 if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then
2803 Pack_Decl := Unit_Declaration_Node (Scop);
2805 return
2806 Nkind (Pack_Decl) = N_Package_Declaration
2807 and then List_Containing (Unit_Declaration_Node (Prim)) =
2808 Visible_Declarations (Specification (Pack_Decl));
2810 else
2811 return False;
2812 end if;
2813 end Is_Inherited_Public_Operation;
2815 ------------------------------
2816 -- Is_Overriding_Subprogram --
2817 ------------------------------
2819 function Is_Overriding_Subprogram (E : Entity_Id) return Boolean renames
2820 Inheritance_Utilities_Inst.Is_Overriding_Subprogram;
2822 --------------------------
2823 -- Is_Tag_Indeterminate --
2824 --------------------------
2826 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
2827 Nam : Entity_Id;
2828 Actual : Node_Id;
2829 Orig_Node : constant Node_Id := Original_Node (N);
2831 begin
2832 if Nkind (Orig_Node) = N_Function_Call
2833 and then Is_Entity_Name (Name (Orig_Node))
2834 then
2835 Nam := Entity (Name (Orig_Node));
2837 if not Has_Controlling_Result (Nam) then
2838 return False;
2840 -- The function may have a controlling result, but if the return type
2841 -- is not visibly tagged, then this is not tag-indeterminate.
2843 elsif Is_Access_Type (Etype (Nam))
2844 and then not Is_Tagged_Type (Designated_Type (Etype (Nam)))
2845 then
2846 return False;
2848 -- An explicit dereference means that the call has already been
2849 -- expanded and there is no tag to propagate.
2851 elsif Nkind (N) = N_Explicit_Dereference then
2852 return False;
2854 -- If there are no actuals, the call is tag-indeterminate
2856 elsif No (Parameter_Associations (Orig_Node)) then
2857 return True;
2859 else
2860 Actual := First_Actual (Orig_Node);
2861 while Present (Actual) loop
2862 if Is_Controlling_Actual (Actual)
2863 and then not Is_Tag_Indeterminate (Actual)
2864 then
2865 -- One operand is dispatching
2867 return False;
2868 end if;
2870 Next_Actual (Actual);
2871 end loop;
2873 return True;
2874 end if;
2876 elsif Nkind (Orig_Node) = N_Qualified_Expression then
2877 return Is_Tag_Indeterminate (Expression (Orig_Node));
2879 -- Case of a call to the Input attribute (possibly rewritten), which is
2880 -- always tag-indeterminate except when its prefix is a Class attribute.
2882 elsif Nkind (Orig_Node) = N_Attribute_Reference
2883 and then
2884 Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
2885 and then Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
2886 then
2887 return True;
2889 -- In Ada 2005, a function that returns an anonymous access type can be
2890 -- dispatching, and the dereference of a call to such a function can
2891 -- also be tag-indeterminate if the call itself is.
2893 elsif Nkind (Orig_Node) = N_Explicit_Dereference
2894 and then Ada_Version >= Ada_2005
2895 then
2896 return Is_Tag_Indeterminate (Prefix (Orig_Node));
2898 else
2899 return False;
2900 end if;
2901 end Is_Tag_Indeterminate;
2903 ------------------------------------
2904 -- Override_Dispatching_Operation --
2905 ------------------------------------
2907 procedure Override_Dispatching_Operation
2908 (Tagged_Type : Entity_Id;
2909 Prev_Op : Entity_Id;
2910 New_Op : Entity_Id)
2912 Elmt : Elmt_Id;
2913 Prim : Node_Id;
2915 begin
2916 -- If there is no previous operation to override, the type declaration
2917 -- was malformed, and an error must have been emitted already.
2919 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2920 while Present (Elmt) and then Node (Elmt) /= Prev_Op loop
2921 Next_Elmt (Elmt);
2922 end loop;
2924 if No (Elmt) then
2925 return;
2926 end if;
2928 -- The location of entities that come from source in the list of
2929 -- primitives of the tagged type must follow their order of occurrence
2930 -- in the sources to fulfill the C++ ABI. If the overridden entity is a
2931 -- primitive of an interface that is not implemented by the parents of
2932 -- this tagged type (that is, it is an alias of an interface primitive
2933 -- generated by Derive_Interface_Progenitors), then we must append the
2934 -- new entity at the end of the list of primitives.
2936 if Present (Alias (Prev_Op))
2937 and then Etype (Tagged_Type) /= Tagged_Type
2938 and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
2939 and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
2940 Tagged_Type, Use_Full_View => True)
2941 and then not Implements_Interface
2942 (Etype (Tagged_Type),
2943 Find_Dispatching_Type (Alias (Prev_Op)))
2944 then
2945 Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
2946 Add_Dispatching_Operation (Tagged_Type, New_Op);
2948 -- The new primitive replaces the overridden entity. Required to ensure
2949 -- that overriding primitive is assigned the same dispatch table slot.
2951 else
2952 Replace_Elmt (Elmt, New_Op);
2953 end if;
2955 if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then
2957 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
2958 -- entities of the overridden primitive to reference New_Op, and
2959 -- also propagate the proper value of Is_Abstract_Subprogram. Verify
2960 -- that the new operation is subtype conformant with the interface
2961 -- operations that it implements (for operations inherited from the
2962 -- parent itself, this check is made when building the derived type).
2964 -- Note: This code is executed with internally generated wrappers of
2965 -- functions with controlling result and late overridings.
2967 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2968 while Present (Elmt) loop
2969 Prim := Node (Elmt);
2971 if Prim = New_Op then
2972 null;
2974 -- Note: The check on Is_Subprogram protects the frontend against
2975 -- reading attributes in entities that are not yet fully decorated
2977 elsif Is_Subprogram (Prim)
2978 and then Present (Interface_Alias (Prim))
2979 and then Alias (Prim) = Prev_Op
2980 then
2981 Set_Alias (Prim, New_Op);
2983 -- No further decoration needed yet for internally generated
2984 -- wrappers of controlling functions since (at this stage)
2985 -- they are not yet decorated.
2987 if not Is_Wrapper (New_Op) then
2988 Check_Subtype_Conformant (New_Op, Prim);
2990 Set_Is_Abstract_Subprogram (Prim,
2991 Is_Abstract_Subprogram (New_Op));
2993 -- Ensure that this entity will be expanded to fill the
2994 -- corresponding entry in its dispatch table.
2996 if not Is_Abstract_Subprogram (Prim) then
2997 Set_Has_Delayed_Freeze (Prim);
2998 end if;
2999 end if;
3000 end if;
3002 Next_Elmt (Elmt);
3003 end loop;
3004 end if;
3006 if not Is_Package_Or_Generic_Package (Current_Scope)
3007 or else not In_Private_Part (Current_Scope)
3008 then
3009 -- Not a private primitive
3011 null;
3013 else pragma Assert (Is_Inherited_Operation (Prev_Op));
3015 -- Make the overriding operation into an alias of the implicit one.
3016 -- In this fashion a call from outside ends up calling the new body
3017 -- even if non-dispatching, and a call from inside calls the over-
3018 -- riding operation because it hides the implicit one. To indicate
3019 -- that the body of Prev_Op is never called, set its dispatch table
3020 -- entity to Empty. If the overridden operation has a dispatching
3021 -- result, so does the overriding one.
3023 Set_Alias (Prev_Op, New_Op);
3024 Set_DTC_Entity (Prev_Op, Empty);
3025 Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
3026 Set_Is_Ada_2022_Only (New_Op, Is_Ada_2022_Only (Prev_Op));
3027 end if;
3028 end Override_Dispatching_Operation;
3030 -------------------
3031 -- Propagate_Tag --
3032 -------------------
3034 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
3035 Call_Node : Node_Id;
3036 Arg : Node_Id;
3038 begin
3039 if Nkind (Actual) = N_Function_Call then
3040 Call_Node := Actual;
3042 elsif Nkind (Actual) = N_Identifier
3043 and then Nkind (Original_Node (Actual)) = N_Function_Call
3044 then
3045 -- Call rewritten as object declaration when stack-checking is
3046 -- enabled. Propagate tag to expression in declaration, which is
3047 -- original call.
3049 Call_Node := Expression (Parent (Entity (Actual)));
3051 -- Ada 2005: If this is a dereference of a call to a function with a
3052 -- dispatching access-result, the tag is propagated when the dereference
3053 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
3055 elsif Nkind (Actual) = N_Explicit_Dereference
3056 and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
3057 then
3058 return;
3060 -- When expansion is suppressed, an unexpanded call to 'Input can occur,
3061 -- and in that case we can simply return.
3063 elsif Nkind (Actual) = N_Attribute_Reference then
3064 pragma Assert (Attribute_Name (Actual) = Name_Input);
3066 return;
3068 -- Only other possibilities are parenthesized or qualified expression,
3069 -- or an expander-generated unchecked conversion of a function call to
3070 -- a stream Input attribute.
3072 else
3073 Call_Node := Expression (Actual);
3074 end if;
3076 -- No action needed if the call has been already expanded
3078 if Is_Expanded_Dispatching_Call (Call_Node) then
3079 return;
3080 end if;
3082 -- Do not set the Controlling_Argument if already set. This happens in
3083 -- the special case of _Input (see Exp_Attr, case Input).
3085 if No (Controlling_Argument (Call_Node)) then
3086 Set_Controlling_Argument (Call_Node, Control);
3087 end if;
3089 Arg := First_Actual (Call_Node);
3090 while Present (Arg) loop
3091 if Is_Tag_Indeterminate (Arg) then
3092 Propagate_Tag (Control, Arg);
3093 end if;
3095 Next_Actual (Arg);
3096 end loop;
3098 -- Add class-wide precondition check if the target of this dispatching
3099 -- call has or inherits class-wide preconditions.
3101 Install_Class_Preconditions_Check (Call_Node);
3103 -- Expansion of dispatching calls is suppressed on VM targets, because
3104 -- the VM back-ends directly handle the generation of dispatching calls
3105 -- and would have to undo any expansion to an indirect call.
3107 if Tagged_Type_Expansion then
3108 declare
3109 Call_Typ : Entity_Id := Etype (Call_Node);
3110 Ctrl_Typ : Entity_Id := Etype (Control);
3112 begin
3113 Expand_Dispatching_Call (Call_Node);
3115 if Is_Class_Wide_Type (Call_Typ) then
3116 Call_Typ := Root_Type (Call_Typ);
3117 end if;
3119 if Is_Class_Wide_Type (Ctrl_Typ) then
3120 Ctrl_Typ := Root_Type (Ctrl_Typ);
3121 end if;
3123 -- If the controlling argument is an interface type and the type
3124 -- of Call_Node differs then we must add an implicit conversion to
3125 -- force displacement of the pointer to the object to reference
3126 -- the secondary dispatch table of the interface.
3128 if Is_Interface (Ctrl_Typ)
3129 and then Ctrl_Typ /= Call_Typ
3130 then
3131 -- Cannot use Convert_To because the previous call to
3132 -- Expand_Dispatching_Call leaves decorated the Call_Node
3133 -- with the type of Control.
3135 Rewrite (Call_Node,
3136 Make_Type_Conversion (Sloc (Call_Node),
3137 Subtype_Mark =>
3138 New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
3139 Expression => Relocate_Node (Call_Node)));
3140 Set_Etype (Call_Node, Etype (Control));
3141 Set_Analyzed (Call_Node);
3143 Expand_Interface_Conversion (Call_Node);
3144 end if;
3145 end;
3147 -- Expansion of a dispatching call results in an indirect call, which in
3148 -- turn causes current values to be killed (see Resolve_Call), so on VM
3149 -- targets we do the call here to ensure consistent warnings between VM
3150 -- and non-VM targets.
3152 else
3153 Kill_Current_Values;
3154 end if;
3155 end Propagate_Tag;
3157 end Sem_Disp;