?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge -r 127928:132243 from trunk
[official-gcc.git] / gcc / ada / sem_disp.adb
blob0f3f57becab874c8d05661117733f15e891a3ca2
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-2007, 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 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Elists; use Elists;
29 with Einfo; use Einfo;
30 with Exp_Disp; use Exp_Disp;
31 with Exp_Ch7; use Exp_Ch7;
32 with Exp_Tss; use Exp_Tss;
33 with Errout; use Errout;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt; use Opt;
38 with Output; use Output;
39 with Restrict; use Restrict;
40 with Rident; use Rident;
41 with Sem; use Sem;
42 with Sem_Ch6; use Sem_Ch6;
43 with Sem_Eval; use Sem_Eval;
44 with Sem_Type; use Sem_Type;
45 with Sem_Util; use Sem_Util;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Sinfo; use Sinfo;
49 with Targparm; use Targparm;
50 with Tbuild; use Tbuild;
51 with Uintp; use Uintp;
52
53 package body Sem_Disp is
54
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
58
59 procedure Add_Dispatching_Operation
60 (Tagged_Type : Entity_Id;
61 New_Op : Entity_Id);
62 -- Add New_Op in the list of primitive operations of Tagged_Type
63
64 function Check_Controlling_Type
65 (T : Entity_Id;
66 Subp : Entity_Id) return Entity_Id;
67 -- T is the tagged type of a formal parameter or the result of Subp.
68 -- If the subprogram has a controlling parameter or result that matches
69 -- the type, then returns the tagged type of that parameter or result
70 -- (returning the designated tagged type in the case of an access
71 -- parameter); otherwise returns empty.
72
73 -------------------------------
74 -- Add_Dispatching_Operation --
75 -------------------------------
76
77 procedure Add_Dispatching_Operation
78 (Tagged_Type : Entity_Id;
79 New_Op : Entity_Id)
80 is
81 List : constant Elist_Id := Primitive_Operations (Tagged_Type);
82
83 begin
84 -- The dispatching operation may already be on the list, if it the
85 -- wrapper for an inherited function of a null extension (see exp_ch3
86 -- for the construction of function wrappers). The list of primitive
87 -- operations must not contain duplicates.
88
89 Append_Unique_Elmt (New_Op, List);
90 end Add_Dispatching_Operation;
91
92 -------------------------------
93 -- Check_Controlling_Formals --
94 -------------------------------
95
96 procedure Check_Controlling_Formals
97 (Typ : Entity_Id;
98 Subp : Entity_Id)
99 is
100 Formal : Entity_Id;
101 Ctrl_Type : Entity_Id;
102
103 begin
104 Formal := First_Formal (Subp);
105
106 while Present (Formal) loop
107 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
108
109 if Present (Ctrl_Type) then
110
111 -- When the controlling type is concurrent and declared within a
112 -- generic or inside an instance, use its corresponding record
113 -- type.
114
115 if Is_Concurrent_Type (Ctrl_Type)
116 and then Present (Corresponding_Record_Type (Ctrl_Type))
117 then
118 Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
119 end if;
120
121 if Ctrl_Type = Typ then
122 Set_Is_Controlling_Formal (Formal);
123
124 -- Ada 2005 (AI-231): Anonymous access types used in
125 -- controlling parameters exclude null because it is necessary
126 -- to read the tag to dispatch, and null has no tag.
127
128 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
129 Set_Can_Never_Be_Null (Etype (Formal));
130 Set_Is_Known_Non_Null (Etype (Formal));
131 end if;
132
133 -- Check that the parameter's nominal subtype statically
134 -- matches the first subtype.
135
136 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
137 if not Subtypes_Statically_Match
138 (Typ, Designated_Type (Etype (Formal)))
139 then
140 Error_Msg_N
141 ("parameter subtype does not match controlling type",
142 Formal);
143 end if;
144
145 elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
146 Error_Msg_N
147 ("parameter subtype does not match controlling type",
148 Formal);
149 end if;
150
151 if Present (Default_Value (Formal)) then
152
153 -- In Ada 2005, access parameters can have defaults
154
155 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
156 and then Ada_Version < Ada_05
157 then
158 Error_Msg_N
159 ("default not allowed for controlling access parameter",
160 Default_Value (Formal));
161
162 elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
163 Error_Msg_N
164 ("default expression must be a tag indeterminate" &
165 " function call", Default_Value (Formal));
166 end if;
167 end if;
168
169 elsif Comes_From_Source (Subp) then
170 Error_Msg_N
171 ("operation can be dispatching in only one type", Subp);
172 end if;
173 end if;
174
175 Next_Formal (Formal);
176 end loop;
177
178 if Present (Etype (Subp)) then
179 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
180
181 if Present (Ctrl_Type) then
182 if Ctrl_Type = Typ then
183 Set_Has_Controlling_Result (Subp);
184
185 -- Check that result subtype statically matches first subtype
186 -- (Ada 2005) : Subp may have a controlling access result.
187
188 if Subtypes_Statically_Match (Typ, Etype (Subp))
189 or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
190 and then
191 Subtypes_Statically_Match
192 (Typ, Designated_Type (Etype (Subp))))
193 then
194 null;
195
196 else
197 Error_Msg_N
198 ("result subtype does not match controlling type", Subp);
199 end if;
200
201 elsif Comes_From_Source (Subp) then
202 Error_Msg_N
203 ("operation can be dispatching in only one type", Subp);
204 end if;
205 end if;
206 end if;
207 end Check_Controlling_Formals;
208
209 ----------------------------
210 -- Check_Controlling_Type --
211 ----------------------------
212
213 function Check_Controlling_Type
214 (T : Entity_Id;
215 Subp : Entity_Id) return Entity_Id
216 is
217 Tagged_Type : Entity_Id := Empty;
218
219 begin
220 if Is_Tagged_Type (T) then
221 if Is_First_Subtype (T) then
222 Tagged_Type := T;
223 else
224 Tagged_Type := Base_Type (T);
225 end if;
226
227 elsif Ekind (T) = E_Anonymous_Access_Type
228 and then Is_Tagged_Type (Designated_Type (T))
229 then
230 if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
231 if Is_First_Subtype (Designated_Type (T)) then
232 Tagged_Type := Designated_Type (T);
233 else
234 Tagged_Type := Base_Type (Designated_Type (T));
235 end if;
236
237 -- Ada 2005 : an incomplete type can be tagged. An operation with
238 -- an access parameter of the type is dispatching.
239
240 elsif Scope (Designated_Type (T)) = Current_Scope then
241 Tagged_Type := Designated_Type (T);
242
243 -- Ada 2005 (AI-50217)
244
245 elsif From_With_Type (Designated_Type (T))
246 and then Present (Non_Limited_View (Designated_Type (T)))
247 then
248 if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
249 Tagged_Type := Non_Limited_View (Designated_Type (T));
250 else
251 Tagged_Type := Base_Type (Non_Limited_View
252 (Designated_Type (T)));
253 end if;
254 end if;
255 end if;
256
257 if No (Tagged_Type)
258 or else Is_Class_Wide_Type (Tagged_Type)
259 then
260 return Empty;
261
262 -- The dispatching type and the primitive operation must be defined
263 -- in the same scope, except in the case of internal operations and
264 -- formal abstract subprograms.
265
266 elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
267 and then (not Is_Generic_Type (Tagged_Type)
268 or else not Comes_From_Source (Subp)))
269 or else
270 (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
271 or else
272 (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
273 and then
274 Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
275 and then
276 Is_Abstract_Subprogram (Subp))
277 then
278 return Tagged_Type;
279
280 else
281 return Empty;
282 end if;
283 end Check_Controlling_Type;
284
285 ----------------------------
286 -- Check_Dispatching_Call --
287 ----------------------------
288
289 procedure Check_Dispatching_Call (N : Node_Id) is
290 Loc : constant Source_Ptr := Sloc (N);
291 Actual : Node_Id;
292 Formal : Entity_Id;
293 Control : Node_Id := Empty;
294 Func : Entity_Id;
295 Subp_Entity : Entity_Id;
296 Indeterm_Ancestor_Call : Boolean := False;
297 Indeterm_Ctrl_Type : Entity_Id;
298
299 Static_Tag : Node_Id := Empty;
300 -- If a controlling formal has a statically tagged actual, the tag of
301 -- this actual is to be used for any tag-indeterminate actual
302
303 procedure Check_Dispatching_Context;
304 -- If the call is tag-indeterminate and the entity being called is
305 -- abstract, verify that the context is a call that will eventually
306 -- provide a tag for dispatching, or has provided one already.
307
308 -------------------------------
309 -- Check_Dispatching_Context --
310 -------------------------------
311
312 procedure Check_Dispatching_Context is
313 Subp : constant Entity_Id := Entity (Name (N));
314 Par : Node_Id;
315
316 begin
317 if Is_Abstract_Subprogram (Subp)
318 and then No (Controlling_Argument (N))
319 then
320 if Present (Alias (Subp))
321 and then not Is_Abstract_Subprogram (Alias (Subp))
322 and then No (DTC_Entity (Subp))
323 then
324 -- Private overriding of inherited abstract operation,
325 -- call is legal.
326
327 Set_Entity (Name (N), Alias (Subp));
328 return;
329
330 else
331 Par := Parent (N);
332
333 while Present (Par) loop
334
335 if (Nkind (Par) = N_Function_Call or else
336 Nkind (Par) = N_Procedure_Call_Statement or else
337 Nkind (Par) = N_Assignment_Statement or else
338 Nkind (Par) = N_Op_Eq or else
339 Nkind (Par) = N_Op_Ne)
340 and then Is_Tagged_Type (Etype (Subp))
341 then
342 return;
343
344 elsif Nkind (Par) = N_Qualified_Expression
345 or else Nkind (Par) = N_Unchecked_Type_Conversion
346 then
347 Par := Parent (Par);
348
349 else
350 if Ekind (Subp) = E_Function then
351 Error_Msg_N
352 ("call to abstract function must be dispatching", N);
353
354 -- This error can occur for a procedure in the case of a
355 -- call to an abstract formal procedure with a statically
356 -- tagged operand.
357
358 else
359 Error_Msg_N
360 ("call to abstract procedure must be dispatching",
361 N);
362 end if;
363
364 return;
365 end if;
366 end loop;
367 end if;
368 end if;
369 end Check_Dispatching_Context;
370
371 -- Start of processing for Check_Dispatching_Call
372
373 begin
374 -- Find a controlling argument, if any
375
376 if Present (Parameter_Associations (N)) then
377 Actual := First_Actual (N);
378
379 Subp_Entity := Entity (Name (N));
380 Formal := First_Formal (Subp_Entity);
381
382 while Present (Actual) loop
383 Control := Find_Controlling_Arg (Actual);
384 exit when Present (Control);
385
386 -- Check for the case where the actual is a tag-indeterminate call
387 -- whose result type is different than the tagged type associated
388 -- with the containing call, but is an ancestor of the type.
389
390 if Is_Controlling_Formal (Formal)
391 and then Is_Tag_Indeterminate (Actual)
392 and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
393 and then Is_Ancestor (Etype (Actual), Etype (Formal))
394 then
395 Indeterm_Ancestor_Call := True;
396 Indeterm_Ctrl_Type := Etype (Formal);
397
398 -- If the formal is controlling but the actual is not, the type
399 -- of the actual is statically known, and may be used as the
400 -- controlling tag for some other-indeterminate actual.
401
402 elsif Is_Controlling_Formal (Formal)
403 and then Is_Entity_Name (Actual)
404 and then Is_Tagged_Type (Etype (Actual))
405 then
406 Static_Tag := Actual;
407 end if;
408
409 Next_Actual (Actual);
410 Next_Formal (Formal);
411 end loop;
412
413 -- If the call doesn't have a controlling actual but does have
414 -- an indeterminate actual that requires dispatching treatment,
415 -- then an object is needed that will serve as the controlling
416 -- argument for a dispatching call on the indeterminate actual.
417 -- This can only occur in the unusual situation of a default
418 -- actual given by a tag-indeterminate call and where the type
419 -- of the call is an ancestor of the type associated with a
420 -- containing call to an inherited operation (see AI-239).
421 -- Rather than create an object of the tagged type, which would
422 -- be problematic for various reasons (default initialization,
423 -- discriminants), the tag of the containing call's associated
424 -- tagged type is directly used to control the dispatching.
425
426 if No (Control)
427 and then Indeterm_Ancestor_Call
428 and then No (Static_Tag)
429 then
430 Control :=
431 Make_Attribute_Reference (Loc,
432 Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
433 Attribute_Name => Name_Tag);
434
435 Analyze (Control);
436 end if;
437
438 if Present (Control) then
439
440 -- Verify that no controlling arguments are statically tagged
441
442 if Debug_Flag_E then
443 Write_Str ("Found Dispatching call");
444 Write_Int (Int (N));
445 Write_Eol;
446 end if;
447
448 Actual := First_Actual (N);
449
450 while Present (Actual) loop
451 if Actual /= Control then
452
453 if not Is_Controlling_Actual (Actual) then
454 null; -- Can be anything
455
456 elsif Is_Dynamically_Tagged (Actual) then
457 null; -- Valid parameter
458
459 elsif Is_Tag_Indeterminate (Actual) then
460
461 -- The tag is inherited from the enclosing call (the
462 -- node we are currently analyzing). Explicitly expand
463 -- the actual, since the previous call to Expand
464 -- (from Resolve_Call) had no way of knowing about
465 -- the required dispatching.
466
467 Propagate_Tag (Control, Actual);
468
469 else
470 Error_Msg_N
471 ("controlling argument is not dynamically tagged",
472 Actual);
473 return;
474 end if;
475 end if;
476
477 Next_Actual (Actual);
478 end loop;
479
480 -- Mark call as a dispatching call
481
482 Set_Controlling_Argument (N, Control);
483 Check_Restriction (No_Dispatching_Calls, N);
484
485 -- If there is a statically tagged actual and a tag-indeterminate
486 -- call to a function of the ancestor (such as that provided by a
487 -- default), then treat this as a dispatching call and propagate
488 -- the tag to the tag-indeterminate call(s).
489
490 elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
491 Control :=
492 Make_Attribute_Reference (Loc,
493 Prefix =>
494 New_Occurrence_Of (Etype (Static_Tag), Loc),
495 Attribute_Name => Name_Tag);
496
497 Analyze (Control);
498
499 Actual := First_Actual (N);
500 Formal := First_Formal (Subp_Entity);
501 while Present (Actual) loop
502 if Is_Tag_Indeterminate (Actual)
503 and then Is_Controlling_Formal (Formal)
504 then
505 Propagate_Tag (Control, Actual);
506 end if;
507
508 Next_Actual (Actual);
509 Next_Formal (Formal);
510 end loop;
511
512 Check_Dispatching_Context;
513
514 else
515 -- The call is not dispatching, so check that there aren't any
516 -- tag-indeterminate abstract calls left.
517
518 Actual := First_Actual (N);
519 while Present (Actual) loop
520 if Is_Tag_Indeterminate (Actual) then
521
522 -- Function call case
523
524 if Nkind (Original_Node (Actual)) = N_Function_Call then
525 Func := Entity (Name (Original_Node (Actual)));
526
527 -- If the actual is an attribute then it can't be abstract
528 -- (the only current case of a tag-indeterminate attribute
529 -- is the stream Input attribute).
530
531 elsif
532 Nkind (Original_Node (Actual)) = N_Attribute_Reference
533 then
534 Func := Empty;
535
536 -- Only other possibility is a qualified expression whose
537 -- constituent expression is itself a call.
538
539 else
540 Func :=
541 Entity (Name
542 (Original_Node
543 (Expression (Original_Node (Actual)))));
544 end if;
545
546 if Present (Func) and then Is_Abstract_Subprogram (Func) then
547 Error_Msg_N (
548 "call to abstract function must be dispatching", N);
549 end if;
550 end if;
551
552 Next_Actual (Actual);
553 end loop;
554
555 Check_Dispatching_Context;
556 end if;
557
558 else
559 -- If dispatching on result, the enclosing call, if any, will
560 -- determine the controlling argument. Otherwise this is the
561 -- primitive operation of the root type.
562
563 Check_Dispatching_Context;
564 end if;
565 end Check_Dispatching_Call;
566
567 ---------------------------------
568 -- Check_Dispatching_Operation --
569 ---------------------------------
570
571 procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
572 Tagged_Type : Entity_Id;
573 Has_Dispatching_Parent : Boolean := False;
574 Body_Is_Last_Primitive : Boolean := False;
575
576 function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
577 -- Check whether T is derived from a visibly controlled type.
578 -- This is true if the root type is declared in Ada.Finalization.
579 -- If T is derived instead from a private type whose full view
580 -- is controlled, an explicit Initialize/Adjust/Finalize subprogram
581 -- does not override the inherited one.
582
583 ---------------------------
584 -- Is_Visibly_Controlled --
585 ---------------------------
586
587 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
588 Root : constant Entity_Id := Root_Type (T);
589 begin
590 return Chars (Scope (Root)) = Name_Finalization
591 and then Chars (Scope (Scope (Root))) = Name_Ada
592 and then Scope (Scope (Scope (Root))) = Standard_Standard;
593 end Is_Visibly_Controlled;
594
595 -- Start of processing for Check_Dispatching_Operation
596
597 begin
598 if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
599 return;
600 end if;
601
602 Set_Is_Dispatching_Operation (Subp, False);
603 Tagged_Type := Find_Dispatching_Type (Subp);
604
605 -- Ada 2005 (AI-345)
606
607 if Ada_Version = Ada_05
608 and then Present (Tagged_Type)
609 and then Is_Concurrent_Type (Tagged_Type)
610 then
611 -- Protect the frontend against previously detected errors
612
613 if No (Corresponding_Record_Type (Tagged_Type)) then
614 return;
615 end if;
616
617 Tagged_Type := Corresponding_Record_Type (Tagged_Type);
618 end if;
619
620 -- If Subp is derived from a dispatching operation then it should
621 -- always be treated as dispatching. In this case various checks
622 -- below will be bypassed. Makes sure that late declarations for
623 -- inherited private subprograms are treated as dispatching, even
624 -- if the associated tagged type is already frozen.
625
626 Has_Dispatching_Parent :=
627 Present (Alias (Subp))
628 and then Is_Dispatching_Operation (Alias (Subp));
629
630 if No (Tagged_Type) then
631
632 -- Ada 2005 (AI-251): Check that Subp is not a primitive associated
633 -- with an abstract interface type unless the interface acts as a
634 -- parent type in a derivation. If the interface type is a formal
635 -- type then the operation is not primitive and therefore legal.
636
637 declare
638 E : Entity_Id;
639 Typ : Entity_Id;
640
641 begin
642 E := First_Entity (Subp);
643 while Present (E) loop
644 if Is_Access_Type (Etype (E)) then
645 Typ := Designated_Type (Etype (E));
646 else
647 Typ := Etype (E);
648 end if;
649
650 if Comes_From_Source (Subp)
651 and then Is_Interface (Typ)
652 and then not Is_Class_Wide_Type (Typ)
653 and then not Is_Derived_Type (Typ)
654 and then not Is_Generic_Type (Typ)
655 and then not In_Instance
656 then
657 Error_Msg_N ("?declaration of& is too late!", Subp);
658 Error_Msg_NE
659 ("\spec should appear immediately after declaration of &!",
660 Subp, Typ);
661 exit;
662 end if;
663
664 Next_Entity (E);
665 end loop;
666
667 -- In case of functions check also the result type
668
669 if Ekind (Subp) = E_Function then
670 if Is_Access_Type (Etype (Subp)) then
671 Typ := Designated_Type (Etype (Subp));
672 else
673 Typ := Etype (Subp);
674 end if;
675
676 if not Is_Class_Wide_Type (Typ)
677 and then Is_Interface (Typ)
678 and then not Is_Derived_Type (Typ)
679 then
680 Error_Msg_N ("?declaration of& is too late!", Subp);
681 Error_Msg_NE
682 ("\spec should appear immediately after declaration of &!",
683 Subp, Typ);
684 end if;
685 end if;
686 end;
687
688 return;
689
690 -- The subprograms build internally after the freezing point (such as
691 -- the Init procedure) are not primitives
692
693 elsif Is_Frozen (Tagged_Type)
694 and then not Comes_From_Source (Subp)
695 and then not Has_Dispatching_Parent
696 then
697 return;
698
699 -- The operation may be a child unit, whose scope is the defining
700 -- package, but which is not a primitive operation of the type.
701
702 elsif Is_Child_Unit (Subp) then
703 return;
704
705 -- If the subprogram is not defined in a package spec, the only case
706 -- where it can be a dispatching op is when it overrides an operation
707 -- before the freezing point of the type.
708
709 elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
710 or else In_Package_Body (Scope (Subp)))
711 and then not Has_Dispatching_Parent
712 then
713 if not Comes_From_Source (Subp)
714 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
715 then
716 null;
717
718 -- If the type is already frozen, the overriding is not allowed
719 -- except when Old_Subp is not a dispatching operation (which
720 -- can occur when Old_Subp was inherited by an untagged type).
721 -- However, a body with no previous spec freezes the type "after"
722 -- its declaration, and therefore is a legal overriding (unless
723 -- the type has already been frozen). Only the first such body
724 -- is legal.
725
726 elsif Present (Old_Subp)
727 and then Is_Dispatching_Operation (Old_Subp)
728 then
729 if Comes_From_Source (Subp)
730 and then
731 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
732 or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
733 then
734 declare
735 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
736 Decl_Item : Node_Id := Next (Parent (Tagged_Type));
737
738 begin
739 -- ??? The checks here for whether the type has been
740 -- frozen prior to the new body are not complete. It's
741 -- not simple to check frozenness at this point since
742 -- the body has already caused the type to be prematurely
743 -- frozen in Analyze_Declarations, but we're forced to
744 -- recheck this here because of the odd rule interpretation
745 -- that allows the overriding if the type wasn't frozen
746 -- prior to the body. The freezing action should probably
747 -- be delayed until after the spec is seen, but that's
748 -- a tricky change to the delicate freezing code.
749
750 -- Look at each declaration following the type up
751 -- until the new subprogram body. If any of the
752 -- declarations is a body then the type has been
753 -- frozen already so the overriding primitive is
754 -- illegal.
755
756 while Present (Decl_Item)
757 and then (Decl_Item /= Subp_Body)
758 loop
759 if Comes_From_Source (Decl_Item)
760 and then (Nkind (Decl_Item) in N_Proper_Body
761 or else Nkind (Decl_Item) in N_Body_Stub)
762 then
763 Error_Msg_N ("overriding of& is too late!", Subp);
764 Error_Msg_N
765 ("\spec should appear immediately after the type!",
766 Subp);
767 exit;
768 end if;
769
770 Next (Decl_Item);
771 end loop;
772
773 -- If the subprogram doesn't follow in the list of
774 -- declarations including the type then the type
775 -- has definitely been frozen already and the body
776 -- is illegal.
777
778 if No (Decl_Item) then
779 Error_Msg_N ("overriding of& is too late!", Subp);
780 Error_Msg_N
781 ("\spec should appear immediately after the type!",
782 Subp);
783
784 elsif Is_Frozen (Subp) then
785
786 -- The subprogram body declares a primitive operation.
787 -- if the subprogram is already frozen, we must update
788 -- its dispatching information explicitly here. The
789 -- information is taken from the overridden subprogram.
790
791 Body_Is_Last_Primitive := True;
792
793 if Present (DTC_Entity (Old_Subp)) then
794 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
795 Set_DT_Position (Subp, DT_Position (Old_Subp));
796
797 if not Restriction_Active (No_Dispatching_Calls) then
798 if Building_Static_DT (Tagged_Type) then
799
800 -- If the static dispatch table has not been
801 -- built then there is nothing else to do now;
802 -- otherwise we notify that we cannot build the
803 -- static dispatch table.
804
805 if Has_Dispatch_Table (Tagged_Type) then
806 Error_Msg_N
807 ("overriding of& is too late for building" &
808 " static dispatch tables!", Subp);
809 Error_Msg_N
810 ("\spec should appear immediately after" &
811 " the type!", Subp);
812 end if;
813
814 else
815 Register_Primitive (Sloc (Subp_Body),
816 Prim => Subp,
817 Ins_Nod => Subp_Body);
818 end if;
819 end if;
820 end if;
821 end if;
822 end;
823
824 else
825 Error_Msg_N ("overriding of& is too late!", Subp);
826 Error_Msg_N
827 ("\subprogram spec should appear immediately after the type!",
828 Subp);
829 end if;
830
831 -- If the type is not frozen yet and we are not in the overriding
832 -- case it looks suspiciously like an attempt to define a primitive
833 -- operation.
834
835 elsif not Is_Frozen (Tagged_Type) then
836 Error_Msg_N
837 ("?not dispatching (must be defined in a package spec)", Subp);
838 return;
839
840 -- When the type is frozen, it is legitimate to define a new
841 -- non-primitive operation.
842
843 else
844 return;
845 end if;
846
847 -- Now, we are sure that the scope is a package spec. If the subprogram
848 -- is declared after the freezing point of the type that's an error
849
850 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
851 Error_Msg_N ("this primitive operation is declared too late", Subp);
852 Error_Msg_NE
853 ("?no primitive operations for& after this line",
854 Freeze_Node (Tagged_Type),
855 Tagged_Type);
856 return;
857 end if;
858
859 Check_Controlling_Formals (Tagged_Type, Subp);
860
861 -- Now it should be a correct primitive operation, put it in the list
862
863 if Present (Old_Subp) then
864 Check_Subtype_Conformant (Subp, Old_Subp);
865
866 if (Chars (Subp) = Name_Initialize
867 or else Chars (Subp) = Name_Adjust
868 or else Chars (Subp) = Name_Finalize)
869 and then Is_Controlled (Tagged_Type)
870 and then not Is_Visibly_Controlled (Tagged_Type)
871 then
872 Set_Is_Overriding_Operation (Subp, False);
873 Error_Msg_NE
874 ("operation does not override inherited&?", Subp, Subp);
875 else
876 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
877 Set_Is_Overriding_Operation (Subp);
878
879 -- Ada 2005 (AI-251): In case of late overriding of a primitive
880 -- that covers abstract interface subprograms we must register it
881 -- in all the secondary dispatch tables associated with abstract
882 -- interfaces.
883
884 if Body_Is_Last_Primitive then
885 declare
886 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
887 Elmt : Elmt_Id;
888 Prim : Node_Id;
889
890 begin
891 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
892 while Present (Elmt) loop
893 Prim := Node (Elmt);
894
895 if Present (Alias (Prim))
896 and then Present (Abstract_Interface_Alias (Prim))
897 and then Alias (Prim) = Subp
898 then
899 Register_Primitive (Sloc (Prim),
900 Prim => Prim,
901 Ins_Nod => Subp_Body);
902 end if;
903
904 Next_Elmt (Elmt);
905 end loop;
906
907 -- Redisplay the contents of the updated dispatch table
908
909 if Debug_Flag_ZZ then
910 Write_Str ("Late overriding: ");
911 Write_DT (Tagged_Type);
912 end if;
913 end;
914 end if;
915 end if;
916
917 -- If no old subprogram, then we add this as a dispatching operation,
918 -- but we avoid doing this if an error was posted, to prevent annoying
919 -- cascaded errors.
920
921 elsif not Error_Posted (Subp) then
922 Add_Dispatching_Operation (Tagged_Type, Subp);
923 end if;
924
925 Set_Is_Dispatching_Operation (Subp, True);
926
927 if not Body_Is_Last_Primitive then
928 Set_DT_Position (Subp, No_Uint);
929
930 elsif Has_Controlled_Component (Tagged_Type)
931 and then
932 (Chars (Subp) = Name_Initialize
933 or else Chars (Subp) = Name_Adjust
934 or else Chars (Subp) = Name_Finalize)
935 then
936 declare
937 F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
938 Decl : Node_Id;
939 Old_P : Entity_Id;
940 Old_Bod : Node_Id;
941 Old_Spec : Entity_Id;
942
943 C_Names : constant array (1 .. 3) of Name_Id :=
944 (Name_Initialize,
945 Name_Adjust,
946 Name_Finalize);
947
948 D_Names : constant array (1 .. 3) of TSS_Name_Type :=
949 (TSS_Deep_Initialize,
950 TSS_Deep_Adjust,
951 TSS_Deep_Finalize);
952
953 begin
954 -- Remove previous controlled function, which was constructed
955 -- and analyzed when the type was frozen. This requires
956 -- removing the body of the redefined primitive, as well as
957 -- its specification if needed (there is no spec created for
958 -- Deep_Initialize, see exp_ch3.adb). We must also dismantle
959 -- the exception information that may have been generated for
960 -- it when front end zero-cost tables are enabled.
961
962 for J in D_Names'Range loop
963 Old_P := TSS (Tagged_Type, D_Names (J));
964
965 if Present (Old_P)
966 and then Chars (Subp) = C_Names (J)
967 then
968 Old_Bod := Unit_Declaration_Node (Old_P);
969 Remove (Old_Bod);
970 Set_Is_Eliminated (Old_P);
971 Set_Scope (Old_P, Scope (Current_Scope));
972
973 if Nkind (Old_Bod) = N_Subprogram_Body
974 and then Present (Corresponding_Spec (Old_Bod))
975 then
976 Old_Spec := Corresponding_Spec (Old_Bod);
977 Set_Has_Completion (Old_Spec, False);
978 end if;
979 end if;
980 end loop;
981
982 Build_Late_Proc (Tagged_Type, Chars (Subp));
983
984 -- The new operation is added to the actions of the freeze
985 -- node for the type, but this node has already been analyzed,
986 -- so we must retrieve and analyze explicitly the new body.
987
988 if Present (F_Node)
989 and then Present (Actions (F_Node))
990 then
991 Decl := Last (Actions (F_Node));
992 Analyze (Decl);
993 end if;
994 end;
995 end if;
996 end Check_Dispatching_Operation;
997
998 ------------------------------------------
999 -- Check_Operation_From_Incomplete_Type --
1000 ------------------------------------------
1001
1002 procedure Check_Operation_From_Incomplete_Type
1003 (Subp : Entity_Id;
1004 Typ : Entity_Id)
1005 is
1006 Full : constant Entity_Id := Full_View (Typ);
1007 Parent_Typ : constant Entity_Id := Etype (Full);
1008 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
1009 New_Prim : constant Elist_Id := Primitive_Operations (Full);
1010 Op1, Op2 : Elmt_Id;
1011 Prev : Elmt_Id := No_Elmt;
1012
1013 function Derives_From (Proc : Entity_Id) return Boolean;
1014 -- Check that Subp has the signature of an operation derived from Proc.
1015 -- Subp has an access parameter that designates Typ.
1016
1017 ------------------
1018 -- Derives_From --
1019 ------------------
1020
1021 function Derives_From (Proc : Entity_Id) return Boolean is
1022 F1, F2 : Entity_Id;
1023
1024 begin
1025 if Chars (Proc) /= Chars (Subp) then
1026 return False;
1027 end if;
1028
1029 F1 := First_Formal (Proc);
1030 F2 := First_Formal (Subp);
1031
1032 while Present (F1) and then Present (F2) loop
1033
1034 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
1035
1036 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
1037 return False;
1038
1039 elsif Designated_Type (Etype (F1)) = Parent_Typ
1040 and then Designated_Type (Etype (F2)) /= Full
1041 then
1042 return False;
1043 end if;
1044
1045 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
1046 return False;
1047
1048 elsif Etype (F1) /= Etype (F2) then
1049 return False;
1050 end if;
1051
1052 Next_Formal (F1);
1053 Next_Formal (F2);
1054 end loop;
1055
1056 return No (F1) and then No (F2);
1057 end Derives_From;
1058
1059 -- Start of processing for Check_Operation_From_Incomplete_Type
1060
1061 begin
1062 -- The operation may override an inherited one, or may be a new one
1063 -- altogether. The inherited operation will have been hidden by the
1064 -- current one at the point of the type derivation, so it does not
1065 -- appear in the list of primitive operations of the type. We have to
1066 -- find the proper place of insertion in the list of primitive opera-
1067 -- tions by iterating over the list for the parent type.
1068
1069 Op1 := First_Elmt (Old_Prim);
1070 Op2 := First_Elmt (New_Prim);
1071
1072 while Present (Op1) and then Present (Op2) loop
1073
1074 if Derives_From (Node (Op1)) then
1075
1076 if No (Prev) then
1077 Prepend_Elmt (Subp, New_Prim);
1078 else
1079 Insert_Elmt_After (Subp, Prev);
1080 end if;
1081
1082 return;
1083 end if;
1084
1085 Prev := Op2;
1086 Next_Elmt (Op1);
1087 Next_Elmt (Op2);
1088 end loop;
1089
1090 -- Operation is a new primitive
1091
1092 Append_Elmt (Subp, New_Prim);
1093 end Check_Operation_From_Incomplete_Type;
1094
1095 ---------------------------------------
1096 -- Check_Operation_From_Private_View --
1097 ---------------------------------------
1098
1099 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
1100 Tagged_Type : Entity_Id;
1101
1102 begin
1103 if Is_Dispatching_Operation (Alias (Subp)) then
1104 Set_Scope (Subp, Current_Scope);
1105 Tagged_Type := Find_Dispatching_Type (Subp);
1106
1107 -- Add Old_Subp to primitive operations if not already present.
1108
1109 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
1110 Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
1111
1112 -- If Old_Subp isn't already marked as dispatching then
1113 -- this is the case of an operation of an untagged private
1114 -- type fulfilled by a tagged type that overrides an
1115 -- inherited dispatching operation, so we set the necessary
1116 -- dispatching attributes here.
1117
1118 if not Is_Dispatching_Operation (Old_Subp) then
1119
1120 -- If the untagged type has no discriminants, and the full
1121 -- view is constrained, there will be a spurious mismatch
1122 -- of subtypes on the controlling arguments, because the tagged
1123 -- type is the internal base type introduced in the derivation.
1124 -- Use the original type to verify conformance, rather than the
1125 -- base type.
1126
1127 if not Comes_From_Source (Tagged_Type)
1128 and then Has_Discriminants (Tagged_Type)
1129 then
1130 declare
1131 Formal : Entity_Id;
1132 begin
1133 Formal := First_Formal (Old_Subp);
1134 while Present (Formal) loop
1135 if Tagged_Type = Base_Type (Etype (Formal)) then
1136 Tagged_Type := Etype (Formal);
1137 end if;
1138
1139 Next_Formal (Formal);
1140 end loop;
1141 end;
1142
1143 if Tagged_Type = Base_Type (Etype (Old_Subp)) then
1144 Tagged_Type := Etype (Old_Subp);
1145 end if;
1146 end if;
1147
1148 Check_Controlling_Formals (Tagged_Type, Old_Subp);
1149 Set_Is_Dispatching_Operation (Old_Subp, True);
1150 Set_DT_Position (Old_Subp, No_Uint);
1151 end if;
1152
1153 -- If the old subprogram is an explicit renaming of some other
1154 -- entity, it is not overridden by the inherited subprogram.
1155 -- Otherwise, update its alias and other attributes.
1156
1157 if Present (Alias (Old_Subp))
1158 and then Nkind (Unit_Declaration_Node (Old_Subp))
1159 /= N_Subprogram_Renaming_Declaration
1160 then
1161 Set_Alias (Old_Subp, Alias (Subp));
1162
1163 -- The derived subprogram should inherit the abstractness
1164 -- of the parent subprogram (except in the case of a function
1165 -- returning the type). This sets the abstractness properly
1166 -- for cases where a private extension may have inherited
1167 -- an abstract operation, but the full type is derived from
1168 -- a descendant type and inherits a nonabstract version.
1169
1170 if Etype (Subp) /= Tagged_Type then
1171 Set_Is_Abstract_Subprogram
1172 (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
1173 end if;
1174 end if;
1175 end if;
1176 end if;
1177 end Check_Operation_From_Private_View;
1178
1179 --------------------------
1180 -- Find_Controlling_Arg --
1181 --------------------------
1182
1183 function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1184 Orig_Node : constant Node_Id := Original_Node (N);
1185 Typ : Entity_Id;
1186
1187 begin
1188 if Nkind (Orig_Node) = N_Qualified_Expression then
1189 return Find_Controlling_Arg (Expression (Orig_Node));
1190 end if;
1191
1192 -- Dispatching on result case. If expansion is disabled, the node still
1193 -- has the structure of a function call. However, if the function name
1194 -- is an operator and the call was given in infix form, the original
1195 -- node has no controlling result and we must examine the current node.
1196
1197 if Nkind (N) = N_Function_Call
1198 and then Present (Controlling_Argument (N))
1199 and then Has_Controlling_Result (Entity (Name (N)))
1200 then
1201 return Controlling_Argument (N);
1202
1203 -- If expansion is enabled, the call may have been transformed into
1204 -- an indirect call, and we need to recover the original node.
1205
1206 elsif Nkind (Orig_Node) = N_Function_Call
1207 and then Present (Controlling_Argument (Orig_Node))
1208 and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1209 then
1210 return Controlling_Argument (Orig_Node);
1211
1212 -- Normal case
1213
1214 elsif Is_Controlling_Actual (N)
1215 or else
1216 (Nkind (Parent (N)) = N_Qualified_Expression
1217 and then Is_Controlling_Actual (Parent (N)))
1218 then
1219 Typ := Etype (N);
1220
1221 if Is_Access_Type (Typ) then
1222 -- In the case of an Access attribute, use the type of
1223 -- the prefix, since in the case of an actual for an
1224 -- access parameter, the attribute's type may be of a
1225 -- specific designated type, even though the prefix
1226 -- type is class-wide.
1227
1228 if Nkind (N) = N_Attribute_Reference then
1229 Typ := Etype (Prefix (N));
1230
1231 -- An allocator is dispatching if the type of qualified
1232 -- expression is class_wide, in which case this is the
1233 -- controlling type.
1234
1235 elsif Nkind (Orig_Node) = N_Allocator
1236 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1237 then
1238 Typ := Etype (Expression (Orig_Node));
1239
1240 else
1241 Typ := Designated_Type (Typ);
1242 end if;
1243 end if;
1244
1245 if Is_Class_Wide_Type (Typ)
1246 or else
1247 (Nkind (Parent (N)) = N_Qualified_Expression
1248 and then Is_Access_Type (Etype (N))
1249 and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1250 then
1251 return N;
1252 end if;
1253 end if;
1254
1255 return Empty;
1256 end Find_Controlling_Arg;
1257
1258 ---------------------------
1259 -- Find_Dispatching_Type --
1260 ---------------------------
1261
1262 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
1263 Formal : Entity_Id;
1264 Ctrl_Type : Entity_Id;
1265
1266 begin
1267 if Present (DTC_Entity (Subp)) then
1268 return Scope (DTC_Entity (Subp));
1269
1270 else
1271 Formal := First_Formal (Subp);
1272 while Present (Formal) loop
1273 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1274
1275 if Present (Ctrl_Type) then
1276 return Ctrl_Type;
1277 end if;
1278
1279 Next_Formal (Formal);
1280 end loop;
1281
1282 -- The subprogram may also be dispatching on result
1283
1284 if Present (Etype (Subp)) then
1285 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
1286
1287 if Present (Ctrl_Type) then
1288 return Ctrl_Type;
1289 end if;
1290 end if;
1291 end if;
1292
1293 return Empty;
1294 end Find_Dispatching_Type;
1295
1296 ---------------------------
1297 -- Is_Dynamically_Tagged --
1298 ---------------------------
1299
1300 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1301 begin
1302 if Nkind (N) = N_Error then
1303 return False;
1304 else
1305 return Find_Controlling_Arg (N) /= Empty;
1306 end if;
1307 end Is_Dynamically_Tagged;
1308
1309 --------------------------
1310 -- Is_Tag_Indeterminate --
1311 --------------------------
1312
1313 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1314 Nam : Entity_Id;
1315 Actual : Node_Id;
1316 Orig_Node : constant Node_Id := Original_Node (N);
1317
1318 begin
1319 if Nkind (Orig_Node) = N_Function_Call
1320 and then Is_Entity_Name (Name (Orig_Node))
1321 then
1322 Nam := Entity (Name (Orig_Node));
1323
1324 if not Has_Controlling_Result (Nam) then
1325 return False;
1326
1327 -- An explicit dereference means that the call has already been
1328 -- expanded and there is no tag to propagate.
1329
1330 elsif Nkind (N) = N_Explicit_Dereference then
1331 return False;
1332
1333 -- If there are no actuals, the call is tag-indeterminate
1334
1335 elsif No (Parameter_Associations (Orig_Node)) then
1336 return True;
1337
1338 else
1339 Actual := First_Actual (Orig_Node);
1340 while Present (Actual) loop
1341 if Is_Controlling_Actual (Actual)
1342 and then not Is_Tag_Indeterminate (Actual)
1343 then
1344 return False; -- one operand is dispatching
1345 end if;
1346
1347 Next_Actual (Actual);
1348 end loop;
1349
1350 return True;
1351 end if;
1352
1353 elsif Nkind (Orig_Node) = N_Qualified_Expression then
1354 return Is_Tag_Indeterminate (Expression (Orig_Node));
1355
1356 -- Case of a call to the Input attribute (possibly rewritten), which is
1357 -- always tag-indeterminate except when its prefix is a Class attribute.
1358
1359 elsif Nkind (Orig_Node) = N_Attribute_Reference
1360 and then
1361 Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
1362 and then
1363 Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
1364 then
1365 return True;
1366
1367 -- In Ada 2005 a function that returns an anonymous access type can
1368 -- dispatching, and the dereference of a call to such a function
1369 -- is also tag-indeterminate.
1370
1371 elsif Nkind (Orig_Node) = N_Explicit_Dereference
1372 and then Ada_Version >= Ada_05
1373 then
1374 return Is_Tag_Indeterminate (Prefix (Orig_Node));
1375
1376 else
1377 return False;
1378 end if;
1379 end Is_Tag_Indeterminate;
1380
1381 ------------------------------------
1382 -- Override_Dispatching_Operation --
1383 ------------------------------------
1384
1385 procedure Override_Dispatching_Operation
1386 (Tagged_Type : Entity_Id;
1387 Prev_Op : Entity_Id;
1388 New_Op : Entity_Id)
1389 is
1390 Elmt : Elmt_Id;
1391 Prim : Node_Id;
1392
1393 begin
1394 -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
1395 -- we do it unconditionally in Ada 95 now, since this is our pragma!)
1396
1397 if No_Return (Prev_Op) and then not No_Return (New_Op) then
1398 Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
1399 Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
1400 end if;
1401
1402 -- If there is no previous operation to override, the type declaration
1403 -- was malformed, and an error must have been emitted already.
1404
1405 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1406 while Present (Elmt)
1407 and then Node (Elmt) /= Prev_Op
1408 loop
1409 Next_Elmt (Elmt);
1410 end loop;
1411
1412 if No (Elmt) then
1413 return;
1414 end if;
1415
1416 Replace_Elmt (Elmt, New_Op);
1417
1418 if Ada_Version >= Ada_05
1419 and then Has_Abstract_Interfaces (Tagged_Type)
1420 then
1421 -- Ada 2005 (AI-251): Update the attribute alias of all the aliased
1422 -- entities of the overridden primitive to reference New_Op, and also
1423 -- propagate the proper value of Is_Abstract_Subprogram. Verify
1424 -- that the new operation is subtype conformant with the interface
1425 -- operations that it implements (for operations inherited from the
1426 -- parent itself, this check is made when building the derived type).
1427
1428 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1429 while Present (Elmt) loop
1430 Prim := Node (Elmt);
1431
1432 if Prim = New_Op then
1433 null;
1434
1435 -- Note: The check on Is_Subprogram protects the frontend against
1436 -- reading attributes in entities that are not yet fully decorated
1437
1438 elsif Is_Subprogram (Prim)
1439 and then Present (Abstract_Interface_Alias (Prim))
1440 and then Alias (Prim) = Prev_Op
1441 and then Present (Etype (New_Op))
1442 then
1443 Set_Alias (Prim, New_Op);
1444 Check_Subtype_Conformant (New_Op, Prim);
1445 Set_Is_Abstract_Subprogram
1446 (Prim, Is_Abstract_Subprogram (New_Op));
1447
1448 -- Ensure that this entity will be expanded to fill the
1449 -- corresponding entry in its dispatch table.
1450
1451 if not Is_Abstract_Subprogram (Prim) then
1452 Set_Has_Delayed_Freeze (Prim);
1453 end if;
1454 end if;
1455
1456 Next_Elmt (Elmt);
1457 end loop;
1458 end if;
1459
1460 if (not Is_Package_Or_Generic_Package (Current_Scope))
1461 or else not In_Private_Part (Current_Scope)
1462 then
1463 -- Not a private primitive
1464
1465 null;
1466
1467 else pragma Assert (Is_Inherited_Operation (Prev_Op));
1468
1469 -- Make the overriding operation into an alias of the implicit one.
1470 -- In this fashion a call from outside ends up calling the new body
1471 -- even if non-dispatching, and a call from inside calls the
1472 -- overriding operation because it hides the implicit one. To
1473 -- indicate that the body of Prev_Op is never called, set its
1474 -- dispatch table entity to Empty.
1475
1476 Set_Alias (Prev_Op, New_Op);
1477 Set_DTC_Entity (Prev_Op, Empty);
1478 return;
1479 end if;
1480 end Override_Dispatching_Operation;
1481
1482 -------------------
1483 -- Propagate_Tag --
1484 -------------------
1485
1486 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1487 Call_Node : Node_Id;
1488 Arg : Node_Id;
1489
1490 begin
1491 if Nkind (Actual) = N_Function_Call then
1492 Call_Node := Actual;
1493
1494 elsif Nkind (Actual) = N_Identifier
1495 and then Nkind (Original_Node (Actual)) = N_Function_Call
1496 then
1497 -- Call rewritten as object declaration when stack-checking
1498 -- is enabled. Propagate tag to expression in declaration, which
1499 -- is original call.
1500
1501 Call_Node := Expression (Parent (Entity (Actual)));
1502
1503 -- Ada 2005: If this is a dereference of a call to a function with a
1504 -- dispatching access-result, the tag is propagated when the dereference
1505 -- itself is expanded (see exp_ch6.adb) and there is nothing else to do.
1506
1507 elsif Nkind (Actual) = N_Explicit_Dereference
1508 and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
1509 then
1510 return;
1511
1512 -- Only other possibilities are parenthesized or qualified expression,
1513 -- or an expander-generated unchecked conversion of a function call to
1514 -- a stream Input attribute.
1515
1516 else
1517 Call_Node := Expression (Actual);
1518 end if;
1519
1520 -- Do not set the Controlling_Argument if already set. This happens
1521 -- in the special case of _Input (see Exp_Attr, case Input).
1522
1523 if No (Controlling_Argument (Call_Node)) then
1524 Set_Controlling_Argument (Call_Node, Control);
1525 end if;
1526
1527 Arg := First_Actual (Call_Node);
1528
1529 while Present (Arg) loop
1530 if Is_Tag_Indeterminate (Arg) then
1531 Propagate_Tag (Control, Arg);
1532 end if;
1533
1534 Next_Actual (Arg);
1535 end loop;
1536
1537 -- Expansion of dispatching calls is suppressed when VM_Target, because
1538 -- the VM back-ends directly handle the generation of dispatching
1539 -- calls and would have to undo any expansion to an indirect call.
1540
1541 if VM_Target = No_VM then
1542 Expand_Dispatching_Call (Call_Node);
1543 end if;
1544 end Propagate_Tag;
1545
1546 end Sem_Disp;
Mirror of the offical gcc git repository hosted at gcc.gnu.org