]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/sem_disp.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2010-10-11 Bob Duff <duff@adacore.com>
[thirdparty/gcc.git] / gcc / ada / sem_disp.adb
CommitLineData
d6f39728 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- S E M _ D I S P --
6-- --
7-- B o d y --
8-- --
503f7fd3 9-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
d6f39728 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- --
80df182a 13-- ware Foundation; either version 3, or (at your option) any later ver- --
d6f39728 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 --
80df182a 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. --
d6f39728 20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
e78e8c8e 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
d6f39728 23-- --
24------------------------------------------------------------------------------
25
26with Atree; use Atree;
27with Debug; use Debug;
28with Elists; use Elists;
29with Einfo; use Einfo;
30with Exp_Disp; use Exp_Disp;
49260fa5 31with Exp_Util; use Exp_Util;
f15731c4 32with Exp_Ch7; use Exp_Ch7;
33with Exp_Tss; use Exp_Tss;
d6f39728 34with Errout; use Errout;
925d0320 35with Lib.Xref; use Lib.Xref;
6340e5cc 36with Namet; use Namet;
d6f39728 37with Nlists; use Nlists;
7189d17f 38with Nmake; use Nmake;
f15731c4 39with Opt; use Opt;
d6f39728 40with Output; use Output;
9c48514a 41with Restrict; use Restrict;
42with Rident; use Rident;
f15731c4 43with Sem; use Sem;
d60c9ff7 44with Sem_Aux; use Sem_Aux;
880342e5 45with Sem_Ch3; use Sem_Ch3;
d6f39728 46with Sem_Ch6; use Sem_Ch6;
47with Sem_Eval; use Sem_Eval;
7189d17f 48with Sem_Type; use Sem_Type;
d6f39728 49with Sem_Util; use Sem_Util;
f15731c4 50with Snames; use Snames;
d6f39728 51with Sinfo; use Sinfo;
7189d17f 52with Tbuild; use Tbuild;
d6f39728 53with Uintp; use Uintp;
54
55package body Sem_Disp is
56
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
60
d6f39728 61 procedure Add_Dispatching_Operation
62 (Tagged_Type : Entity_Id;
63 New_Op : Entity_Id);
64 -- Add New_Op in the list of primitive operations of Tagged_Type
65
66 function Check_Controlling_Type
67 (T : Entity_Id;
5c99c290 68 Subp : Entity_Id) return Entity_Id;
7189d17f 69 -- T is the tagged type of a formal parameter or the result of Subp.
70 -- If the subprogram has a controlling parameter or result that matches
71 -- the type, then returns the tagged type of that parameter or result
72 -- (returning the designated tagged type in the case of an access
73 -- parameter); otherwise returns empty.
d6f39728 74
5c99c290 75 -------------------------------
76 -- Add_Dispatching_Operation --
77 -------------------------------
d6f39728 78
79 procedure Add_Dispatching_Operation
80 (Tagged_Type : Entity_Id;
81 New_Op : Entity_Id)
82 is
83 List : constant Elist_Id := Primitive_Operations (Tagged_Type);
fd89b7ee 84
d6f39728 85 begin
4a8d5a0a 86 -- The dispatching operation may already be on the list, if it is the
87 -- wrapper for an inherited function of a null extension (see Exp_Ch3
fd89b7ee 88 -- for the construction of function wrappers). The list of primitive
89 -- operations must not contain duplicates.
90
91 Append_Unique_Elmt (New_Op, List);
d6f39728 92 end Add_Dispatching_Operation;
93
4d2fc001 94 ---------------------------
95 -- Covers_Some_Interface --
96 ---------------------------
97
98 function Covers_Some_Interface (Prim : Entity_Id) return Boolean is
99 Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim);
100 Elmt : Elmt_Id;
101 E : Entity_Id;
102
103 begin
104 pragma Assert (Is_Dispatching_Operation (Prim));
105
106 -- Although this is a dispatching primitive we must check if its
107 -- dispatching type is available because it may be the primitive
108 -- of a private type not defined as tagged in its partial view.
109
110 if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then
111
112 -- If the tagged type is frozen then the internal entities associated
113 -- with interfaces are available in the list of primitives of the
114 -- tagged type and can be used to speed up this search.
115
116 if Is_Frozen (Tagged_Type) then
117 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
118 while Present (Elmt) loop
119 E := Node (Elmt);
120
121 if Present (Interface_Alias (E))
122 and then Alias (E) = Prim
123 then
124 return True;
125 end if;
126
127 Next_Elmt (Elmt);
128 end loop;
129
130 -- Otherwise we must collect all the interface primitives and check
131 -- if the Prim will override some interface primitive.
132
133 else
134 declare
135 Ifaces_List : Elist_Id;
136 Iface_Elmt : Elmt_Id;
137 Iface : Entity_Id;
138 Iface_Prim : Entity_Id;
139
140 begin
141 Collect_Interfaces (Tagged_Type, Ifaces_List);
142 Iface_Elmt := First_Elmt (Ifaces_List);
143 while Present (Iface_Elmt) loop
144 Iface := Node (Iface_Elmt);
145
146 Elmt := First_Elmt (Primitive_Operations (Iface));
147 while Present (Elmt) loop
148 Iface_Prim := Node (Elmt);
149
150 if Chars (E) = Chars (Prim)
151 and then Is_Interface_Conformant
152 (Tagged_Type, Iface_Prim, Prim)
153 then
154 return True;
155 end if;
156
157 Next_Elmt (Elmt);
158 end loop;
159
160 Next_Elmt (Iface_Elmt);
161 end loop;
162 end;
163 end if;
164 end if;
165
166 return False;
167 end Covers_Some_Interface;
168
d6f39728 169 -------------------------------
170 -- Check_Controlling_Formals --
171 -------------------------------
172
173 procedure Check_Controlling_Formals
174 (Typ : Entity_Id;
175 Subp : Entity_Id)
176 is
177 Formal : Entity_Id;
178 Ctrl_Type : Entity_Id;
d6f39728 179
180 begin
181 Formal := First_Formal (Subp);
d6f39728 182 while Present (Formal) loop
183 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
184
185 if Present (Ctrl_Type) then
6340e5cc 186
dffd0a90 187 -- When controlling type is concurrent and declared within a
188 -- generic or inside an instance use corresponding record type.
6340e5cc 189
190 if Is_Concurrent_Type (Ctrl_Type)
191 and then Present (Corresponding_Record_Type (Ctrl_Type))
192 then
193 Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
194 end if;
195
d6f39728 196 if Ctrl_Type = Typ then
197 Set_Is_Controlling_Formal (Formal);
198
dffd0a90 199 -- Ada 2005 (AI-231): Anonymous access types that are used in
779facca 200 -- controlling parameters exclude null because it is necessary
201 -- to read the tag to dispatch, and null has no tag.
7c7c3694 202
203 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
204 Set_Can_Never_Be_Null (Etype (Formal));
205 Set_Is_Known_Non_Null (Etype (Formal));
206 end if;
207
d6f39728 208 -- Check that the parameter's nominal subtype statically
209 -- matches the first subtype.
210
211 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
212 if not Subtypes_Statically_Match
213 (Typ, Designated_Type (Etype (Formal)))
214 then
215 Error_Msg_N
216 ("parameter subtype does not match controlling type",
217 Formal);
218 end if;
219
220 elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
221 Error_Msg_N
222 ("parameter subtype does not match controlling type",
223 Formal);
224 end if;
225
226 if Present (Default_Value (Formal)) then
fd89b7ee 227
228 -- In Ada 2005, access parameters can have defaults
229
230 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
de54c5ab 231 and then Ada_Version < Ada_2005
fd89b7ee 232 then
d6f39728 233 Error_Msg_N
234 ("default not allowed for controlling access parameter",
235 Default_Value (Formal));
236
237 elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
238 Error_Msg_N
239 ("default expression must be a tag indeterminate" &
240 " function call", Default_Value (Formal));
241 end if;
242 end if;
243
244 elsif Comes_From_Source (Subp) then
245 Error_Msg_N
246 ("operation can be dispatching in only one type", Subp);
247 end if;
d6f39728 248 end if;
249
250 Next_Formal (Formal);
251 end loop;
252
4ad935a2 253 if Ekind_In (Subp, E_Function, E_Generic_Function) then
d6f39728 254 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
255
256 if Present (Ctrl_Type) then
257 if Ctrl_Type = Typ then
258 Set_Has_Controlling_Result (Subp);
259
779facca 260 -- Check that result subtype statically matches first subtype
4a8d5a0a 261 -- (Ada 2005): Subp may have a controlling access result.
d6f39728 262
6340e5cc 263 if Subtypes_Statically_Match (Typ, Etype (Subp))
264 or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
265 and then
266 Subtypes_Statically_Match
267 (Typ, Designated_Type (Etype (Subp))))
268 then
269 null;
270
271 else
d6f39728 272 Error_Msg_N
273 ("result subtype does not match controlling type", Subp);
274 end if;
275
276 elsif Comes_From_Source (Subp) then
277 Error_Msg_N
278 ("operation can be dispatching in only one type", Subp);
279 end if;
d6f39728 280 end if;
281 end if;
282 end Check_Controlling_Formals;
283
284 ----------------------------
285 -- Check_Controlling_Type --
286 ----------------------------
287
288 function Check_Controlling_Type
289 (T : Entity_Id;
5c99c290 290 Subp : Entity_Id) return Entity_Id
d6f39728 291 is
292 Tagged_Type : Entity_Id := Empty;
293
294 begin
295 if Is_Tagged_Type (T) then
296 if Is_First_Subtype (T) then
297 Tagged_Type := T;
298 else
299 Tagged_Type := Base_Type (T);
300 end if;
301
302 elsif Ekind (T) = E_Anonymous_Access_Type
303 and then Is_Tagged_Type (Designated_Type (T))
d6f39728 304 then
aad6babd 305 if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
306 if Is_First_Subtype (Designated_Type (T)) then
307 Tagged_Type := Designated_Type (T);
308 else
309 Tagged_Type := Base_Type (Designated_Type (T));
310 end if;
311
4a8d5a0a 312 -- Ada 2005: an incomplete type can be tagged. An operation with an
313 -- access parameter of the type is dispatching.
343d35dc 314
315 elsif Scope (Designated_Type (T)) = Current_Scope then
316 Tagged_Type := Designated_Type (T);
317
aad6babd 318 -- Ada 2005 (AI-50217)
319
320 elsif From_With_Type (Designated_Type (T))
321 and then Present (Non_Limited_View (Designated_Type (T)))
322 then
323 if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
324 Tagged_Type := Non_Limited_View (Designated_Type (T));
325 else
326 Tagged_Type := Base_Type (Non_Limited_View
327 (Designated_Type (T)));
328 end if;
d6f39728 329 end if;
330 end if;
331
4a8d5a0a 332 if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then
d6f39728 333 return Empty;
334
4a8d5a0a 335 -- The dispatching type and the primitive operation must be defined in
336 -- the same scope, except in the case of internal operations and formal
337 -- abstract subprograms.
d6f39728 338
7189d17f 339 elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
340 and then (not Is_Generic_Type (Tagged_Type)
341 or else not Comes_From_Source (Subp)))
342 or else
343d35dc 343 (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
7189d17f 344 or else
345 (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
346 and then
347 Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
348 and then
343d35dc 349 Is_Abstract_Subprogram (Subp))
d6f39728 350 then
351 return Tagged_Type;
352
353 else
354 return Empty;
355 end if;
356 end Check_Controlling_Type;
357
358 ----------------------------
359 -- Check_Dispatching_Call --
360 ----------------------------
361
362 procedure Check_Dispatching_Call (N : Node_Id) is
6340e5cc 363 Loc : constant Source_Ptr := Sloc (N);
7189d17f 364 Actual : Node_Id;
365 Formal : Entity_Id;
366 Control : Node_Id := Empty;
367 Func : Entity_Id;
368 Subp_Entity : Entity_Id;
7189d17f 369 Indeterm_Ancestor_Call : Boolean := False;
370 Indeterm_Ctrl_Type : Entity_Id;
d6f39728 371
ad4eda7a 372 Static_Tag : Node_Id := Empty;
373 -- If a controlling formal has a statically tagged actual, the tag of
4a8d5a0a 374 -- this actual is to be used for any tag-indeterminate actual.
ad4eda7a 375
6d081ca6 376 procedure Check_Direct_Call;
377 -- In the case when the controlling actual is a class-wide type whose
378 -- root type's completion is a task or protected type, the call is in
379 -- fact direct. This routine detects the above case and modifies the
380 -- call accordingly.
381
d6f39728 382 procedure Check_Dispatching_Context;
383 -- If the call is tag-indeterminate and the entity being called is
384 -- abstract, verify that the context is a call that will eventually
385 -- provide a tag for dispatching, or has provided one already.
386
6d081ca6 387 -----------------------
388 -- Check_Direct_Call --
389 -----------------------
390
391 procedure Check_Direct_Call is
392 Typ : Entity_Id := Etype (Control);
393
c85cfca7 394 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
395 -- Determine whether an entity denotes a user-defined equality
396
397 ------------------------------
398 -- Is_User_Defined_Equality --
399 ------------------------------
400
401 function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
402 begin
403 return
404 Ekind (Id) = E_Function
405 and then Chars (Id) = Name_Op_Eq
406 and then Comes_From_Source (Id)
407
408 -- Internally generated equalities have a full type declaration
409 -- as their parent.
410
411 and then Nkind (Parent (Id)) = N_Function_Specification;
412 end Is_User_Defined_Equality;
413
414 -- Start of processing for Check_Direct_Call
415
6d081ca6 416 begin
c85cfca7 417 -- Predefined primitives do not receive wrappers since they are built
418 -- from scratch for the corresponding record of synchronized types.
419 -- Equality is in general predefined, but is excluded from the check
420 -- when it is user-defined.
421
422 if Is_Predefined_Dispatching_Operation (Subp_Entity)
423 and then not Is_User_Defined_Equality (Subp_Entity)
424 then
425 return;
426 end if;
427
6d081ca6 428 if Is_Class_Wide_Type (Typ) then
429 Typ := Root_Type (Typ);
430 end if;
431
c85cfca7 432 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
433 Typ := Full_View (Typ);
434 end if;
6d081ca6 435
c85cfca7 436 if Is_Concurrent_Type (Typ)
437 and then
438 Present (Corresponding_Record_Type (Typ))
6d081ca6 439 then
c85cfca7 440 Typ := Corresponding_Record_Type (Typ);
6d081ca6 441
442 -- The concurrent record's list of primitives should contain a
443 -- wrapper for the entity of the call, retrieve it.
444
445 declare
446 Prim : Entity_Id;
447 Prim_Elmt : Elmt_Id;
448 Wrapper_Found : Boolean := False;
449
450 begin
451 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
452 while Present (Prim_Elmt) loop
453 Prim := Node (Prim_Elmt);
454
455 if Is_Primitive_Wrapper (Prim)
456 and then Wrapped_Entity (Prim) = Subp_Entity
457 then
458 Wrapper_Found := True;
459 exit;
460 end if;
461
462 Next_Elmt (Prim_Elmt);
463 end loop;
464
465 -- A primitive declared between two views should have a
466 -- corresponding wrapper.
467
468 pragma Assert (Wrapper_Found);
469
470 -- Modify the call by setting the proper entity
471
472 Set_Entity (Name (N), Prim);
473 end;
474 end if;
475 end Check_Direct_Call;
476
d6f39728 477 -------------------------------
478 -- Check_Dispatching_Context --
479 -------------------------------
480
481 procedure Check_Dispatching_Context is
7189d17f 482 Subp : constant Entity_Id := Entity (Name (N));
d6f39728 483 Par : Node_Id;
484
485 begin
343d35dc 486 if Is_Abstract_Subprogram (Subp)
d6f39728 487 and then No (Controlling_Argument (N))
488 then
7189d17f 489 if Present (Alias (Subp))
343d35dc 490 and then not Is_Abstract_Subprogram (Alias (Subp))
7189d17f 491 and then No (DTC_Entity (Subp))
f15731c4 492 then
4a8d5a0a 493 -- Private overriding of inherited abstract operation, call is
494 -- legal.
d6f39728 495
7189d17f 496 Set_Entity (Name (N), Alias (Subp));
f15731c4 497 return;
d6f39728 498
f15731c4 499 else
500 Par := Parent (N);
f15731c4 501 while Present (Par) loop
dffd0a90 502 if Nkind_In (Par, N_Function_Call,
503 N_Procedure_Call_Statement,
504 N_Assignment_Statement,
505 N_Op_Eq,
506 N_Op_Ne)
7189d17f 507 and then Is_Tagged_Type (Etype (Subp))
f15731c4 508 then
509 return;
510
511 elsif Nkind (Par) = N_Qualified_Expression
512 or else Nkind (Par) = N_Unchecked_Type_Conversion
513 then
514 Par := Parent (Par);
515
516 else
7189d17f 517 if Ekind (Subp) = E_Function then
518 Error_Msg_N
519 ("call to abstract function must be dispatching", N);
520
521 -- This error can occur for a procedure in the case of a
522 -- call to an abstract formal procedure with a statically
523 -- tagged operand.
524
525 else
526 Error_Msg_N
527 ("call to abstract procedure must be dispatching",
528 N);
529 end if;
530
f15731c4 531 return;
532 end if;
533 end loop;
534 end if;
d6f39728 535 end if;
536 end Check_Dispatching_Context;
537
538 -- Start of processing for Check_Dispatching_Call
539
540 begin
541 -- Find a controlling argument, if any
542
543 if Present (Parameter_Associations (N)) then
7189d17f 544 Subp_Entity := Entity (Name (N));
7189d17f 545
dffd0a90 546 Actual := First_Actual (N);
547 Formal := First_Formal (Subp_Entity);
d6f39728 548 while Present (Actual) loop
549 Control := Find_Controlling_Arg (Actual);
550 exit when Present (Control);
7189d17f 551
552 -- Check for the case where the actual is a tag-indeterminate call
553 -- whose result type is different than the tagged type associated
554 -- with the containing call, but is an ancestor of the type.
555
556 if Is_Controlling_Formal (Formal)
557 and then Is_Tag_Indeterminate (Actual)
558 and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
559 and then Is_Ancestor (Etype (Actual), Etype (Formal))
560 then
561 Indeterm_Ancestor_Call := True;
562 Indeterm_Ctrl_Type := Etype (Formal);
ad4eda7a 563
564 -- If the formal is controlling but the actual is not, the type
565 -- of the actual is statically known, and may be used as the
4a8d5a0a 566 -- controlling tag for some other tag-indeterminate actual.
ad4eda7a 567
568 elsif Is_Controlling_Formal (Formal)
569 and then Is_Entity_Name (Actual)
570 and then Is_Tagged_Type (Etype (Actual))
571 then
572 Static_Tag := Actual;
7189d17f 573 end if;
574
d6f39728 575 Next_Actual (Actual);
7189d17f 576 Next_Formal (Formal);
d6f39728 577 end loop;
578
4a8d5a0a 579 -- If the call doesn't have a controlling actual but does have an
580 -- indeterminate actual that requires dispatching treatment, then an
581 -- object is needed that will serve as the controlling argument for a
582 -- dispatching call on the indeterminate actual. This can only occur
583 -- in the unusual situation of a default actual given by a
584 -- tag-indeterminate call and where the type of the call is an
585 -- ancestor of the type associated with a containing call to an
586 -- inherited operation (see AI-239).
587
588 -- Rather than create an object of the tagged type, which would be
589 -- problematic for various reasons (default initialization,
590 -- discriminants), the tag of the containing call's associated tagged
591 -- type is directly used to control the dispatching.
7189d17f 592
9c48514a 593 if No (Control)
7189d17f 594 and then Indeterm_Ancestor_Call
ad4eda7a 595 and then No (Static_Tag)
7189d17f 596 then
597 Control :=
598 Make_Attribute_Reference (Loc,
599 Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
600 Attribute_Name => Name_Tag);
ad4eda7a 601
7189d17f 602 Analyze (Control);
603 end if;
604
d6f39728 605 if Present (Control) then
606
607 -- Verify that no controlling arguments are statically tagged
608
609 if Debug_Flag_E then
610 Write_Str ("Found Dispatching call");
611 Write_Int (Int (N));
612 Write_Eol;
613 end if;
614
615 Actual := First_Actual (N);
d6f39728 616 while Present (Actual) loop
617 if Actual /= Control then
618
619 if not Is_Controlling_Actual (Actual) then
7189d17f 620 null; -- Can be anything
d6f39728 621
9dfe12ae 622 elsif Is_Dynamically_Tagged (Actual) then
7189d17f 623 null; -- Valid parameter
d6f39728 624
625 elsif Is_Tag_Indeterminate (Actual) then
626
4a8d5a0a 627 -- The tag is inherited from the enclosing call (the node
628 -- we are currently analyzing). Explicitly expand the
629 -- actual, since the previous call to Expand (from
630 -- Resolve_Call) had no way of knowing about the required
631 -- dispatching.
d6f39728 632
633 Propagate_Tag (Control, Actual);
634
635 else
636 Error_Msg_N
637 ("controlling argument is not dynamically tagged",
638 Actual);
639 return;
640 end if;
641 end if;
642
643 Next_Actual (Actual);
644 end loop;
645
646 -- Mark call as a dispatching call
647
648 Set_Controlling_Argument (N, Control);
343d35dc 649 Check_Restriction (No_Dispatching_Calls, N);
d6f39728 650
6d081ca6 651 -- The dispatching call may need to be converted into a direct
652 -- call in certain cases.
653
654 Check_Direct_Call;
655
fd89b7ee 656 -- If there is a statically tagged actual and a tag-indeterminate
657 -- call to a function of the ancestor (such as that provided by a
658 -- default), then treat this as a dispatching call and propagate
659 -- the tag to the tag-indeterminate call(s).
ad4eda7a 660
fd89b7ee 661 elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
ad4eda7a 662 Control :=
663 Make_Attribute_Reference (Loc,
664 Prefix =>
665 New_Occurrence_Of (Etype (Static_Tag), Loc),
666 Attribute_Name => Name_Tag);
667
668 Analyze (Control);
669
670 Actual := First_Actual (N);
671 Formal := First_Formal (Subp_Entity);
672 while Present (Actual) loop
673 if Is_Tag_Indeterminate (Actual)
674 and then Is_Controlling_Formal (Formal)
675 then
676 Propagate_Tag (Control, Actual);
677 end if;
678
679 Next_Actual (Actual);
680 Next_Formal (Formal);
681 end loop;
682
683 Check_Dispatching_Context;
684
d6f39728 685 else
7189d17f 686 -- The call is not dispatching, so check that there aren't any
687 -- tag-indeterminate abstract calls left.
d6f39728 688
689 Actual := First_Actual (N);
d6f39728 690 while Present (Actual) loop
691 if Is_Tag_Indeterminate (Actual) then
692
693 -- Function call case
694
695 if Nkind (Original_Node (Actual)) = N_Function_Call then
696 Func := Entity (Name (Original_Node (Actual)));
697
9c48514a 698 -- If the actual is an attribute then it can't be abstract
699 -- (the only current case of a tag-indeterminate attribute
700 -- is the stream Input attribute).
701
702 elsif
703 Nkind (Original_Node (Actual)) = N_Attribute_Reference
704 then
705 Func := Empty;
706
d6f39728 707 -- Only other possibility is a qualified expression whose
6340e5cc 708 -- constituent expression is itself a call.
d6f39728 709
710 else
711 Func :=
712 Entity (Name
713 (Original_Node
714 (Expression (Original_Node (Actual)))));
715 end if;
716
343d35dc 717 if Present (Func) and then Is_Abstract_Subprogram (Func) then
503f7fd3 718 Error_Msg_N
719 ("call to abstract function must be dispatching", N);
d6f39728 720 end if;
721 end if;
722
723 Next_Actual (Actual);
724 end loop;
725
726 Check_Dispatching_Context;
727 end if;
728
729 else
730 -- If dispatching on result, the enclosing call, if any, will
731 -- determine the controlling argument. Otherwise this is the
732 -- primitive operation of the root type.
733
734 Check_Dispatching_Context;
735 end if;
736 end Check_Dispatching_Call;
737
738 ---------------------------------
739 -- Check_Dispatching_Operation --
740 ---------------------------------
741
742 procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
f15731c4 743 Tagged_Type : Entity_Id;
d6f39728 744 Has_Dispatching_Parent : Boolean := False;
745 Body_Is_Last_Primitive : Boolean := False;
746
747 begin
4ad935a2 748 if not Ekind_In (Subp, E_Procedure, E_Function) then
d6f39728 749 return;
750 end if;
751
752 Set_Is_Dispatching_Operation (Subp, False);
f15731c4 753 Tagged_Type := Find_Dispatching_Type (Subp);
d6f39728 754
64988bb0 755 -- Ada 2005 (AI-345): Use the corresponding record (if available).
756 -- Required because primitives of concurrent types are be attached
757 -- to the corresponding record (not to the concurrent type).
aad6babd 758
de54c5ab 759 if Ada_Version >= Ada_2005
aad6babd 760 and then Present (Tagged_Type)
761 and then Is_Concurrent_Type (Tagged_Type)
64988bb0 762 and then Present (Corresponding_Record_Type (Tagged_Type))
aad6babd 763 then
764 Tagged_Type := Corresponding_Record_Type (Tagged_Type);
765 end if;
766
a652dd51 767 -- (AI-345): The task body procedure is not a primitive of the tagged
768 -- type
769
770 if Present (Tagged_Type)
771 and then Is_Concurrent_Record_Type (Tagged_Type)
772 and then Present (Corresponding_Concurrent_Type (Tagged_Type))
773 and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type))
774 and then Subp = Get_Task_Body_Procedure
775 (Corresponding_Concurrent_Type (Tagged_Type))
776 then
777 return;
778 end if;
779
d6f39728 780 -- If Subp is derived from a dispatching operation then it should
781 -- always be treated as dispatching. In this case various checks
782 -- below will be bypassed. Makes sure that late declarations for
783 -- inherited private subprograms are treated as dispatching, even
784 -- if the associated tagged type is already frozen.
785
9dfe12ae 786 Has_Dispatching_Parent :=
787 Present (Alias (Subp))
788 and then Is_Dispatching_Operation (Alias (Subp));
d6f39728 789
f15731c4 790 if No (Tagged_Type) then
779facca 791
792 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
793 -- with an abstract interface type unless the interface acts as a
794 -- parent type in a derivation. If the interface type is a formal
795 -- type then the operation is not primitive and therefore legal.
796
797 declare
798 E : Entity_Id;
799 Typ : Entity_Id;
800
801 begin
802 E := First_Entity (Subp);
803 while Present (E) loop
695680ce 804
7f2cf564 805 -- For an access parameter, check designated type
695680ce 806
807 if Ekind (Etype (E)) = E_Anonymous_Access_Type then
779facca 808 Typ := Designated_Type (Etype (E));
809 else
810 Typ := Etype (E);
811 end if;
812
cdfe77a0 813 if Comes_From_Source (Subp)
779facca 814 and then Is_Interface (Typ)
cdfe77a0 815 and then not Is_Class_Wide_Type (Typ)
779facca 816 and then not Is_Derived_Type (Typ)
817 and then not Is_Generic_Type (Typ)
6340e5cc 818 and then not In_Instance
779facca 819 then
820 Error_Msg_N ("?declaration of& is too late!", Subp);
503f7fd3 821 Error_Msg_NE -- CODEFIX??
779facca 822 ("\spec should appear immediately after declaration of &!",
823 Subp, Typ);
824 exit;
825 end if;
826
827 Next_Entity (E);
828 end loop;
829
830 -- In case of functions check also the result type
831
832 if Ekind (Subp) = E_Function then
833 if Is_Access_Type (Etype (Subp)) then
834 Typ := Designated_Type (Etype (Subp));
835 else
836 Typ := Etype (Subp);
837 end if;
838
839 if not Is_Class_Wide_Type (Typ)
840 and then Is_Interface (Typ)
841 and then not Is_Derived_Type (Typ)
842 then
843 Error_Msg_N ("?declaration of& is too late!", Subp);
844 Error_Msg_NE
845 ("\spec should appear immediately after declaration of &!",
846 Subp, Typ);
847 end if;
848 end if;
849 end;
850
d6f39728 851 return;
852
853 -- The subprograms build internally after the freezing point (such as
880342e5 854 -- init procs, interface thunks, type support subprograms, and Offset
855 -- to top functions for accessing interface components in variable
856 -- size tagged types) are not primitives.
d6f39728 857
f15731c4 858 elsif Is_Frozen (Tagged_Type)
d6f39728 859 and then not Comes_From_Source (Subp)
860 and then not Has_Dispatching_Parent
861 then
b381b314 862 -- Complete decoration of internally built subprograms that override
880342e5 863 -- a dispatching primitive. These entities correspond with the
864 -- following cases:
865
866 -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander
867 -- to override functions of nonabstract null extensions. These
868 -- primitives were added to the list of primitives of the tagged
869 -- type by Make_Controlling_Function_Wrappers. However, attribute
870 -- Is_Dispatching_Operation must be set to true.
871
4d2fc001 872 -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
873 -- primitives.
874
875 -- 3. Subprograms associated with stream attributes (built by
880342e5 876 -- New_Stream_Subprogram)
877
878 if Present (Old_Subp)
879 and then Is_Overriding_Operation (Subp)
880 and then Is_Dispatching_Operation (Old_Subp)
881 then
882 pragma Assert
883 ((Ekind (Subp) = E_Function
1fc096b1 884 and then Is_Dispatching_Operation (Old_Subp)
885 and then Is_Null_Extension (Base_Type (Etype (Subp))))
4d2fc001 886 or else
887 (Ekind (Subp) = E_Procedure
888 and then Is_Dispatching_Operation (Old_Subp)
889 and then Present (Alias (Old_Subp))
890 and then Is_Null_Interface_Primitive
891 (Ultimate_Alias (Old_Subp)))
880342e5 892 or else Get_TSS_Name (Subp) = TSS_Stream_Read
893 or else Get_TSS_Name (Subp) = TSS_Stream_Write);
894
4d2fc001 895 Check_Controlling_Formals (Tagged_Type, Subp);
896 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
880342e5 897 Set_Is_Dispatching_Operation (Subp);
898 end if;
899
d6f39728 900 return;
901
902 -- The operation may be a child unit, whose scope is the defining
903 -- package, but which is not a primitive operation of the type.
904
905 elsif Is_Child_Unit (Subp) then
906 return;
907
908 -- If the subprogram is not defined in a package spec, the only case
909 -- where it can be a dispatching op is when it overrides an operation
910 -- before the freezing point of the type.
911
b635a7dd 912 elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
913 or else In_Package_Body (Scope (Subp)))
d6f39728 914 and then not Has_Dispatching_Parent
915 then
916 if not Comes_From_Source (Subp)
f15731c4 917 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
d6f39728 918 then
919 null;
920
921 -- If the type is already frozen, the overriding is not allowed
1fc096b1 922 -- except when Old_Subp is not a dispatching operation (which can
923 -- occur when Old_Subp was inherited by an untagged type). However,
dffd0a90 924 -- a body with no previous spec freezes the type *after* its
1fc096b1 925 -- declaration, and therefore is a legal overriding (unless the type
926 -- has already been frozen). Only the first such body is legal.
d6f39728 927
928 elsif Present (Old_Subp)
929 and then Is_Dispatching_Operation (Old_Subp)
930 then
aad6babd 931 if Comes_From_Source (Subp)
932 and then
933 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
934 or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
d6f39728 935 then
936 declare
937 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
dffd0a90 938 Decl_Item : Node_Id;
d6f39728 939
940 begin
941 -- ??? The checks here for whether the type has been
942 -- frozen prior to the new body are not complete. It's
943 -- not simple to check frozenness at this point since
944 -- the body has already caused the type to be prematurely
945 -- frozen in Analyze_Declarations, but we're forced to
946 -- recheck this here because of the odd rule interpretation
947 -- that allows the overriding if the type wasn't frozen
948 -- prior to the body. The freezing action should probably
949 -- be delayed until after the spec is seen, but that's
950 -- a tricky change to the delicate freezing code.
951
ab31e6f8 952 -- Look at each declaration following the type up until the
953 -- new subprogram body. If any of the declarations is a body
954 -- then the type has been frozen already so the overriding
955 -- primitive is illegal.
d6f39728 956
dffd0a90 957 Decl_Item := Next (Parent (Tagged_Type));
d6f39728 958 while Present (Decl_Item)
959 and then (Decl_Item /= Subp_Body)
960 loop
961 if Comes_From_Source (Decl_Item)
962 and then (Nkind (Decl_Item) in N_Proper_Body
963 or else Nkind (Decl_Item) in N_Body_Stub)
964 then
965 Error_Msg_N ("overriding of& is too late!", Subp);
966 Error_Msg_N
967 ("\spec should appear immediately after the type!",
968 Subp);
969 exit;
970 end if;
971
972 Next (Decl_Item);
973 end loop;
974
975 -- If the subprogram doesn't follow in the list of
ab31e6f8 976 -- declarations including the type then the type has
977 -- definitely been frozen already and the body is illegal.
d6f39728 978
9c48514a 979 if No (Decl_Item) then
d6f39728 980 Error_Msg_N ("overriding of& is too late!", Subp);
981 Error_Msg_N
982 ("\spec should appear immediately after the type!",
983 Subp);
984
985 elsif Is_Frozen (Subp) then
986
9dfe12ae 987 -- The subprogram body declares a primitive operation.
d6f39728 988 -- if the subprogram is already frozen, we must update
989 -- its dispatching information explicitly here. The
990 -- information is taken from the overridden subprogram.
925d0320 991 -- We must also generate a cross-reference entry because
992 -- references to other primitives were already created
993 -- when type was frozen.
d6f39728 994
995 Body_Is_Last_Primitive := True;
996
997 if Present (DTC_Entity (Old_Subp)) then
998 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
999 Set_DT_Position (Subp, DT_Position (Old_Subp));
9c48514a 1000
1001 if not Restriction_Active (No_Dispatching_Calls) then
e7e688dd 1002 if Building_Static_DT (Tagged_Type) then
1003
1004 -- If the static dispatch table has not been
1005 -- built then there is nothing else to do now;
1006 -- otherwise we notify that we cannot build the
1007 -- static dispatch table.
1008
1009 if Has_Dispatch_Table (Tagged_Type) then
1010 Error_Msg_N
1011 ("overriding of& is too late for building" &
1012 " static dispatch tables!", Subp);
1013 Error_Msg_N
1014 ("\spec should appear immediately after" &
1015 " the type!", Subp);
1016 end if;
1017
1018 else
49260fa5 1019 Insert_Actions_After (Subp_Body,
1020 Register_Primitive (Sloc (Subp_Body),
1021 Prim => Subp));
e7e688dd 1022 end if;
925d0320 1023
ff508364 1024 -- Indicate that this is an overriding operation,
1025 -- and replace the overriden entry in the list of
1026 -- primitive operations, which is used for xref
1027 -- generation subsequently.
1028
1029 Generate_Reference (Tagged_Type, Subp, 'P', False);
1030 Override_Dispatching_Operation
1031 (Tagged_Type, Old_Subp, Subp);
9c48514a 1032 end if;
d6f39728 1033 end if;
1034 end if;
1035 end;
1036
1037 else
1038 Error_Msg_N ("overriding of& is too late!", Subp);
1039 Error_Msg_N
1040 ("\subprogram spec should appear immediately after the type!",
1041 Subp);
1042 end if;
1043
6340e5cc 1044 -- If the type is not frozen yet and we are not in the overriding
d6f39728 1045 -- case it looks suspiciously like an attempt to define a primitive
ab31e6f8 1046 -- operation, which requires the declaration to be in a package spec
1047 -- (3.2.3(6)).
d6f39728 1048
f15731c4 1049 elsif not Is_Frozen (Tagged_Type) then
d6f39728 1050 Error_Msg_N
1051 ("?not dispatching (must be defined in a package spec)", Subp);
1052 return;
1053
1054 -- When the type is frozen, it is legitimate to define a new
1055 -- non-primitive operation.
1056
1057 else
1058 return;
1059 end if;
1060
1061 -- Now, we are sure that the scope is a package spec. If the subprogram
6340e5cc 1062 -- is declared after the freezing point of the type that's an error
d6f39728 1063
f15731c4 1064 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
d6f39728 1065 Error_Msg_N ("this primitive operation is declared too late", Subp);
1066 Error_Msg_NE
1067 ("?no primitive operations for& after this line",
f15731c4 1068 Freeze_Node (Tagged_Type),
1069 Tagged_Type);
d6f39728 1070 return;
1071 end if;
1072
f15731c4 1073 Check_Controlling_Formals (Tagged_Type, Subp);
d6f39728 1074
1075 -- Now it should be a correct primitive operation, put it in the list
1076
1077 if Present (Old_Subp) then
a652dd51 1078
4a8d5a0a 1079 -- If the type has interfaces we complete this check after we set
1080 -- attribute Is_Dispatching_Operation.
a652dd51 1081
d6f39728 1082 Check_Subtype_Conformant (Subp, Old_Subp);
e7e688dd 1083
e161d1a3 1084 if (Chars (Subp) = Name_Initialize
1085 or else Chars (Subp) = Name_Adjust
1086 or else Chars (Subp) = Name_Finalize)
1087 and then Is_Controlled (Tagged_Type)
1088 and then not Is_Visibly_Controlled (Tagged_Type)
1089 then
1090 Set_Is_Overriding_Operation (Subp, False);
18e968e2 1091
9041e88f 1092 -- If the subprogram specification carries an overriding
1093 -- indicator, no need for the warning: it is either redundant,
1094 -- or else an error will be reported.
1095
1096 if Nkind (Parent (Subp)) = N_Procedure_Specification
1097 and then
1098 (Must_Override (Parent (Subp))
1099 or else Must_Not_Override (Parent (Subp)))
1100 then
1101 null;
18e968e2 1102
1103 -- Here we need the warning
1104
9041e88f 1105 else
1106 Error_Msg_NE
1107 ("operation does not override inherited&?", Subp, Subp);
1108 end if;
18e968e2 1109
e161d1a3 1110 else
1111 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
1112 Set_Is_Overriding_Operation (Subp);
779facca 1113
1114 -- Ada 2005 (AI-251): In case of late overriding of a primitive
1115 -- that covers abstract interface subprograms we must register it
1116 -- in all the secondary dispatch tables associated with abstract
49260fa5 1117 -- interfaces. We do this now only if not building static tables.
1118 -- Otherwise the patch code is emitted after those tables are
1119 -- built, to prevent access_before_elaboration in gigi.
779facca 1120
1121 if Body_Is_Last_Primitive then
1122 declare
1123 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
1124 Elmt : Elmt_Id;
1125 Prim : Node_Id;
1126
1127 begin
1128 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1129 while Present (Elmt) loop
1130 Prim := Node (Elmt);
1131
1132 if Present (Alias (Prim))
a652dd51 1133 and then Present (Interface_Alias (Prim))
779facca 1134 and then Alias (Prim) = Subp
49260fa5 1135 and then not Building_Static_DT (Tagged_Type)
779facca 1136 then
49260fa5 1137 Insert_Actions_After (Subp_Body,
1138 Register_Primitive (Sloc (Subp_Body), Prim => Prim));
779facca 1139 end if;
1140
1141 Next_Elmt (Elmt);
1142 end loop;
1143
6340e5cc 1144 -- Redisplay the contents of the updated dispatch table
779facca 1145
1146 if Debug_Flag_ZZ then
1147 Write_Str ("Late overriding: ");
1148 Write_DT (Tagged_Type);
1149 end if;
1150 end;
1151 end if;
e161d1a3 1152 end if;
9c48514a 1153
64988bb0 1154 -- If the tagged type is a concurrent type then we must be compiling
1155 -- with no code generation (we are either compiling a generic unit or
1156 -- compiling under -gnatc mode) because we have previously tested that
1157 -- no serious errors has been reported. In this case we do not add the
1158 -- primitive to the list of primitives of Tagged_Type but we leave the
1159 -- primitive decorated as a dispatching operation to be able to analyze
1160 -- and report errors associated with the Object.Operation notation.
1161
1162 elsif Is_Concurrent_Type (Tagged_Type) then
1163 pragma Assert (not Expander_Active);
1164 null;
1165
9c48514a 1166 -- If no old subprogram, then we add this as a dispatching operation,
1167 -- but we avoid doing this if an error was posted, to prevent annoying
1168 -- cascaded errors.
1169
1170 elsif not Error_Posted (Subp) then
f15731c4 1171 Add_Dispatching_Operation (Tagged_Type, Subp);
d6f39728 1172 end if;
1173
1174 Set_Is_Dispatching_Operation (Subp, True);
1175
a652dd51 1176 -- Ada 2005 (AI-251): If the type implements interfaces we must check
1177 -- subtype conformance against all the interfaces covered by this
1178 -- primitive.
1179
1180 if Present (Old_Subp)
1181 and then Has_Interfaces (Tagged_Type)
1182 then
1183 declare
1184 Ifaces_List : Elist_Id;
1185 Iface_Elmt : Elmt_Id;
1186 Iface_Prim_Elmt : Elmt_Id;
1187 Iface_Prim : Entity_Id;
1188 Ret_Typ : Entity_Id;
1189
1190 begin
1191 Collect_Interfaces (Tagged_Type, Ifaces_List);
1192
1193 Iface_Elmt := First_Elmt (Ifaces_List);
1194 while Present (Iface_Elmt) loop
1195 if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
1196 Iface_Prim_Elmt :=
1197 First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
1198 while Present (Iface_Prim_Elmt) loop
1199 Iface_Prim := Node (Iface_Prim_Elmt);
1200
1201 if Is_Interface_Conformant
1202 (Tagged_Type, Iface_Prim, Subp)
1203 then
1204 -- Handle procedures, functions whose return type
1205 -- matches, or functions not returning interfaces
1206
1207 if Ekind (Subp) = E_Procedure
1208 or else Etype (Iface_Prim) = Etype (Subp)
1209 or else not Is_Interface (Etype (Iface_Prim))
1210 then
1211 Check_Subtype_Conformant
1212 (New_Id => Subp,
1213 Old_Id => Iface_Prim,
1214 Err_Loc => Subp,
1215 Skip_Controlling_Formals => True);
1216
1217 -- Handle functions returning interfaces
1218
1219 elsif Implements_Interface
1220 (Etype (Subp), Etype (Iface_Prim))
1221 then
1222 -- Temporarily force both entities to return the
1223 -- same type. Required because Subtype_Conformant
1224 -- does not handle this case.
1225
1226 Ret_Typ := Etype (Iface_Prim);
1227 Set_Etype (Iface_Prim, Etype (Subp));
1228
1229 Check_Subtype_Conformant
1230 (New_Id => Subp,
1231 Old_Id => Iface_Prim,
1232 Err_Loc => Subp,
1233 Skip_Controlling_Formals => True);
1234
1235 Set_Etype (Iface_Prim, Ret_Typ);
1236 end if;
1237 end if;
1238
1239 Next_Elmt (Iface_Prim_Elmt);
1240 end loop;
1241 end if;
1242
1243 Next_Elmt (Iface_Elmt);
1244 end loop;
1245 end;
1246 end if;
1247
d6f39728 1248 if not Body_Is_Last_Primitive then
1249 Set_DT_Position (Subp, No_Uint);
d6f39728 1250
f15731c4 1251 elsif Has_Controlled_Component (Tagged_Type)
1252 and then
1253 (Chars (Subp) = Name_Initialize
dffd0a90 1254 or else
1255 Chars (Subp) = Name_Adjust
1256 or else
1257 Chars (Subp) = Name_Finalize)
f15731c4 1258 then
1259 declare
9dfe12ae 1260 F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
f15731c4 1261 Decl : Node_Id;
1262 Old_P : Entity_Id;
1263 Old_Bod : Node_Id;
1264 Old_Spec : Entity_Id;
1265
1266 C_Names : constant array (1 .. 3) of Name_Id :=
1267 (Name_Initialize,
1268 Name_Adjust,
1269 Name_Finalize);
1270
9dfe12ae 1271 D_Names : constant array (1 .. 3) of TSS_Name_Type :=
1272 (TSS_Deep_Initialize,
1273 TSS_Deep_Adjust,
1274 TSS_Deep_Finalize);
f15731c4 1275
1276 begin
dffd0a90 1277 -- Remove previous controlled function which was constructed and
1278 -- analyzed when the type was frozen. This requires removing the
1279 -- body of the redefined primitive, as well as its specification
1280 -- if needed (there is no spec created for Deep_Initialize, see
1281 -- exp_ch3.adb). We must also dismantle the exception information
1282 -- that may have been generated for it when front end zero-cost
1283 -- tables are enabled.
f15731c4 1284
1285 for J in D_Names'Range loop
1286 Old_P := TSS (Tagged_Type, D_Names (J));
1287
1288 if Present (Old_P)
1289 and then Chars (Subp) = C_Names (J)
1290 then
1291 Old_Bod := Unit_Declaration_Node (Old_P);
1292 Remove (Old_Bod);
1293 Set_Is_Eliminated (Old_P);
1294 Set_Scope (Old_P, Scope (Current_Scope));
1295
1296 if Nkind (Old_Bod) = N_Subprogram_Body
1297 and then Present (Corresponding_Spec (Old_Bod))
1298 then
1299 Old_Spec := Corresponding_Spec (Old_Bod);
1300 Set_Has_Completion (Old_Spec, False);
f15731c4 1301 end if;
f15731c4 1302 end if;
1303 end loop;
1304
1305 Build_Late_Proc (Tagged_Type, Chars (Subp));
1306
dffd0a90 1307 -- The new operation is added to the actions of the freeze node
1308 -- for the type, but this node has already been analyzed, so we
1309 -- must retrieve and analyze explicitly the new body.
f15731c4 1310
1311 if Present (F_Node)
1312 and then Present (Actions (F_Node))
1313 then
1314 Decl := Last (Actions (F_Node));
1315 Analyze (Decl);
1316 end if;
1317 end;
1318 end if;
d6f39728 1319 end Check_Dispatching_Operation;
1320
1321 ------------------------------------------
1322 -- Check_Operation_From_Incomplete_Type --
1323 ------------------------------------------
1324
1325 procedure Check_Operation_From_Incomplete_Type
1326 (Subp : Entity_Id;
1327 Typ : Entity_Id)
1328 is
1329 Full : constant Entity_Id := Full_View (Typ);
1330 Parent_Typ : constant Entity_Id := Etype (Full);
1331 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
1332 New_Prim : constant Elist_Id := Primitive_Operations (Full);
1333 Op1, Op2 : Elmt_Id;
1334 Prev : Elmt_Id := No_Elmt;
1335
1336 function Derives_From (Proc : Entity_Id) return Boolean;
1337 -- Check that Subp has the signature of an operation derived from Proc.
1338 -- Subp has an access parameter that designates Typ.
1339
1340 ------------------
1341 -- Derives_From --
1342 ------------------
1343
1344 function Derives_From (Proc : Entity_Id) return Boolean is
1345 F1, F2 : Entity_Id;
1346
1347 begin
1348 if Chars (Proc) /= Chars (Subp) then
1349 return False;
1350 end if;
1351
1352 F1 := First_Formal (Proc);
1353 F2 := First_Formal (Subp);
d6f39728 1354 while Present (F1) and then Present (F2) loop
d6f39728 1355 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
d6f39728 1356 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
1357 return False;
d6f39728 1358 elsif Designated_Type (Etype (F1)) = Parent_Typ
1359 and then Designated_Type (Etype (F2)) /= Full
1360 then
1361 return False;
1362 end if;
1363
1364 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
1365 return False;
1366
1367 elsif Etype (F1) /= Etype (F2) then
1368 return False;
1369 end if;
1370
1371 Next_Formal (F1);
1372 Next_Formal (F2);
1373 end loop;
1374
1375 return No (F1) and then No (F2);
1376 end Derives_From;
1377
1378 -- Start of processing for Check_Operation_From_Incomplete_Type
1379
1380 begin
1381 -- The operation may override an inherited one, or may be a new one
1382 -- altogether. The inherited operation will have been hidden by the
1383 -- current one at the point of the type derivation, so it does not
1384 -- appear in the list of primitive operations of the type. We have to
1385 -- find the proper place of insertion in the list of primitive opera-
1386 -- tions by iterating over the list for the parent type.
1387
1388 Op1 := First_Elmt (Old_Prim);
1389 Op2 := First_Elmt (New_Prim);
d6f39728 1390 while Present (Op1) and then Present (Op2) loop
d6f39728 1391 if Derives_From (Node (Op1)) then
d6f39728 1392 if No (Prev) then
a652dd51 1393
1394 -- Avoid adding it to the list of primitives if already there!
1395
1396 if Node (Op2) /= Subp then
1397 Prepend_Elmt (Subp, New_Prim);
1398 end if;
1399
d6f39728 1400 else
1401 Insert_Elmt_After (Subp, Prev);
1402 end if;
1403
1404 return;
1405 end if;
1406
1407 Prev := Op2;
1408 Next_Elmt (Op1);
1409 Next_Elmt (Op2);
1410 end loop;
1411
9dfe12ae 1412 -- Operation is a new primitive
d6f39728 1413
1414 Append_Elmt (Subp, New_Prim);
d6f39728 1415 end Check_Operation_From_Incomplete_Type;
1416
1417 ---------------------------------------
1418 -- Check_Operation_From_Private_View --
1419 ---------------------------------------
1420
1421 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
1422 Tagged_Type : Entity_Id;
1423
1424 begin
1425 if Is_Dispatching_Operation (Alias (Subp)) then
1426 Set_Scope (Subp, Current_Scope);
1427 Tagged_Type := Find_Dispatching_Type (Subp);
1428
7f2cf564 1429 -- Add Old_Subp to primitive operations if not already present
fd89b7ee 1430
d6f39728 1431 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
fd89b7ee 1432 Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
d6f39728 1433
1434 -- If Old_Subp isn't already marked as dispatching then
1435 -- this is the case of an operation of an untagged private
1436 -- type fulfilled by a tagged type that overrides an
1437 -- inherited dispatching operation, so we set the necessary
1438 -- dispatching attributes here.
1439
1440 if not Is_Dispatching_Operation (Old_Subp) then
9dfe12ae 1441
1442 -- If the untagged type has no discriminants, and the full
1443 -- view is constrained, there will be a spurious mismatch
1444 -- of subtypes on the controlling arguments, because the tagged
1445 -- type is the internal base type introduced in the derivation.
1446 -- Use the original type to verify conformance, rather than the
1447 -- base type.
1448
1449 if not Comes_From_Source (Tagged_Type)
1450 and then Has_Discriminants (Tagged_Type)
1451 then
1452 declare
1453 Formal : Entity_Id;
dffd0a90 1454
9dfe12ae 1455 begin
1456 Formal := First_Formal (Old_Subp);
1457 while Present (Formal) loop
1458 if Tagged_Type = Base_Type (Etype (Formal)) then
1459 Tagged_Type := Etype (Formal);
1460 end if;
1461
1462 Next_Formal (Formal);
1463 end loop;
1464 end;
1465
1466 if Tagged_Type = Base_Type (Etype (Old_Subp)) then
1467 Tagged_Type := Etype (Old_Subp);
1468 end if;
1469 end if;
1470
d6f39728 1471 Check_Controlling_Formals (Tagged_Type, Old_Subp);
1472 Set_Is_Dispatching_Operation (Old_Subp, True);
1473 Set_DT_Position (Old_Subp, No_Uint);
1474 end if;
1475
1476 -- If the old subprogram is an explicit renaming of some other
1477 -- entity, it is not overridden by the inherited subprogram.
1478 -- Otherwise, update its alias and other attributes.
1479
1480 if Present (Alias (Old_Subp))
dffd0a90 1481 and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
1482 N_Subprogram_Renaming_Declaration
d6f39728 1483 then
1484 Set_Alias (Old_Subp, Alias (Subp));
1485
1486 -- The derived subprogram should inherit the abstractness
1487 -- of the parent subprogram (except in the case of a function
1488 -- returning the type). This sets the abstractness properly
1489 -- for cases where a private extension may have inherited
1490 -- an abstract operation, but the full type is derived from
1491 -- a descendant type and inherits a nonabstract version.
1492
1493 if Etype (Subp) /= Tagged_Type then
343d35dc 1494 Set_Is_Abstract_Subprogram
1495 (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
d6f39728 1496 end if;
1497 end if;
1498 end if;
1499 end if;
1500 end Check_Operation_From_Private_View;
1501
1502 --------------------------
1503 -- Find_Controlling_Arg --
1504 --------------------------
1505
1506 function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1507 Orig_Node : constant Node_Id := Original_Node (N);
1508 Typ : Entity_Id;
1509
1510 begin
1511 if Nkind (Orig_Node) = N_Qualified_Expression then
1512 return Find_Controlling_Arg (Expression (Orig_Node));
1513 end if;
1514
57df6d00 1515 -- Dispatching on result case. If expansion is disabled, the node still
1516 -- has the structure of a function call. However, if the function name
1517 -- is an operator and the call was given in infix form, the original
1518 -- node has no controlling result and we must examine the current node.
1519
1520 if Nkind (N) = N_Function_Call
1521 and then Present (Controlling_Argument (N))
1522 and then Has_Controlling_Result (Entity (Name (N)))
1523 then
1524 return Controlling_Argument (N);
1525
1526 -- If expansion is enabled, the call may have been transformed into
1527 -- an indirect call, and we need to recover the original node.
d6f39728 1528
57df6d00 1529 elsif Nkind (Orig_Node) = N_Function_Call
d6f39728 1530 and then Present (Controlling_Argument (Orig_Node))
1531 and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1532 then
1533 return Controlling_Argument (Orig_Node);
1534
1535 -- Normal case
1536
9dfe12ae 1537 elsif Is_Controlling_Actual (N)
1538 or else
1539 (Nkind (Parent (N)) = N_Qualified_Expression
1540 and then Is_Controlling_Actual (Parent (N)))
1541 then
d6f39728 1542 Typ := Etype (N);
1543
1544 if Is_Access_Type (Typ) then
dffd0a90 1545
1546 -- In the case of an Access attribute, use the type of the prefix,
1547 -- since in the case of an actual for an access parameter, the
1548 -- attribute's type may be of a specific designated type, even
1549 -- though the prefix type is class-wide.
d6f39728 1550
1551 if Nkind (N) = N_Attribute_Reference then
1552 Typ := Etype (Prefix (N));
f15731c4 1553
dffd0a90 1554 -- An allocator is dispatching if the type of qualified expression
1555 -- is class_wide, in which case this is the controlling type.
f15731c4 1556
1557 elsif Nkind (Orig_Node) = N_Allocator
1558 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1559 then
1560 Typ := Etype (Expression (Orig_Node));
d6f39728 1561 else
1562 Typ := Designated_Type (Typ);
1563 end if;
1564 end if;
1565
9dfe12ae 1566 if Is_Class_Wide_Type (Typ)
1567 or else
1568 (Nkind (Parent (N)) = N_Qualified_Expression
1569 and then Is_Access_Type (Etype (N))
1570 and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1571 then
d6f39728 1572 return N;
1573 end if;
1574 end if;
1575
1576 return Empty;
1577 end Find_Controlling_Arg;
1578
1579 ---------------------------
1580 -- Find_Dispatching_Type --
1581 ---------------------------
1582
1583 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
069d2ce4 1584 A_Formal : Entity_Id;
d6f39728 1585 Formal : Entity_Id;
1586 Ctrl_Type : Entity_Id;
1587
1588 begin
1589 if Present (DTC_Entity (Subp)) then
1590 return Scope (DTC_Entity (Subp));
1591
069d2ce4 1592 -- For subprograms internally generated by derivations of tagged types
1593 -- use the alias subprogram as a reference to locate the dispatching
4ad935a2 1594 -- type of Subp.
069d2ce4 1595
1596 elsif not Comes_From_Source (Subp)
1597 and then Present (Alias (Subp))
1598 and then Is_Dispatching_Operation (Alias (Subp))
1599 then
1600 if Ekind (Alias (Subp)) = E_Function
1601 and then Has_Controlling_Result (Alias (Subp))
1602 then
1603 return Check_Controlling_Type (Etype (Subp), Subp);
1604
1605 else
1606 Formal := First_Formal (Subp);
1607 A_Formal := First_Formal (Alias (Subp));
1608 while Present (A_Formal) loop
1609 if Is_Controlling_Formal (A_Formal) then
1610 return Check_Controlling_Type (Etype (Formal), Subp);
1611 end if;
1612
1613 Next_Formal (Formal);
1614 Next_Formal (A_Formal);
1615 end loop;
1616
1617 pragma Assert (False);
1618 return Empty;
1619 end if;
1620
1621 -- General case
1622
d6f39728 1623 else
1624 Formal := First_Formal (Subp);
1625 while Present (Formal) loop
1626 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1627
1628 if Present (Ctrl_Type) then
1629 return Ctrl_Type;
1630 end if;
1631
1632 Next_Formal (Formal);
1633 end loop;
1634
069d2ce4 1635 -- The subprogram may also be dispatching on result
d6f39728 1636
1637 if Present (Etype (Subp)) then
069d2ce4 1638 return Check_Controlling_Type (Etype (Subp), Subp);
d6f39728 1639 end if;
1640 end if;
1641
dffd0a90 1642 pragma Assert (not Is_Dispatching_Operation (Subp));
d6f39728 1643 return Empty;
1644 end Find_Dispatching_Type;
1645
a652dd51 1646 ---------------------------------------
1647 -- Find_Primitive_Covering_Interface --
1648 ---------------------------------------
1649
1650 function Find_Primitive_Covering_Interface
1651 (Tagged_Type : Entity_Id;
1652 Iface_Prim : Entity_Id) return Entity_Id
1653 is
ee52a7de 1654 E : Entity_Id;
1655 El : Elmt_Id;
a652dd51 1656
1657 begin
1658 pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
1659 or else (Present (Alias (Iface_Prim))
1660 and then
1661 Is_Interface
1662 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
1663
98f7db28 1664 -- Search in the homonym chain. Done to speed up locating visible
1665 -- entities and required to catch primitives associated with the partial
1666 -- view of private types when processing the corresponding full view.
ee52a7de 1667
a652dd51 1668 E := Current_Entity (Iface_Prim);
1669 while Present (E) loop
1670 if Is_Subprogram (E)
1671 and then Is_Dispatching_Operation (E)
1672 and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
1673 then
1674 return E;
1675 end if;
1676
1677 E := Homonym (E);
1678 end loop;
1679
98f7db28 1680 -- Search in the list of primitives of the type. Required to locate the
1681 -- covering primitive if the covering primitive is not visible (for
1682 -- example, non-visible inherited primitive of private type).
ee52a7de 1683
1684 El := First_Elmt (Primitive_Operations (Tagged_Type));
1685 while Present (El) loop
1686 E := Node (El);
1687
98f7db28 1688 -- Keep separate the management of internal entities that link
1689 -- primitives with interface primitives from tagged type primitives.
1690
1691 if No (Interface_Alias (E)) then
1692 if Present (Alias (E)) then
1693
1694 -- This interface primitive has not been covered yet
1695
1696 if Alias (E) = Iface_Prim then
1697 return E;
1698
1699 -- The covering primitive was inherited
1700
1701 elsif Overridden_Operation (Ultimate_Alias (E))
1702 = Iface_Prim
1703 then
1704 return E;
1705 end if;
1706 end if;
1707
1708 -- Use the internal entity that links the interface primitive with
1709 -- the covering primitive to locate the entity
1710
1711 elsif Interface_Alias (E) = Iface_Prim then
1712 return Alias (E);
ee52a7de 1713 end if;
1714
1715 Next_Elmt (El);
1716 end loop;
1717
1718 -- Not found
1719
a652dd51 1720 return Empty;
1721 end Find_Primitive_Covering_Interface;
1722
d6f39728 1723 ---------------------------
1724 -- Is_Dynamically_Tagged --
1725 ---------------------------
1726
1727 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1728 begin
cdfe77a0 1729 if Nkind (N) = N_Error then
1730 return False;
1731 else
1732 return Find_Controlling_Arg (N) /= Empty;
1733 end if;
d6f39728 1734 end Is_Dynamically_Tagged;
1735
4d2fc001 1736 ---------------------------------
1737 -- Is_Null_Interface_Primitive --
1738 ---------------------------------
1739
1740 function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
1741 begin
1742 return Comes_From_Source (E)
1743 and then Is_Dispatching_Operation (E)
1744 and then Ekind (E) = E_Procedure
1745 and then Null_Present (Parent (E))
1746 and then Is_Interface (Find_Dispatching_Type (E));
1747 end Is_Null_Interface_Primitive;
1748
d6f39728 1749 --------------------------
1750 -- Is_Tag_Indeterminate --
1751 --------------------------
1752
1753 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1754 Nam : Entity_Id;
1755 Actual : Node_Id;
1756 Orig_Node : constant Node_Id := Original_Node (N);
1757
1758 begin
1759 if Nkind (Orig_Node) = N_Function_Call
1760 and then Is_Entity_Name (Name (Orig_Node))
1761 then
1762 Nam := Entity (Name (Orig_Node));
1763
1764 if not Has_Controlling_Result (Nam) then
1765 return False;
1766
9dfe12ae 1767 -- An explicit dereference means that the call has already been
1768 -- expanded and there is no tag to propagate.
1769
1770 elsif Nkind (N) = N_Explicit_Dereference then
1771 return False;
1772
d6f39728 1773 -- If there are no actuals, the call is tag-indeterminate
1774
1775 elsif No (Parameter_Associations (Orig_Node)) then
1776 return True;
1777
1778 else
1779 Actual := First_Actual (Orig_Node);
d6f39728 1780 while Present (Actual) loop
1781 if Is_Controlling_Actual (Actual)
1782 and then not Is_Tag_Indeterminate (Actual)
1783 then
1784 return False; -- one operand is dispatching
1785 end if;
1786
1787 Next_Actual (Actual);
1788 end loop;
1789
1790 return True;
d6f39728 1791 end if;
1792
1793 elsif Nkind (Orig_Node) = N_Qualified_Expression then
1794 return Is_Tag_Indeterminate (Expression (Orig_Node));
1795
9c48514a 1796 -- Case of a call to the Input attribute (possibly rewritten), which is
1797 -- always tag-indeterminate except when its prefix is a Class attribute.
1798
1799 elsif Nkind (Orig_Node) = N_Attribute_Reference
1800 and then
1801 Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
1802 and then
1803 Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
1804 then
1805 return True;
779facca 1806
1807 -- In Ada 2005 a function that returns an anonymous access type can
1808 -- dispatching, and the dereference of a call to such a function
1809 -- is also tag-indeterminate.
1810
1811 elsif Nkind (Orig_Node) = N_Explicit_Dereference
de54c5ab 1812 and then Ada_Version >= Ada_2005
779facca 1813 then
1814 return Is_Tag_Indeterminate (Prefix (Orig_Node));
1815
d6f39728 1816 else
1817 return False;
1818 end if;
1819 end Is_Tag_Indeterminate;
1820
1821 ------------------------------------
1822 -- Override_Dispatching_Operation --
1823 ------------------------------------
1824
1825 procedure Override_Dispatching_Operation
1826 (Tagged_Type : Entity_Id;
1827 Prev_Op : Entity_Id;
1828 New_Op : Entity_Id)
1829 is
779facca 1830 Elmt : Elmt_Id;
1831 Prim : Node_Id;
d6f39728 1832
1833 begin
9c48514a 1834 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
1835 -- we do it unconditionally in Ada 95 now, since this is our pragma!)
1836
1837 if No_Return (Prev_Op) and then not No_Return (New_Op) then
1838 Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
1839 Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
1840 end if;
1841
779facca 1842 -- If there is no previous operation to override, the type declaration
1843 -- was malformed, and an error must have been emitted already.
d6f39728 1844
779facca 1845 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1846 while Present (Elmt)
1847 and then Node (Elmt) /= Prev_Op
d6f39728 1848 loop
779facca 1849 Next_Elmt (Elmt);
d6f39728 1850 end loop;
1851
779facca 1852 if No (Elmt) then
d6f39728 1853 return;
1854 end if;
1855
b381b314 1856 -- The location of entities that come from source in the list of
1857 -- primitives of the tagged type must follow their order of occurrence
1858 -- in the sources to fulfill the C++ ABI. If the overriden entity is a
1859 -- primitive of an interface that is not an ancestor of this tagged
1860 -- type (that is, it is an entity added to the list of primitives by
1861 -- Derive_Interface_Progenitors), then we must append the new entity
1862 -- at the end of the list of primitives.
1863
1864 if Present (Alias (Prev_Op))
1865 and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
1866 and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
1867 Tagged_Type)
1868 then
1869 Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
1870 Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
1871
1872 -- The new primitive replaces the overriden entity. Required to ensure
1873 -- that overriding primitive is assigned the same dispatch table slot.
1874
1875 else
1876 Replace_Elmt (Elmt, New_Op);
1877 end if;
9c48514a 1878
de54c5ab 1879 if Ada_Version >= Ada_2005
a652dd51 1880 and then Has_Interfaces (Tagged_Type)
779facca 1881 then
1882 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
6340e5cc 1883 -- entities of the overridden primitive to reference New_Op, and also
0c57415b 1884 -- propagate the proper value of Is_Abstract_Subprogram. Verify
1885 -- that the new operation is subtype conformant with the interface
1886 -- operations that it implements (for operations inherited from the
1887 -- parent itself, this check is made when building the derived type).
aad6babd 1888
a652dd51 1889 -- Note: This code is only executed in case of late overriding
1890
779facca 1891 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1892 while Present (Elmt) loop
1893 Prim := Node (Elmt);
aad6babd 1894
779facca 1895 if Prim = New_Op then
1896 null;
aad6babd 1897
cdfe77a0 1898 -- Note: The check on Is_Subprogram protects the frontend against
1899 -- reading attributes in entities that are not yet fully decorated
1900
1901 elsif Is_Subprogram (Prim)
a652dd51 1902 and then Present (Interface_Alias (Prim))
779facca 1903 and then Alias (Prim) = Prev_Op
ad4eda7a 1904 and then Present (Etype (New_Op))
779facca 1905 then
1906 Set_Alias (Prim, New_Op);
0c57415b 1907 Check_Subtype_Conformant (New_Op, Prim);
a652dd51 1908 Set_Is_Abstract_Subprogram (Prim,
1909 Is_Abstract_Subprogram (New_Op));
aad6babd 1910
779facca 1911 -- Ensure that this entity will be expanded to fill the
1912 -- corresponding entry in its dispatch table.
1913
343d35dc 1914 if not Is_Abstract_Subprogram (Prim) then
779facca 1915 Set_Has_Delayed_Freeze (Prim);
1916 end if;
aad6babd 1917 end if;
1918
1919 Next_Elmt (Elmt);
1920 end loop;
aad6babd 1921 end if;
d6f39728 1922
b635a7dd 1923 if (not Is_Package_Or_Generic_Package (Current_Scope))
d6f39728 1924 or else not In_Private_Part (Current_Scope)
1925 then
1926 -- Not a private primitive
1927
1928 null;
1929
1930 else pragma Assert (Is_Inherited_Operation (Prev_Op));
1931
1932 -- Make the overriding operation into an alias of the implicit one.
9c48514a 1933 -- In this fashion a call from outside ends up calling the new body
1934 -- even if non-dispatching, and a call from inside calls the
1935 -- overriding operation because it hides the implicit one. To
1936 -- indicate that the body of Prev_Op is never called, set its
d56d8525 1937 -- dispatch table entity to Empty. If the overridden operation
1938 -- has a dispatching result, so does the overriding one.
d6f39728 1939
1940 Set_Alias (Prev_Op, New_Op);
1941 Set_DTC_Entity (Prev_Op, Empty);
d56d8525 1942 Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
d6f39728 1943 return;
1944 end if;
1945 end Override_Dispatching_Operation;
1946
1947 -------------------
1948 -- Propagate_Tag --
1949 -------------------
1950
1951 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1952 Call_Node : Node_Id;
1953 Arg : Node_Id;
1954
1955 begin
1956 if Nkind (Actual) = N_Function_Call then
1957 Call_Node := Actual;
1958
1959 elsif Nkind (Actual) = N_Identifier
1960 and then Nkind (Original_Node (Actual)) = N_Function_Call
1961 then
dffd0a90 1962 -- Call rewritten as object declaration when stack-checking is
1963 -- enabled. Propagate tag to expression in declaration, which is
1964 -- original call.
d6f39728 1965
1966 Call_Node := Expression (Parent (Entity (Actual)));
1967
779facca 1968 -- Ada 2005: If this is a dereference of a call to a function with a
1969 -- dispatching access-result, the tag is propagated when the dereference
1970 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
1971
1972 elsif Nkind (Actual) = N_Explicit_Dereference
1973 and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
1974 then
1975 return;
1976
9c48514a 1977 -- Only other possibilities are parenthesized or qualified expression,
1978 -- or an expander-generated unchecked conversion of a function call to
1979 -- a stream Input attribute.
d6f39728 1980
1981 else
1982 Call_Node := Expression (Actual);
1983 end if;
1984
dffd0a90 1985 -- Do not set the Controlling_Argument if already set. This happens in
1986 -- the special case of _Input (see Exp_Attr, case Input).
d6f39728 1987
1988 if No (Controlling_Argument (Call_Node)) then
1989 Set_Controlling_Argument (Call_Node, Control);
1990 end if;
1991
1992 Arg := First_Actual (Call_Node);
1993
1994 while Present (Arg) loop
1995 if Is_Tag_Indeterminate (Arg) then
1996 Propagate_Tag (Control, Arg);
1997 end if;
1998
1999 Next_Actual (Arg);
2000 end loop;
2001
6340e5cc 2002 -- Expansion of dispatching calls is suppressed when VM_Target, because
dffd0a90 2003 -- the VM back-ends directly handle the generation of dispatching calls
2004 -- and would have to undo any expansion to an indirect call.
d6f39728 2005
662256db 2006 if Tagged_Type_Expansion then
e30c7d84 2007 declare
2008 Call_Typ : constant Entity_Id := Etype (Call_Node);
2009
2010 begin
2011 Expand_Dispatching_Call (Call_Node);
2012
2013 -- If the controlling argument is an interface type and the type
2014 -- of Call_Node differs then we must add an implicit conversion to
2015 -- force displacement of the pointer to the object to reference
2016 -- the secondary dispatch table of the interface.
2017
2018 if Is_Interface (Etype (Control))
2019 and then Etype (Control) /= Call_Typ
2020 then
2021 -- Cannot use Convert_To because the previous call to
2022 -- Expand_Dispatching_Call leaves decorated the Call_Node
2023 -- with the type of Control.
2024
2025 Rewrite (Call_Node,
2026 Make_Type_Conversion (Sloc (Call_Node),
2027 Subtype_Mark =>
2028 New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
2029 Expression => Relocate_Node (Call_Node)));
2030 Set_Etype (Call_Node, Etype (Control));
2031 Set_Analyzed (Call_Node);
2032
2033 Expand_Interface_Conversion (Call_Node, Is_Static => False);
2034 end if;
2035 end;
925d0320 2036
2037 -- Expansion of a dispatching call results in an indirect call, which in
2038 -- turn causes current values to be killed (see Resolve_Call), so on VM
2039 -- targets we do the call here to ensure consistent warnings between VM
2040 -- and non-VM targets.
2041
2042 else
2043 Kill_Current_Values;
d6f39728 2044 end if;
2045 end Propagate_Tag;
2046
2047end Sem_Disp;
Mirror of https://gcc.gnu.org/git/gcc.git