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