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