?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Remove old autovect-branch by moving to "dead" directory.
[official-gcc.git] / old-autovect-branch / gcc / ada / sem_disp.adb
bloba187b15384839ff49f80e12924dfb6107dc16af2
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 then
554 -- Protect the frontend against previously detected errors
555
556 if not Present (Corresponding_Record_Type (Tagged_Type)) then
557 return;
558 end if;
559
560 Tagged_Type := Corresponding_Record_Type (Tagged_Type);
561 end if;
562
563 -- If Subp is derived from a dispatching operation then it should
564 -- always be treated as dispatching. In this case various checks
565 -- below will be bypassed. Makes sure that late declarations for
566 -- inherited private subprograms are treated as dispatching, even
567 -- if the associated tagged type is already frozen.
568
569 Has_Dispatching_Parent :=
570 Present (Alias (Subp))
571 and then Is_Dispatching_Operation (Alias (Subp));
572
573 if No (Tagged_Type) then
574 return;
575
576 -- The subprograms build internally after the freezing point (such as
577 -- the Init procedure) are not primitives
578
579 elsif Is_Frozen (Tagged_Type)
580 and then not Comes_From_Source (Subp)
581 and then not Has_Dispatching_Parent
582 then
583 return;
584
585 -- The operation may be a child unit, whose scope is the defining
586 -- package, but which is not a primitive operation of the type.
587
588 elsif Is_Child_Unit (Subp) then
589 return;
590
591 -- If the subprogram is not defined in a package spec, the only case
592 -- where it can be a dispatching op is when it overrides an operation
593 -- before the freezing point of the type.
594
595 elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
596 or else In_Package_Body (Scope (Subp)))
597 and then not Has_Dispatching_Parent
598 then
599 if not Comes_From_Source (Subp)
600 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
601 then
602 null;
603
604 -- If the type is already frozen, the overriding is not allowed
605 -- except when Old_Subp is not a dispatching operation (which
606 -- can occur when Old_Subp was inherited by an untagged type).
607 -- However, a body with no previous spec freezes the type "after"
608 -- its declaration, and therefore is a legal overriding (unless
609 -- the type has already been frozen). Only the first such body
610 -- is legal.
611
612 elsif Present (Old_Subp)
613 and then Is_Dispatching_Operation (Old_Subp)
614 then
615 if Comes_From_Source (Subp)
616 and then
617 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
618 or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
619 then
620 declare
621 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
622 Decl_Item : Node_Id := Next (Parent (Tagged_Type));
623
624 begin
625 -- ??? The checks here for whether the type has been
626 -- frozen prior to the new body are not complete. It's
627 -- not simple to check frozenness at this point since
628 -- the body has already caused the type to be prematurely
629 -- frozen in Analyze_Declarations, but we're forced to
630 -- recheck this here because of the odd rule interpretation
631 -- that allows the overriding if the type wasn't frozen
632 -- prior to the body. The freezing action should probably
633 -- be delayed until after the spec is seen, but that's
634 -- a tricky change to the delicate freezing code.
635
636 -- Look at each declaration following the type up
637 -- until the new subprogram body. If any of the
638 -- declarations is a body then the type has been
639 -- frozen already so the overriding primitive is
640 -- illegal.
641
642 while Present (Decl_Item)
643 and then (Decl_Item /= Subp_Body)
644 loop
645 if Comes_From_Source (Decl_Item)
646 and then (Nkind (Decl_Item) in N_Proper_Body
647 or else Nkind (Decl_Item) in N_Body_Stub)
648 then
649 Error_Msg_N ("overriding of& is too late!", Subp);
650 Error_Msg_N
651 ("\spec should appear immediately after the type!",
652 Subp);
653 exit;
654 end if;
655
656 Next (Decl_Item);
657 end loop;
658
659 -- If the subprogram doesn't follow in the list of
660 -- declarations including the type then the type
661 -- has definitely been frozen already and the body
662 -- is illegal.
663
664 if not Present (Decl_Item) then
665 Error_Msg_N ("overriding of& is too late!", Subp);
666 Error_Msg_N
667 ("\spec should appear immediately after the type!",
668 Subp);
669
670 elsif Is_Frozen (Subp) then
671
672 -- The subprogram body declares a primitive operation.
673 -- if the subprogram is already frozen, we must update
674 -- its dispatching information explicitly here. The
675 -- information is taken from the overridden subprogram.
676
677 Body_Is_Last_Primitive := True;
678
679 if Present (DTC_Entity (Old_Subp)) then
680 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
681 Set_DT_Position (Subp, DT_Position (Old_Subp));
682 Insert_After (
683 Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
684 end if;
685 end if;
686 end;
687
688 else
689 Error_Msg_N ("overriding of& is too late!", Subp);
690 Error_Msg_N
691 ("\subprogram spec should appear immediately after the type!",
692 Subp);
693 end if;
694
695 -- If the type is not frozen yet and we are not in the overridding
696 -- case it looks suspiciously like an attempt to define a primitive
697 -- operation.
698
699 elsif not Is_Frozen (Tagged_Type) then
700 Error_Msg_N
701 ("?not dispatching (must be defined in a package spec)", Subp);
702 return;
703
704 -- When the type is frozen, it is legitimate to define a new
705 -- non-primitive operation.
706
707 else
708 return;
709 end if;
710
711 -- Now, we are sure that the scope is a package spec. If the subprogram
712 -- is declared after the freezing point ot the type that's an error
713
714 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
715 Error_Msg_N ("this primitive operation is declared too late", Subp);
716 Error_Msg_NE
717 ("?no primitive operations for& after this line",
718 Freeze_Node (Tagged_Type),
719 Tagged_Type);
720 return;
721 end if;
722
723 Check_Controlling_Formals (Tagged_Type, Subp);
724
725 -- Now it should be a correct primitive operation, put it in the list
726
727 if Present (Old_Subp) then
728 Check_Subtype_Conformant (Subp, Old_Subp);
729 if (Chars (Subp) = Name_Initialize
730 or else Chars (Subp) = Name_Adjust
731 or else Chars (Subp) = Name_Finalize)
732 and then Is_Controlled (Tagged_Type)
733 and then not Is_Visibly_Controlled (Tagged_Type)
734 then
735 Set_Is_Overriding_Operation (Subp, False);
736 Error_Msg_NE
737 ("operation does not override inherited&?", Subp, Subp);
738 else
739 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
740 Set_Is_Overriding_Operation (Subp);
741 end if;
742 else
743 Add_Dispatching_Operation (Tagged_Type, Subp);
744 end if;
745
746 Set_Is_Dispatching_Operation (Subp, True);
747
748 if not Body_Is_Last_Primitive then
749 Set_DT_Position (Subp, No_Uint);
750
751 elsif Has_Controlled_Component (Tagged_Type)
752 and then
753 (Chars (Subp) = Name_Initialize
754 or else Chars (Subp) = Name_Adjust
755 or else Chars (Subp) = Name_Finalize)
756 then
757 declare
758 F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
759 Decl : Node_Id;
760 Old_P : Entity_Id;
761 Old_Bod : Node_Id;
762 Old_Spec : Entity_Id;
763
764 C_Names : constant array (1 .. 3) of Name_Id :=
765 (Name_Initialize,
766 Name_Adjust,
767 Name_Finalize);
768
769 D_Names : constant array (1 .. 3) of TSS_Name_Type :=
770 (TSS_Deep_Initialize,
771 TSS_Deep_Adjust,
772 TSS_Deep_Finalize);
773
774 begin
775 -- Remove previous controlled function, which was constructed
776 -- and analyzed when the type was frozen. This requires
777 -- removing the body of the redefined primitive, as well as
778 -- its specification if needed (there is no spec created for
779 -- Deep_Initialize, see exp_ch3.adb). We must also dismantle
780 -- the exception information that may have been generated for
781 -- it when front end zero-cost tables are enabled.
782
783 for J in D_Names'Range loop
784 Old_P := TSS (Tagged_Type, D_Names (J));
785
786 if Present (Old_P)
787 and then Chars (Subp) = C_Names (J)
788 then
789 Old_Bod := Unit_Declaration_Node (Old_P);
790 Remove (Old_Bod);
791 Set_Is_Eliminated (Old_P);
792 Set_Scope (Old_P, Scope (Current_Scope));
793
794 if Nkind (Old_Bod) = N_Subprogram_Body
795 and then Present (Corresponding_Spec (Old_Bod))
796 then
797 Old_Spec := Corresponding_Spec (Old_Bod);
798 Set_Has_Completion (Old_Spec, False);
799 end if;
800 end if;
801 end loop;
802
803 Build_Late_Proc (Tagged_Type, Chars (Subp));
804
805 -- The new operation is added to the actions of the freeze
806 -- node for the type, but this node has already been analyzed,
807 -- so we must retrieve and analyze explicitly the one new body,
808
809 if Present (F_Node)
810 and then Present (Actions (F_Node))
811 then
812 Decl := Last (Actions (F_Node));
813 Analyze (Decl);
814 end if;
815 end;
816 end if;
817 end Check_Dispatching_Operation;
818
819 ------------------------------------------
820 -- Check_Operation_From_Incomplete_Type --
821 ------------------------------------------
822
823 procedure Check_Operation_From_Incomplete_Type
824 (Subp : Entity_Id;
825 Typ : Entity_Id)
826 is
827 Full : constant Entity_Id := Full_View (Typ);
828 Parent_Typ : constant Entity_Id := Etype (Full);
829 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ);
830 New_Prim : constant Elist_Id := Primitive_Operations (Full);
831 Op1, Op2 : Elmt_Id;
832 Prev : Elmt_Id := No_Elmt;
833
834 function Derives_From (Proc : Entity_Id) return Boolean;
835 -- Check that Subp has the signature of an operation derived from Proc.
836 -- Subp has an access parameter that designates Typ.
837
838 ------------------
839 -- Derives_From --
840 ------------------
841
842 function Derives_From (Proc : Entity_Id) return Boolean is
843 F1, F2 : Entity_Id;
844
845 begin
846 if Chars (Proc) /= Chars (Subp) then
847 return False;
848 end if;
849
850 F1 := First_Formal (Proc);
851 F2 := First_Formal (Subp);
852
853 while Present (F1) and then Present (F2) loop
854
855 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
856
857 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
858 return False;
859
860 elsif Designated_Type (Etype (F1)) = Parent_Typ
861 and then Designated_Type (Etype (F2)) /= Full
862 then
863 return False;
864 end if;
865
866 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
867 return False;
868
869 elsif Etype (F1) /= Etype (F2) then
870 return False;
871 end if;
872
873 Next_Formal (F1);
874 Next_Formal (F2);
875 end loop;
876
877 return No (F1) and then No (F2);
878 end Derives_From;
879
880 -- Start of processing for Check_Operation_From_Incomplete_Type
881
882 begin
883 -- The operation may override an inherited one, or may be a new one
884 -- altogether. The inherited operation will have been hidden by the
885 -- current one at the point of the type derivation, so it does not
886 -- appear in the list of primitive operations of the type. We have to
887 -- find the proper place of insertion in the list of primitive opera-
888 -- tions by iterating over the list for the parent type.
889
890 Op1 := First_Elmt (Old_Prim);
891 Op2 := First_Elmt (New_Prim);
892
893 while Present (Op1) and then Present (Op2) loop
894
895 if Derives_From (Node (Op1)) then
896
897 if No (Prev) then
898 Prepend_Elmt (Subp, New_Prim);
899 else
900 Insert_Elmt_After (Subp, Prev);
901 end if;
902
903 return;
904 end if;
905
906 Prev := Op2;
907 Next_Elmt (Op1);
908 Next_Elmt (Op2);
909 end loop;
910
911 -- Operation is a new primitive
912
913 Append_Elmt (Subp, New_Prim);
914 end Check_Operation_From_Incomplete_Type;
915
916 ---------------------------------------
917 -- Check_Operation_From_Private_View --
918 ---------------------------------------
919
920 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
921 Tagged_Type : Entity_Id;
922
923 begin
924 if Is_Dispatching_Operation (Alias (Subp)) then
925 Set_Scope (Subp, Current_Scope);
926 Tagged_Type := Find_Dispatching_Type (Subp);
927
928 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
929 Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
930
931 -- If Old_Subp isn't already marked as dispatching then
932 -- this is the case of an operation of an untagged private
933 -- type fulfilled by a tagged type that overrides an
934 -- inherited dispatching operation, so we set the necessary
935 -- dispatching attributes here.
936
937 if not Is_Dispatching_Operation (Old_Subp) then
938
939 -- If the untagged type has no discriminants, and the full
940 -- view is constrained, there will be a spurious mismatch
941 -- of subtypes on the controlling arguments, because the tagged
942 -- type is the internal base type introduced in the derivation.
943 -- Use the original type to verify conformance, rather than the
944 -- base type.
945
946 if not Comes_From_Source (Tagged_Type)
947 and then Has_Discriminants (Tagged_Type)
948 then
949 declare
950 Formal : Entity_Id;
951 begin
952 Formal := First_Formal (Old_Subp);
953 while Present (Formal) loop
954 if Tagged_Type = Base_Type (Etype (Formal)) then
955 Tagged_Type := Etype (Formal);
956 end if;
957
958 Next_Formal (Formal);
959 end loop;
960 end;
961
962 if Tagged_Type = Base_Type (Etype (Old_Subp)) then
963 Tagged_Type := Etype (Old_Subp);
964 end if;
965 end if;
966
967 Check_Controlling_Formals (Tagged_Type, Old_Subp);
968 Set_Is_Dispatching_Operation (Old_Subp, True);
969 Set_DT_Position (Old_Subp, No_Uint);
970 end if;
971
972 -- If the old subprogram is an explicit renaming of some other
973 -- entity, it is not overridden by the inherited subprogram.
974 -- Otherwise, update its alias and other attributes.
975
976 if Present (Alias (Old_Subp))
977 and then Nkind (Unit_Declaration_Node (Old_Subp))
978 /= N_Subprogram_Renaming_Declaration
979 then
980 Set_Alias (Old_Subp, Alias (Subp));
981
982 -- The derived subprogram should inherit the abstractness
983 -- of the parent subprogram (except in the case of a function
984 -- returning the type). This sets the abstractness properly
985 -- for cases where a private extension may have inherited
986 -- an abstract operation, but the full type is derived from
987 -- a descendant type and inherits a nonabstract version.
988
989 if Etype (Subp) /= Tagged_Type then
990 Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
991 end if;
992 end if;
993 end if;
994 end if;
995 end Check_Operation_From_Private_View;
996
997 --------------------------
998 -- Find_Controlling_Arg --
999 --------------------------
1000
1001 function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1002 Orig_Node : constant Node_Id := Original_Node (N);
1003 Typ : Entity_Id;
1004
1005 begin
1006 if Nkind (Orig_Node) = N_Qualified_Expression then
1007 return Find_Controlling_Arg (Expression (Orig_Node));
1008 end if;
1009
1010 -- Dispatching on result case
1011
1012 if Nkind (Orig_Node) = N_Function_Call
1013 and then Present (Controlling_Argument (Orig_Node))
1014 and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1015 then
1016 return Controlling_Argument (Orig_Node);
1017
1018 -- Normal case
1019
1020 elsif Is_Controlling_Actual (N)
1021 or else
1022 (Nkind (Parent (N)) = N_Qualified_Expression
1023 and then Is_Controlling_Actual (Parent (N)))
1024 then
1025 Typ := Etype (N);
1026
1027 if Is_Access_Type (Typ) then
1028 -- In the case of an Access attribute, use the type of
1029 -- the prefix, since in the case of an actual for an
1030 -- access parameter, the attribute's type may be of a
1031 -- specific designated type, even though the prefix
1032 -- type is class-wide.
1033
1034 if Nkind (N) = N_Attribute_Reference then
1035 Typ := Etype (Prefix (N));
1036
1037 -- An allocator is dispatching if the type of qualified
1038 -- expression is class_wide, in which case this is the
1039 -- controlling type.
1040
1041 elsif Nkind (Orig_Node) = N_Allocator
1042 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1043 then
1044 Typ := Etype (Expression (Orig_Node));
1045
1046 else
1047 Typ := Designated_Type (Typ);
1048 end if;
1049 end if;
1050
1051 if Is_Class_Wide_Type (Typ)
1052 or else
1053 (Nkind (Parent (N)) = N_Qualified_Expression
1054 and then Is_Access_Type (Etype (N))
1055 and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1056 then
1057 return N;
1058 end if;
1059 end if;
1060
1061 return Empty;
1062 end Find_Controlling_Arg;
1063
1064 ---------------------------
1065 -- Find_Dispatching_Type --
1066 ---------------------------
1067
1068 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
1069 Formal : Entity_Id;
1070 Ctrl_Type : Entity_Id;
1071
1072 begin
1073 if Present (DTC_Entity (Subp)) then
1074 return Scope (DTC_Entity (Subp));
1075
1076 else
1077 Formal := First_Formal (Subp);
1078 while Present (Formal) loop
1079 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1080
1081 if Present (Ctrl_Type) then
1082 return Ctrl_Type;
1083 end if;
1084
1085 Next_Formal (Formal);
1086 end loop;
1087
1088 -- The subprogram may also be dispatching on result
1089
1090 if Present (Etype (Subp)) then
1091 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
1092
1093 if Present (Ctrl_Type) then
1094 return Ctrl_Type;
1095 end if;
1096 end if;
1097 end if;
1098
1099 return Empty;
1100 end Find_Dispatching_Type;
1101
1102 ---------------------------
1103 -- Is_Dynamically_Tagged --
1104 ---------------------------
1105
1106 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1107 begin
1108 return Find_Controlling_Arg (N) /= Empty;
1109 end Is_Dynamically_Tagged;
1110
1111 --------------------------
1112 -- Is_Tag_Indeterminate --
1113 --------------------------
1114
1115 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1116 Nam : Entity_Id;
1117 Actual : Node_Id;
1118 Orig_Node : constant Node_Id := Original_Node (N);
1119
1120 begin
1121 if Nkind (Orig_Node) = N_Function_Call
1122 and then Is_Entity_Name (Name (Orig_Node))
1123 then
1124 Nam := Entity (Name (Orig_Node));
1125
1126 if not Has_Controlling_Result (Nam) then
1127 return False;
1128
1129 -- An explicit dereference means that the call has already been
1130 -- expanded and there is no tag to propagate.
1131
1132 elsif Nkind (N) = N_Explicit_Dereference then
1133 return False;
1134
1135 -- If there are no actuals, the call is tag-indeterminate
1136
1137 elsif No (Parameter_Associations (Orig_Node)) then
1138 return True;
1139
1140 else
1141 Actual := First_Actual (Orig_Node);
1142
1143 while Present (Actual) loop
1144 if Is_Controlling_Actual (Actual)
1145 and then not Is_Tag_Indeterminate (Actual)
1146 then
1147 return False; -- one operand is dispatching
1148 end if;
1149
1150 Next_Actual (Actual);
1151 end loop;
1152
1153 return True;
1154
1155 end if;
1156
1157 elsif Nkind (Orig_Node) = N_Qualified_Expression then
1158 return Is_Tag_Indeterminate (Expression (Orig_Node));
1159
1160 else
1161 return False;
1162 end if;
1163 end Is_Tag_Indeterminate;
1164
1165 ------------------------------------
1166 -- Override_Dispatching_Operation --
1167 ------------------------------------
1168
1169 procedure Override_Dispatching_Operation
1170 (Tagged_Type : Entity_Id;
1171 Prev_Op : Entity_Id;
1172 New_Op : Entity_Id)
1173 is
1174 Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
1175 Elmt : Elmt_Id;
1176 Found : Boolean;
1177
1178 function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
1179 -- Comment requjired ???
1180
1181 -----------------------------
1182 -- Is_Interface_Subprogram --
1183 -----------------------------
1184
1185 function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is
1186 Aux : Entity_Id;
1187
1188 begin
1189 Aux := Op;
1190 while Present (Alias (Aux))
1191 and then Present (DTC_Entity (Alias (Aux)))
1192 loop
1193 if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then
1194 return True;
1195 end if;
1196 Aux := Alias (Aux);
1197 end loop;
1198
1199 return False;
1200 end Is_Interface_Subprogram;
1201
1202 -- Start of processing for Override_Dispatching_Operation
1203
1204 begin
1205 -- Patch the primitive operation list
1206
1207 while Present (Op_Elmt)
1208 and then Node (Op_Elmt) /= Prev_Op
1209 loop
1210 Next_Elmt (Op_Elmt);
1211 end loop;
1212
1213 -- If there is no previous operation to override, the type declaration
1214 -- was malformed, and an error must have been emitted already.
1215
1216 if No (Op_Elmt) then
1217 return;
1218 end if;
1219
1220 -- Ada 2005 (AI-251): Do not replace subprograms inherited from
1221 -- abstract interfaces. They will be used later to generate the
1222 -- corresponding thunks to initialize the Vtable (see subprogram
1223 -- Freeze_Subprogram). The inherited operation itself must also
1224 -- become hidden, to avoid spurious ambiguities; name resolution
1225 -- must pick up only the operation that implements it,
1226
1227 if Is_Interface_Subprogram (Prev_Op) then
1228 Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op)));
1229 Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op));
1230 Set_Is_Overriding_Operation (Prev_Op);
1231 Set_Abstract_Interface_Alias (Prev_Op, Alias (Prev_Op));
1232 Set_Alias (Prev_Op, New_Op);
1233 Set_Is_Internal (Prev_Op);
1234 Set_Is_Hidden (Prev_Op);
1235
1236 -- Override predefined primitive operations
1237
1238 if Is_Predefined_Dispatching_Operation (Prev_Op) then
1239 Replace_Elmt (Op_Elmt, New_Op);
1240 return;
1241 end if;
1242
1243 -- Check if this primitive operation was previously added for another
1244 -- interface.
1245
1246 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1247 Found := False;
1248 while Present (Elmt) loop
1249 if Node (Elmt) = New_Op then
1250 Found := True;
1251 exit;
1252 end if;
1253
1254 Next_Elmt (Elmt);
1255 end loop;
1256
1257 if not Found then
1258 Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
1259 -- Replace_Elmt (Op_Elmt, New_Op); -- why is this commented out???
1260 end if;
1261 return;
1262
1263 else
1264 Replace_Elmt (Op_Elmt, New_Op);
1265 end if;
1266
1267 if (not Is_Package_Or_Generic_Package (Current_Scope))
1268 or else not In_Private_Part (Current_Scope)
1269 then
1270 -- Not a private primitive
1271
1272 null;
1273
1274 else pragma Assert (Is_Inherited_Operation (Prev_Op));
1275
1276 -- Make the overriding operation into an alias of the implicit one.
1277 -- In this fashion a call from outside ends up calling the new
1278 -- body even if non-dispatching, and a call from inside calls the
1279 -- overriding operation because it hides the implicit one.
1280 -- To indicate that the body of Prev_Op is never called, set its
1281 -- dispatch table entity to Empty.
1282
1283 Set_Alias (Prev_Op, New_Op);
1284 Set_DTC_Entity (Prev_Op, Empty);
1285 return;
1286 end if;
1287 end Override_Dispatching_Operation;
1288
1289 -------------------
1290 -- Propagate_Tag --
1291 -------------------
1292
1293 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1294 Call_Node : Node_Id;
1295 Arg : Node_Id;
1296
1297 begin
1298 if Nkind (Actual) = N_Function_Call then
1299 Call_Node := Actual;
1300
1301 elsif Nkind (Actual) = N_Identifier
1302 and then Nkind (Original_Node (Actual)) = N_Function_Call
1303 then
1304 -- Call rewritten as object declaration when stack-checking
1305 -- is enabled. Propagate tag to expression in declaration, which
1306 -- is original call.
1307
1308 Call_Node := Expression (Parent (Entity (Actual)));
1309
1310 -- Only other possibility is parenthesized or qualified expression
1311
1312 else
1313 Call_Node := Expression (Actual);
1314 end if;
1315
1316 -- Do not set the Controlling_Argument if already set. This happens
1317 -- in the special case of _Input (see Exp_Attr, case Input).
1318
1319 if No (Controlling_Argument (Call_Node)) then
1320 Set_Controlling_Argument (Call_Node, Control);
1321 end if;
1322
1323 Arg := First_Actual (Call_Node);
1324
1325 while Present (Arg) loop
1326 if Is_Tag_Indeterminate (Arg) then
1327 Propagate_Tag (Control, Arg);
1328 end if;
1329
1330 Next_Actual (Arg);
1331 end loop;
1332
1333 -- Expansion of dispatching calls is suppressed when Java_VM, because
1334 -- the JVM back end directly handles the generation of dispatching
1335 -- calls and would have to undo any expansion to an indirect call.
1336
1337 if not Java_VM then
1338 Expand_Dispatching_Call (Call_Node);
1339 end if;
1340 end Propagate_Tag;
1341
1342 end Sem_Disp;
Mirror of the offical gcc git repository hosted at gcc.gnu.org