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