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