?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
gcc:
[official-gcc.git] / gcc / ada / exp_disp.adb
blob4c6fe26de40f49b6b06269cb17ada2ee6afc7b78
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ 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 Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Tss; use Exp_Tss;
36 with Exp_Util; use Exp_Util;
37 with Freeze; use Freeze;
38 with Itypes; use Itypes;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
41 with Namet; use Namet;
42 with Opt; use Opt;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
47 with Sem; use Sem;
48 with Sem_Disp; use Sem_Disp;
49 with Sem_Res; use Sem_Res;
50 with Sem_Type; use Sem_Type;
51 with Sem_Util; use Sem_Util;
52 with Sinfo; use Sinfo;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Tbuild; use Tbuild;
56 with Uintp; use Uintp;
57
58 package body Exp_Disp is
59
60 --------------------------------
61 -- Select_Expansion_Utilities --
62 --------------------------------
63
64 -- The following package contains helper routines used in the expansion of
65 -- dispatching asynchronous, conditional and timed selects.
66
67 package Select_Expansion_Utilities is
68 procedure Build_B
69 (Loc : Source_Ptr;
70 Params : List_Id);
71 -- Generate:
72 -- B : out Communication_Block
73
74 procedure Build_C
75 (Loc : Source_Ptr;
76 Params : List_Id);
77 -- Generate:
78 -- C : out Prim_Op_Kind
79
80 procedure Build_Common_Dispatching_Select_Statements
81 (Loc : Source_Ptr;
82 Typ : Entity_Id;
83 DT_Ptr : Entity_Id;
84 Stmts : List_Id);
85 -- Ada 2005 (AI-345): Generate statements that are common between
86 -- asynchronous, conditional and timed select expansion.
87
88 procedure Build_F
89 (Loc : Source_Ptr;
90 Params : List_Id);
91 -- Generate:
92 -- F : out Boolean
93
94 procedure Build_P
95 (Loc : Source_Ptr;
96 Params : List_Id);
97 -- Generate:
98 -- P : Address
99
100 procedure Build_S
101 (Loc : Source_Ptr;
102 Params : List_Id);
103 -- Generate:
104 -- S : Integer
105
106 procedure Build_T
107 (Loc : Source_Ptr;
108 Typ : Entity_Id;
109 Params : List_Id);
110 -- Generate:
111 -- T : in out Typ
112 end Select_Expansion_Utilities;
113
114 package body Select_Expansion_Utilities is
115
116 -------------
117 -- Build_B --
118 -------------
119
120 procedure Build_B
121 (Loc : Source_Ptr;
122 Params : List_Id)
123 is
124 begin
125 Append_To (Params,
126 Make_Parameter_Specification (Loc,
127 Defining_Identifier =>
128 Make_Defining_Identifier (Loc, Name_uB),
129 Parameter_Type =>
130 New_Reference_To (RTE (RE_Communication_Block), Loc),
131 Out_Present => True));
132 end Build_B;
133
134 -------------
135 -- Build_C --
136 -------------
137
138 procedure Build_C
139 (Loc : Source_Ptr;
140 Params : List_Id)
141 is
142 begin
143 Append_To (Params,
144 Make_Parameter_Specification (Loc,
145 Defining_Identifier =>
146 Make_Defining_Identifier (Loc, Name_uC),
147 Parameter_Type =>
148 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
149 Out_Present => True));
150 end Build_C;
151
152 ------------------------------------------------
153 -- Build_Common_Dispatching_Select_Statements --
154 ------------------------------------------------
155
156 procedure Build_Common_Dispatching_Select_Statements
157 (Loc : Source_Ptr;
158 Typ : Entity_Id;
159 DT_Ptr : Entity_Id;
160 Stmts : List_Id)
161 is
162 begin
163 -- Generate:
164 -- C := get_prim_op_kind (tag! (<type>VP), S);
165
166 -- where C is the out parameter capturing the call kind and S is the
167 -- dispatch table slot number.
168
169 Append_To (Stmts,
170 Make_Assignment_Statement (Loc,
171 Name =>
172 Make_Identifier (Loc, Name_uC),
173 Expression =>
174 Make_DT_Access_Action (Typ,
175 Action =>
176 Get_Prim_Op_Kind,
177 Args =>
178 New_List (
179 Unchecked_Convert_To (RTE (RE_Tag),
180 New_Reference_To (DT_Ptr, Loc)),
181 Make_Identifier (Loc, Name_uS)))));
182
183 -- Generate:
184
185 -- if C = POK_Procedure
186 -- or else C = POK_Protected_Procedure
187 -- or else C = POK_Task_Procedure;
188 -- then
189 -- F := True;
190 -- return;
191
192 -- where F is the out parameter capturing the status of a potential
193 -- entry call.
194
195 Append_To (Stmts,
196 Make_If_Statement (Loc,
197
198 Condition =>
199 Make_Or_Else (Loc,
200 Left_Opnd =>
201 Make_Op_Eq (Loc,
202 Left_Opnd =>
203 Make_Identifier (Loc, Name_uC),
204 Right_Opnd =>
205 New_Reference_To (RTE (RE_POK_Procedure), Loc)),
206 Right_Opnd =>
207 Make_Or_Else (Loc,
208 Left_Opnd =>
209 Make_Op_Eq (Loc,
210 Left_Opnd =>
211 Make_Identifier (Loc, Name_uC),
212 Right_Opnd =>
213 New_Reference_To (RTE (
214 RE_POK_Protected_Procedure), Loc)),
215 Right_Opnd =>
216 Make_Op_Eq (Loc,
217 Left_Opnd =>
218 Make_Identifier (Loc, Name_uC),
219 Right_Opnd =>
220 New_Reference_To (RTE (
221 RE_POK_Task_Procedure), Loc)))),
222
223 Then_Statements =>
224 New_List (
225 Make_Assignment_Statement (Loc,
226 Name => Make_Identifier (Loc, Name_uF),
227 Expression => New_Reference_To (Standard_True, Loc)),
228
229 Make_Return_Statement (Loc))));
230 end Build_Common_Dispatching_Select_Statements;
231
232 -------------
233 -- Build_F --
234 -------------
235
236 procedure Build_F
237 (Loc : Source_Ptr;
238 Params : List_Id)
239 is
240 begin
241 Append_To (Params,
242 Make_Parameter_Specification (Loc,
243 Defining_Identifier =>
244 Make_Defining_Identifier (Loc, Name_uF),
245 Parameter_Type =>
246 New_Reference_To (Standard_Boolean, Loc),
247 Out_Present => True));
248 end Build_F;
249
250 -------------
251 -- Build_P --
252 -------------
253
254 procedure Build_P
255 (Loc : Source_Ptr;
256 Params : List_Id)
257 is
258 begin
259 Append_To (Params,
260 Make_Parameter_Specification (Loc,
261 Defining_Identifier =>
262 Make_Defining_Identifier (Loc, Name_uP),
263 Parameter_Type =>
264 New_Reference_To (RTE (RE_Address), Loc)));
265 end Build_P;
266
267 -------------
268 -- Build_S --
269 -------------
270
271 procedure Build_S
272 (Loc : Source_Ptr;
273 Params : List_Id)
274 is
275 begin
276 Append_To (Params,
277 Make_Parameter_Specification (Loc,
278 Defining_Identifier =>
279 Make_Defining_Identifier (Loc, Name_uS),
280 Parameter_Type =>
281 New_Reference_To (Standard_Integer, Loc)));
282 end Build_S;
283
284 -------------
285 -- Build_T --
286 -------------
287
288 procedure Build_T
289 (Loc : Source_Ptr;
290 Typ : Entity_Id;
291 Params : List_Id)
292 is
293 begin
294 Append_To (Params,
295 Make_Parameter_Specification (Loc,
296 Defining_Identifier =>
297 Make_Defining_Identifier (Loc, Name_uT),
298 Parameter_Type =>
299 New_Reference_To (Typ, Loc),
300 In_Present => True,
301 Out_Present => True));
302 end Build_T;
303 end Select_Expansion_Utilities;
304
305 package SEU renames Select_Expansion_Utilities;
306
307 Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
308 (CW_Membership => RE_CW_Membership,
309 IW_Membership => RE_IW_Membership,
310 DT_Entry_Size => RE_DT_Entry_Size,
311 DT_Prologue_Size => RE_DT_Prologue_Size,
312 Get_Access_Level => RE_Get_Access_Level,
313 Get_Entry_Index => RE_Get_Entry_Index,
314 Get_External_Tag => RE_Get_External_Tag,
315 Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address,
316 Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
317 Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
318 Get_RC_Offset => RE_Get_RC_Offset,
319 Get_Remotely_Callable => RE_Get_Remotely_Callable,
320 Get_Tagged_Kind => RE_Get_Tagged_Kind,
321 Inherit_DT => RE_Inherit_DT,
322 Inherit_TSD => RE_Inherit_TSD,
323 Register_Interface_Tag => RE_Register_Interface_Tag,
324 Register_Tag => RE_Register_Tag,
325 Set_Access_Level => RE_Set_Access_Level,
326 Set_Entry_Index => RE_Set_Entry_Index,
327 Set_Expanded_Name => RE_Set_Expanded_Name,
328 Set_External_Tag => RE_Set_External_Tag,
329 Set_Interface_Table => RE_Set_Interface_Table,
330 Set_Offset_Index => RE_Set_Offset_Index,
331 Set_OSD => RE_Set_OSD,
332 Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address,
333 Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
334 Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
335 Set_RC_Offset => RE_Set_RC_Offset,
336 Set_Remotely_Callable => RE_Set_Remotely_Callable,
337 Set_Signature => RE_Set_Signature,
338 Set_SSD => RE_Set_SSD,
339 Set_TSD => RE_Set_TSD,
340 Set_Tagged_Kind => RE_Set_Tagged_Kind,
341 TSD_Entry_Size => RE_TSD_Entry_Size,
342 TSD_Prologue_Size => RE_TSD_Prologue_Size);
343
344 Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
345 (CW_Membership => False,
346 IW_Membership => False,
347 DT_Entry_Size => False,
348 DT_Prologue_Size => False,
349 Get_Access_Level => False,
350 Get_Entry_Index => False,
351 Get_External_Tag => False,
352 Get_Predefined_Prim_Op_Address => False,
353 Get_Prim_Op_Address => False,
354 Get_Prim_Op_Kind => False,
355 Get_RC_Offset => False,
356 Get_Remotely_Callable => False,
357 Get_Tagged_Kind => False,
358 Inherit_DT => True,
359 Inherit_TSD => True,
360 Register_Interface_Tag => True,
361 Register_Tag => True,
362 Set_Access_Level => True,
363 Set_Entry_Index => True,
364 Set_Expanded_Name => True,
365 Set_External_Tag => True,
366 Set_Interface_Table => True,
367 Set_Offset_Index => True,
368 Set_OSD => True,
369 Set_Predefined_Prim_Op_Address => True,
370 Set_Prim_Op_Address => True,
371 Set_Prim_Op_Kind => True,
372 Set_RC_Offset => True,
373 Set_Remotely_Callable => True,
374 Set_Signature => True,
375 Set_SSD => True,
376 Set_TSD => True,
377 Set_Tagged_Kind => True,
378 TSD_Entry_Size => False,
379 TSD_Prologue_Size => False);
380
381 Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
382 (CW_Membership => 2,
383 IW_Membership => 2,
384 DT_Entry_Size => 0,
385 DT_Prologue_Size => 0,
386 Get_Access_Level => 1,
387 Get_Entry_Index => 2,
388 Get_External_Tag => 1,
389 Get_Predefined_Prim_Op_Address => 2,
390 Get_Prim_Op_Address => 2,
391 Get_Prim_Op_Kind => 2,
392 Get_RC_Offset => 1,
393 Get_Remotely_Callable => 1,
394 Get_Tagged_Kind => 1,
395 Inherit_DT => 3,
396 Inherit_TSD => 2,
397 Register_Interface_Tag => 3,
398 Register_Tag => 1,
399 Set_Access_Level => 2,
400 Set_Entry_Index => 3,
401 Set_Expanded_Name => 2,
402 Set_External_Tag => 2,
403 Set_Interface_Table => 2,
404 Set_Offset_Index => 3,
405 Set_OSD => 2,
406 Set_Predefined_Prim_Op_Address => 3,
407 Set_Prim_Op_Address => 3,
408 Set_Prim_Op_Kind => 3,
409 Set_RC_Offset => 2,
410 Set_Remotely_Callable => 2,
411 Set_Signature => 2,
412 Set_SSD => 2,
413 Set_TSD => 2,
414 Set_Tagged_Kind => 2,
415 TSD_Entry_Size => 0,
416 TSD_Prologue_Size => 0);
417
418 function Default_Prim_Op_Position (E : Entity_Id) return Uint;
419 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
420 -- of the default primitive operations.
421
422 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
423 -- Returns true if Prim is not a predefined dispatching primitive but it is
424 -- an alias of a predefined dispatching primitive (ie. through a renaming)
425
426 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
427 -- Check if the type has a private view or if the public view appears
428 -- in the visible part of a package spec.
429
430 function Prim_Op_Kind
431 (Prim : Entity_Id;
432 Typ : Entity_Id) return Node_Id;
433 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
434 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
435 -- enumeration value.
436
437 function Tagged_Kind (T : Entity_Id) return Node_Id;
438 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
439 -- to an RE_Tagged_Kind enumeration value.
440
441 ------------------------------
442 -- Default_Prim_Op_Position --
443 ------------------------------
444
445 function Default_Prim_Op_Position (E : Entity_Id) return Uint is
446 TSS_Name : TSS_Name_Type;
447
448 begin
449 Get_Name_String (Chars (E));
450 TSS_Name :=
451 TSS_Name_Type
452 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
453
454 if Chars (E) = Name_uSize then
455 return Uint_1;
456
457 elsif Chars (E) = Name_uAlignment then
458 return Uint_2;
459
460 elsif TSS_Name = TSS_Stream_Read then
461 return Uint_3;
462
463 elsif TSS_Name = TSS_Stream_Write then
464 return Uint_4;
465
466 elsif TSS_Name = TSS_Stream_Input then
467 return Uint_5;
468
469 elsif TSS_Name = TSS_Stream_Output then
470 return Uint_6;
471
472 elsif Chars (E) = Name_Op_Eq then
473 return Uint_7;
474
475 elsif Chars (E) = Name_uAssign then
476 return Uint_8;
477
478 elsif TSS_Name = TSS_Deep_Adjust then
479 return Uint_9;
480
481 elsif TSS_Name = TSS_Deep_Finalize then
482 return Uint_10;
483
484 elsif Ada_Version >= Ada_05 then
485 if Chars (E) = Name_uDisp_Asynchronous_Select then
486 return Uint_11;
487
488 elsif Chars (E) = Name_uDisp_Conditional_Select then
489 return Uint_12;
490
491 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
492 return Uint_13;
493
494 elsif Chars (E) = Name_uDisp_Get_Task_Id then
495 return Uint_14;
496
497 elsif Chars (E) = Name_uDisp_Timed_Select then
498 return Uint_15;
499 end if;
500 end if;
501
502 raise Program_Error;
503 end Default_Prim_Op_Position;
504
505 -----------------------------
506 -- Expand_Dispatching_Call --
507 -----------------------------
508
509 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
510 Loc : constant Source_Ptr := Sloc (Call_Node);
511 Call_Typ : constant Entity_Id := Etype (Call_Node);
512
513 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
514 Param_List : constant List_Id := Parameter_Associations (Call_Node);
515
516 Subp : Entity_Id;
517 CW_Typ : Entity_Id;
518 New_Call : Node_Id;
519 New_Call_Name : Node_Id;
520 New_Params : List_Id := No_List;
521 Param : Node_Id;
522 Res_Typ : Entity_Id;
523 Subp_Ptr_Typ : Entity_Id;
524 Subp_Typ : Entity_Id;
525 Typ : Entity_Id;
526 Eq_Prim_Op : Entity_Id := Empty;
527 Controlling_Tag : Node_Id;
528
529 function New_Value (From : Node_Id) return Node_Id;
530 -- From is the original Expression. New_Value is equivalent to a call
531 -- to Duplicate_Subexpr with an explicit dereference when From is an
532 -- access parameter.
533
534 ---------------
535 -- New_Value --
536 ---------------
537
538 function New_Value (From : Node_Id) return Node_Id is
539 Res : constant Node_Id := Duplicate_Subexpr (From);
540 begin
541 if Is_Access_Type (Etype (From)) then
542 return
543 Make_Explicit_Dereference (Sloc (From),
544 Prefix => Res);
545 else
546 return Res;
547 end if;
548 end New_Value;
549
550 -- Start of processing for Expand_Dispatching_Call
551
552 begin
553 Check_Restriction (No_Dispatching_Calls, Call_Node);
554
555 -- Set subprogram. If this is an inherited operation that was
556 -- overridden, the body that is being called is its alias.
557
558 Subp := Entity (Name (Call_Node));
559
560 if Present (Alias (Subp))
561 and then Is_Inherited_Operation (Subp)
562 and then No (DTC_Entity (Subp))
563 then
564 Subp := Alias (Subp);
565 end if;
566
567 -- Expand_Dispatching_Call is called directly from the semantics,
568 -- so we need a check to see whether expansion is active before
569 -- proceeding.
570
571 if not Expander_Active then
572 return;
573 end if;
574
575 -- Definition of the class-wide type and the tagged type
576
577 -- If the controlling argument is itself a tag rather than a tagged
578 -- object, then use the class-wide type associated with the subprogram's
579 -- controlling type. This case can occur when a call to an inherited
580 -- primitive has an actual that originated from a default parameter
581 -- given by a tag-indeterminate call and when there is no other
582 -- controlling argument providing the tag (AI-239 requires dispatching).
583 -- This capability of dispatching directly by tag is also needed by the
584 -- implementation of AI-260 (for the generic dispatching constructors).
585
586 if Etype (Ctrl_Arg) = RTE (RE_Tag)
587 or else (RTE_Available (RE_Interface_Tag)
588 and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
589 then
590 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
591
592 elsif Is_Access_Type (Etype (Ctrl_Arg)) then
593 CW_Typ := Designated_Type (Etype (Ctrl_Arg));
594
595 else
596 CW_Typ := Etype (Ctrl_Arg);
597 end if;
598
599 Typ := Root_Type (CW_Typ);
600
601 if Ekind (Typ) = E_Incomplete_Type then
602 Typ := Non_Limited_View (Typ);
603 end if;
604
605 if not Is_Limited_Type (Typ) then
606 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
607 end if;
608
609 -- Why do we check the Root_Type instead of Typ???
610
611 if Is_CPP_Class (Root_Type (Typ)) then
612
613 -- Create a new parameter list with the displaced 'this'
614
615 New_Params := New_List;
616 Param := First_Actual (Call_Node);
617 while Present (Param) loop
618 Append_To (New_Params, Relocate_Node (Param));
619 Next_Actual (Param);
620 end loop;
621
622 elsif Present (Param_List) then
623
624 -- Generate the Tag checks when appropriate
625
626 New_Params := New_List;
627 Param := First_Actual (Call_Node);
628 while Present (Param) loop
629
630 -- No tag check with itself
631
632 if Param = Ctrl_Arg then
633 Append_To (New_Params,
634 Duplicate_Subexpr_Move_Checks (Param));
635
636 -- No tag check for parameter whose type is neither tagged nor
637 -- access to tagged (for access parameters)
638
639 elsif No (Find_Controlling_Arg (Param)) then
640 Append_To (New_Params, Relocate_Node (Param));
641
642 -- No tag check for function dispatching on result if the
643 -- Tag given by the context is this one
644
645 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
646 Append_To (New_Params, Relocate_Node (Param));
647
648 -- "=" is the only dispatching operation allowed to get
649 -- operands with incompatible tags (it just returns false).
650 -- We use Duplicate_Subexpr_Move_Checks instead of calling
651 -- Relocate_Node because the value will be duplicated to
652 -- check the tags.
653
654 elsif Subp = Eq_Prim_Op then
655 Append_To (New_Params,
656 Duplicate_Subexpr_Move_Checks (Param));
657
658 -- No check in presence of suppress flags
659
660 elsif Tag_Checks_Suppressed (Etype (Param))
661 or else (Is_Access_Type (Etype (Param))
662 and then Tag_Checks_Suppressed
663 (Designated_Type (Etype (Param))))
664 then
665 Append_To (New_Params, Relocate_Node (Param));
666
667 -- Optimization: no tag checks if the parameters are identical
668
669 elsif Is_Entity_Name (Param)
670 and then Is_Entity_Name (Ctrl_Arg)
671 and then Entity (Param) = Entity (Ctrl_Arg)
672 then
673 Append_To (New_Params, Relocate_Node (Param));
674
675 -- Now we need to generate the Tag check
676
677 else
678 -- Generate code for tag equality check
679 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
680
681 Insert_Action (Ctrl_Arg,
682 Make_Implicit_If_Statement (Call_Node,
683 Condition =>
684 Make_Op_Ne (Loc,
685 Left_Opnd =>
686 Make_Selected_Component (Loc,
687 Prefix => New_Value (Ctrl_Arg),
688 Selector_Name =>
689 New_Reference_To
690 (First_Tag_Component (Typ), Loc)),
691
692 Right_Opnd =>
693 Make_Selected_Component (Loc,
694 Prefix =>
695 Unchecked_Convert_To (Typ, New_Value (Param)),
696 Selector_Name =>
697 New_Reference_To
698 (First_Tag_Component (Typ), Loc))),
699
700 Then_Statements =>
701 New_List (New_Constraint_Error (Loc))));
702
703 Append_To (New_Params, Relocate_Node (Param));
704 end if;
705
706 Next_Actual (Param);
707 end loop;
708 end if;
709
710 -- Generate the appropriate subprogram pointer type
711
712 if Etype (Subp) = Typ then
713 Res_Typ := CW_Typ;
714 else
715 Res_Typ := Etype (Subp);
716 end if;
717
718 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
719 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
720 Set_Etype (Subp_Typ, Res_Typ);
721 Init_Size_Align (Subp_Ptr_Typ);
722 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
723
724 -- Create a new list of parameters which is a copy of the old formal
725 -- list including the creation of a new set of matching entities.
726
727 declare
728 Old_Formal : Entity_Id := First_Formal (Subp);
729 New_Formal : Entity_Id;
730 Extra : Entity_Id;
731
732 begin
733 if Present (Old_Formal) then
734 New_Formal := New_Copy (Old_Formal);
735 Set_First_Entity (Subp_Typ, New_Formal);
736 Param := First_Actual (Call_Node);
737
738 loop
739 Set_Scope (New_Formal, Subp_Typ);
740
741 -- Change all the controlling argument types to be class-wide
742 -- to avoid a recursion in dispatching.
743
744 if Is_Controlling_Formal (New_Formal) then
745 Set_Etype (New_Formal, Etype (Param));
746 end if;
747
748 if Is_Itype (Etype (New_Formal)) then
749 Extra := New_Copy (Etype (New_Formal));
750
751 if Ekind (Extra) = E_Record_Subtype
752 or else Ekind (Extra) = E_Class_Wide_Subtype
753 then
754 Set_Cloned_Subtype (Extra, Etype (New_Formal));
755 end if;
756
757 Set_Etype (New_Formal, Extra);
758 Set_Scope (Etype (New_Formal), Subp_Typ);
759 end if;
760
761 Extra := New_Formal;
762 Next_Formal (Old_Formal);
763 exit when No (Old_Formal);
764
765 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
766 Next_Entity (New_Formal);
767 Next_Actual (Param);
768 end loop;
769
770 Set_Next_Entity (New_Formal, Empty);
771 Set_Last_Entity (Subp_Typ, Extra);
772
773 -- Copy extra formals
774
775 New_Formal := First_Entity (Subp_Typ);
776 while Present (New_Formal) loop
777 if Present (Extra_Constrained (New_Formal)) then
778 Set_Extra_Formal (Extra,
779 New_Copy (Extra_Constrained (New_Formal)));
780 Extra := Extra_Formal (Extra);
781 Set_Extra_Constrained (New_Formal, Extra);
782
783 elsif Present (Extra_Accessibility (New_Formal)) then
784 Set_Extra_Formal (Extra,
785 New_Copy (Extra_Accessibility (New_Formal)));
786 Extra := Extra_Formal (Extra);
787 Set_Extra_Accessibility (New_Formal, Extra);
788 end if;
789
790 Next_Formal (New_Formal);
791 end loop;
792 end if;
793 end;
794
795 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
796 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
797
798 -- If the controlling argument is a value of type Ada.Tag or an abstract
799 -- interface class-wide type then use it directly. Otherwise, the tag
800 -- must be extracted from the controlling object.
801
802 if Etype (Ctrl_Arg) = RTE (RE_Tag)
803 or else (RTE_Available (RE_Interface_Tag)
804 and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
805 then
806 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
807
808 -- Ada 2005 (AI-251): Abstract interface class-wide type
809
810 elsif Is_Interface (Etype (Ctrl_Arg))
811 and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
812 then
813 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
814
815 else
816 Controlling_Tag :=
817 Make_Selected_Component (Loc,
818 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
819 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
820 end if;
821
822 -- Generate:
823 -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
824
825 if Is_Predefined_Dispatching_Operation (Subp)
826 or else Is_Predefined_Dispatching_Alias (Subp)
827 then
828 New_Call_Name :=
829 Unchecked_Convert_To (Subp_Ptr_Typ,
830 Make_DT_Access_Action (Typ,
831 Action => Get_Predefined_Prim_Op_Address,
832 Args => New_List (
833
834 -- Vptr
835
836 Unchecked_Convert_To (RTE (RE_Tag),
837 Controlling_Tag),
838
839 -- Position
840
841 Make_Integer_Literal (Loc, DT_Position (Subp)))));
842
843 else
844 New_Call_Name :=
845 Unchecked_Convert_To (Subp_Ptr_Typ,
846 Make_DT_Access_Action (Typ,
847 Action => Get_Prim_Op_Address,
848 Args => New_List (
849
850 -- Vptr
851
852 Unchecked_Convert_To (RTE (RE_Tag),
853 Controlling_Tag),
854
855 -- Position
856
857 Make_Integer_Literal (Loc, DT_Position (Subp)))));
858 end if;
859
860 if Nkind (Call_Node) = N_Function_Call then
861
862 -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface
863 -- just requires the comparison of the tags.
864
865 if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
866 and then Is_Interface (Etype (Ctrl_Arg))
867 and then Subp = Eq_Prim_Op
868 then
869 Param := First_Actual (Call_Node);
870
871 New_Call :=
872 Make_Op_Eq (Loc,
873 Left_Opnd =>
874 Make_Selected_Component (Loc,
875 Prefix => New_Value (Param),
876 Selector_Name =>
877 New_Reference_To (First_Tag_Component (Typ), Loc)),
878
879 Right_Opnd =>
880 Make_Selected_Component (Loc,
881 Prefix =>
882 Unchecked_Convert_To (Typ,
883 New_Value (Next_Actual (Param))),
884 Selector_Name =>
885 New_Reference_To (First_Tag_Component (Typ), Loc)));
886
887 else
888 New_Call :=
889 Make_Function_Call (Loc,
890 Name => New_Call_Name,
891 Parameter_Associations => New_Params);
892
893 -- If this is a dispatching "=", we must first compare the tags so
894 -- we generate: x.tag = y.tag and then x = y
895
896 if Subp = Eq_Prim_Op then
897 Param := First_Actual (Call_Node);
898 New_Call :=
899 Make_And_Then (Loc,
900 Left_Opnd =>
901 Make_Op_Eq (Loc,
902 Left_Opnd =>
903 Make_Selected_Component (Loc,
904 Prefix => New_Value (Param),
905 Selector_Name =>
906 New_Reference_To (First_Tag_Component (Typ),
907 Loc)),
908
909 Right_Opnd =>
910 Make_Selected_Component (Loc,
911 Prefix =>
912 Unchecked_Convert_To (Typ,
913 New_Value (Next_Actual (Param))),
914 Selector_Name =>
915 New_Reference_To (First_Tag_Component (Typ),
916 Loc))),
917 Right_Opnd => New_Call);
918 end if;
919 end if;
920
921 else
922 New_Call :=
923 Make_Procedure_Call_Statement (Loc,
924 Name => New_Call_Name,
925 Parameter_Associations => New_Params);
926 end if;
927
928 Rewrite (Call_Node, New_Call);
929 Analyze_And_Resolve (Call_Node, Call_Typ);
930 end Expand_Dispatching_Call;
931
932 ---------------------------------
933 -- Expand_Interface_Conversion --
934 ---------------------------------
935
936 procedure Expand_Interface_Conversion
937 (N : Node_Id;
938 Is_Static : Boolean := True)
939 is
940 Loc : constant Source_Ptr := Sloc (N);
941 Etyp : constant Entity_Id := Etype (N);
942 Operand : constant Node_Id := Expression (N);
943 Operand_Typ : Entity_Id := Etype (Operand);
944 Fent : Entity_Id;
945 Func : Node_Id;
946 Iface_Typ : Entity_Id := Etype (N);
947 Iface_Tag : Entity_Id;
948 New_Itype : Entity_Id;
949 P : Node_Id;
950
951 begin
952 pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
953
954 -- Ada 2005 (AI-345): Handle task interfaces
955
956 if Ekind (Operand_Typ) = E_Task_Type
957 or else Ekind (Operand_Typ) = E_Protected_Type
958 then
959 Operand_Typ := Corresponding_Record_Type (Operand_Typ);
960 end if;
961
962 -- Handle access types to interfaces
963
964 if Is_Access_Type (Iface_Typ) then
965 Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
966 end if;
967
968 -- Handle class-wide interface types. This conversion can appear
969 -- explicitly in the source code. Example: I'Class (Obj)
970
971 if Is_Class_Wide_Type (Iface_Typ) then
972 Iface_Typ := Etype (Iface_Typ);
973 end if;
974
975 pragma Assert (not Is_Static
976 or else (not Is_Class_Wide_Type (Iface_Typ)
977 and then Is_Interface (Iface_Typ)));
978
979 if not Is_Static then
980
981 -- Give error if configurable run time and Displace not available
982
983 if not RTE_Available (RE_Displace) then
984 Error_Msg_CRT ("abstract interface types", N);
985 return;
986 end if;
987
988 -- Handle conversion of access to class-wide interface types. The
989 -- target can be an access to object or an access to another class
990 -- wide interfac (see -1- and -2- in the following example):
991
992 -- type Iface1_Ref is access all Iface1'Class;
993 -- type Iface2_Ref is access all Iface1'Class;
994
995 -- Acc1 : Iface1_Ref := new ...
996 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
997 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
998
999 if Is_Access_Type (Operand_Typ) then
1000 pragma Assert
1001 (Is_Class_Wide_Type (Directly_Designated_Type (Operand_Typ))
1002 and then
1003 Is_Interface (Directly_Designated_Type (Operand_Typ)));
1004
1005 Rewrite (N,
1006 Unchecked_Convert_To (Etype (N),
1007 Make_Function_Call (Loc,
1008 Name => New_Reference_To (RTE (RE_Displace), Loc),
1009 Parameter_Associations => New_List (
1010
1011 Unchecked_Convert_To (RTE (RE_Address),
1012 Relocate_Node (Expression (N))),
1013
1014 New_Occurrence_Of
1015 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1016 Loc)))));
1017
1018 Analyze (N);
1019 return;
1020 end if;
1021
1022 Rewrite (N,
1023 Make_Function_Call (Loc,
1024 Name => New_Reference_To (RTE (RE_Displace), Loc),
1025 Parameter_Associations => New_List (
1026 Make_Attribute_Reference (Loc,
1027 Prefix => Relocate_Node (Expression (N)),
1028 Attribute_Name => Name_Address),
1029
1030 New_Occurrence_Of
1031 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1032 Loc))));
1033
1034 Analyze (N);
1035
1036 -- If the target is a class-wide interface we change the type of the
1037 -- data returned by IW_Convert to indicate that this is a dispatching
1038 -- call.
1039
1040 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1041 Set_Etype (New_Itype, New_Itype);
1042 Init_Esize (New_Itype);
1043 Init_Size_Align (New_Itype);
1044 Set_Directly_Designated_Type (New_Itype, Etyp);
1045
1046 Rewrite (N, Make_Explicit_Dereference (Loc,
1047 Unchecked_Convert_To (New_Itype,
1048 Relocate_Node (N))));
1049 Analyze (N);
1050 Freeze_Itype (New_Itype, N);
1051
1052 return;
1053 end if;
1054
1055 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1056 pragma Assert (Iface_Tag /= Empty);
1057
1058 -- Keep separate access types to interfaces because one internal
1059 -- function is used to handle the null value (see following comment)
1060
1061 if not Is_Access_Type (Etype (N)) then
1062 Rewrite (N,
1063 Unchecked_Convert_To (Etype (N),
1064 Make_Selected_Component (Loc,
1065 Prefix => Relocate_Node (Expression (N)),
1066 Selector_Name =>
1067 New_Occurrence_Of (Iface_Tag, Loc))));
1068
1069 else
1070 -- Build internal function to handle the case in which the
1071 -- actual is null. If the actual is null returns null because
1072 -- no displacement is required; otherwise performs a type
1073 -- conversion that will be expanded in the code that returns
1074 -- the value of the displaced actual. That is:
1075
1076 -- function Func (O : Address) return Iface_Typ is
1077 -- begin
1078 -- if O = Null_Address then
1079 -- return null;
1080 -- else
1081 -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
1082 -- end if;
1083 -- end Func;
1084
1085 Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
1086 Set_Is_Internal (Fent);
1087
1088 declare
1089 Desig_Typ : Entity_Id;
1090 begin
1091 Desig_Typ := Etype (Expression (N));
1092
1093 if Is_Access_Type (Desig_Typ) then
1094 Desig_Typ := Directly_Designated_Type (Desig_Typ);
1095 end if;
1096
1097 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1098 Set_Etype (New_Itype, New_Itype);
1099 Set_Scope (New_Itype, Fent);
1100 Init_Size_Align (New_Itype);
1101 Set_Directly_Designated_Type (New_Itype, Desig_Typ);
1102 end;
1103
1104 Func :=
1105 Make_Subprogram_Body (Loc,
1106 Specification =>
1107 Make_Function_Specification (Loc,
1108 Defining_Unit_Name => Fent,
1109
1110 Parameter_Specifications => New_List (
1111 Make_Parameter_Specification (Loc,
1112 Defining_Identifier =>
1113 Make_Defining_Identifier (Loc, Name_uO),
1114 Parameter_Type =>
1115 New_Reference_To (RTE (RE_Address), Loc))),
1116
1117 Result_Definition =>
1118 New_Reference_To (Etype (N), Loc)),
1119
1120 Declarations => Empty_List,
1121
1122 Handled_Statement_Sequence =>
1123 Make_Handled_Sequence_Of_Statements (Loc,
1124 Statements => New_List (
1125 Make_If_Statement (Loc,
1126 Condition =>
1127 Make_Op_Eq (Loc,
1128 Left_Opnd => Make_Identifier (Loc, Name_uO),
1129 Right_Opnd => New_Reference_To
1130 (RTE (RE_Null_Address), Loc)),
1131
1132 Then_Statements => New_List (
1133 Make_Return_Statement (Loc,
1134 Make_Null (Loc))),
1135
1136 Else_Statements => New_List (
1137 Make_Return_Statement (Loc,
1138 Unchecked_Convert_To (Etype (N),
1139 Make_Attribute_Reference (Loc,
1140 Prefix =>
1141 Make_Selected_Component (Loc,
1142 Prefix => Unchecked_Convert_To (New_Itype,
1143 Make_Identifier (Loc, Name_uO)),
1144 Selector_Name =>
1145 New_Occurrence_Of (Iface_Tag, Loc)),
1146 Attribute_Name => Name_Address))))))));
1147
1148 -- Insert the new declaration in the nearest enclosing scope
1149 -- that has declarations.
1150
1151 P := N;
1152 while not Has_Declarations (Parent (P)) loop
1153 P := Parent (P);
1154 end loop;
1155
1156 if Is_List_Member (P) then
1157 Insert_Before (P, Func);
1158
1159 elsif Nkind (Parent (P)) = N_Package_Specification then
1160 Append_To (Visible_Declarations (Parent (P)), Func);
1161
1162 else
1163 Append_To (Declarations (Parent (P)), Func);
1164 end if;
1165
1166 Analyze (Func);
1167
1168 if Is_Access_Type (Etype (Expression (N))) then
1169
1170 -- Generate: Operand_Typ!(Expression.all)'Address
1171
1172 Rewrite (N,
1173 Make_Function_Call (Loc,
1174 Name => New_Reference_To (Fent, Loc),
1175 Parameter_Associations => New_List (
1176 Make_Attribute_Reference (Loc,
1177 Prefix => Unchecked_Convert_To (Operand_Typ,
1178 Make_Explicit_Dereference (Loc,
1179 Relocate_Node (Expression (N)))),
1180 Attribute_Name => Name_Address))));
1181
1182 else
1183 -- Generate: Operand_Typ!(Expression)'Address
1184
1185 Rewrite (N,
1186 Make_Function_Call (Loc,
1187 Name => New_Reference_To (Fent, Loc),
1188 Parameter_Associations => New_List (
1189 Make_Attribute_Reference (Loc,
1190 Prefix => Unchecked_Convert_To (Operand_Typ,
1191 Relocate_Node (Expression (N))),
1192 Attribute_Name => Name_Address))));
1193 end if;
1194 end if;
1195
1196 Analyze (N);
1197 end Expand_Interface_Conversion;
1198
1199 ------------------------------
1200 -- Expand_Interface_Actuals --
1201 ------------------------------
1202
1203 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1204 Loc : constant Source_Ptr := Sloc (Call_Node);
1205 Actual : Node_Id;
1206 Actual_Dup : Node_Id;
1207 Actual_Typ : Entity_Id;
1208 Anon : Entity_Id;
1209 Conversion : Node_Id;
1210 Formal : Entity_Id;
1211 Formal_Typ : Entity_Id;
1212 Subp : Entity_Id;
1213 Nam : Name_Id;
1214 Formal_DDT : Entity_Id;
1215 Actual_DDT : Entity_Id;
1216
1217 begin
1218 -- This subprogram is called directly from the semantics, so we need a
1219 -- check to see whether expansion is active before proceeding.
1220
1221 if not Expander_Active then
1222 return;
1223 end if;
1224
1225 -- Call using access to subprogram with explicit dereference
1226
1227 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1228 Subp := Etype (Name (Call_Node));
1229
1230 -- Normal case
1231
1232 else
1233 Subp := Entity (Name (Call_Node));
1234 end if;
1235
1236 Formal := First_Formal (Subp);
1237 Actual := First_Actual (Call_Node);
1238 while Present (Formal) loop
1239
1240 -- Ada 2005 (AI-251): Conversion to interface to force "this"
1241 -- displacement.
1242
1243 Formal_Typ := Etype (Etype (Formal));
1244
1245 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1246 Formal_Typ := Full_View (Formal_Typ);
1247 end if;
1248
1249 if Is_Access_Type (Formal_Typ) then
1250 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1251 end if;
1252
1253 Actual_Typ := Etype (Actual);
1254
1255 if Is_Access_Type (Actual_Typ) then
1256 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1257 end if;
1258
1259 if Is_Interface (Formal_Typ) then
1260
1261 -- No need to displace the pointer if the type of the actual
1262 -- is class-wide of the formal-type interface; in this case the
1263 -- displacement of the pointer was already done at the point of
1264 -- the call to the enclosing subprogram. This case corresponds
1265 -- with the call to P (Obj) in the following example:
1266
1267 -- type I is interface;
1268 -- procedure P (X : I) is abstract;
1269
1270 -- procedure General_Op (Obj : I'Class) is
1271 -- begin
1272 -- P (Obj);
1273 -- end General_Op;
1274
1275 if Is_Class_Wide_Type (Actual_Typ)
1276 and then Etype (Actual_Typ) = Formal_Typ
1277 then
1278 null;
1279
1280 -- No need to displace the pointer if the type of the actual is a
1281 -- derivation of the formal-type interface because in this case
1282 -- the interface primitives are located in the primary dispatch
1283 -- table.
1284
1285 elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
1286 null;
1287
1288 else
1289 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1290 Rewrite (Actual, Conversion);
1291 Analyze_And_Resolve (Actual, Formal_Typ);
1292 end if;
1293
1294 -- Anonymous access type
1295
1296 elsif Is_Access_Type (Formal_Typ)
1297 and then Is_Interface (Etype (Formal_DDT))
1298 and then Interface_Present_In_Ancestor
1299 (Typ => Actual_DDT,
1300 Iface => Etype (Formal_DDT))
1301 then
1302 if Nkind (Actual) = N_Attribute_Reference
1303 and then
1304 (Attribute_Name (Actual) = Name_Access
1305 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1306 then
1307 Nam := Attribute_Name (Actual);
1308
1309 Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
1310
1311 Rewrite (Actual, Conversion);
1312 Analyze_And_Resolve (Actual, Etype (Formal_DDT));
1313
1314 Rewrite (Actual,
1315 Unchecked_Convert_To (Formal_Typ,
1316 Make_Attribute_Reference (Loc,
1317 Prefix => Relocate_Node (Actual),
1318 Attribute_Name => Nam)));
1319
1320 Analyze_And_Resolve (Actual, Formal_Typ);
1321
1322 -- No need to displace the pointer if the actual is a class-wide
1323 -- type of the formal-type interface because in this case the
1324 -- displacement of the pointer was already done at the point of
1325 -- the call to the enclosing subprogram (this case is similar
1326 -- to the example described above for the non access-type case)
1327
1328 elsif Is_Class_Wide_Type (Actual_DDT)
1329 and then Etype (Actual_DDT) = Formal_DDT
1330 then
1331 null;
1332
1333 -- No need to displace the pointer if the type of the actual is a
1334 -- derivation of the interface (because in this case the interface
1335 -- primitives are located in the primary dispatch table)
1336
1337 elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
1338 null;
1339
1340 else
1341 Actual_Dup := Relocate_Node (Actual);
1342
1343 if From_With_Type (Actual_Typ) then
1344
1345 -- If the type of the actual parameter comes from a limited
1346 -- with-clause and the non-limited view is already available
1347 -- we replace the anonymous access type by a duplicate decla
1348 -- ration whose designated type is the non-limited view
1349
1350 if Ekind (Actual_DDT) = E_Incomplete_Type
1351 and then Present (Non_Limited_View (Actual_DDT))
1352 then
1353 Anon := New_Copy (Actual_Typ);
1354
1355 if Is_Itype (Anon) then
1356 Set_Scope (Anon, Current_Scope);
1357 end if;
1358
1359 Set_Directly_Designated_Type (Anon,
1360 Non_Limited_View (Actual_DDT));
1361 Set_Etype (Actual_Dup, Anon);
1362
1363 elsif Is_Class_Wide_Type (Actual_DDT)
1364 and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1365 and then Present (Non_Limited_View (Etype (Actual_DDT)))
1366 then
1367 Anon := New_Copy (Actual_Typ);
1368
1369 if Is_Itype (Anon) then
1370 Set_Scope (Anon, Current_Scope);
1371 end if;
1372
1373 Set_Directly_Designated_Type (Anon,
1374 New_Copy (Actual_DDT));
1375 Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1376 New_Copy (Class_Wide_Type (Actual_DDT)));
1377 Set_Etype (Directly_Designated_Type (Anon),
1378 Non_Limited_View (Etype (Actual_DDT)));
1379 Set_Etype (
1380 Class_Wide_Type (Directly_Designated_Type (Anon)),
1381 Non_Limited_View (Etype (Actual_DDT)));
1382 Set_Etype (Actual_Dup, Anon);
1383 end if;
1384 end if;
1385
1386 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1387 Rewrite (Actual, Conversion);
1388 Analyze_And_Resolve (Actual, Formal_Typ);
1389 end if;
1390 end if;
1391
1392 Next_Actual (Actual);
1393 Next_Formal (Formal);
1394 end loop;
1395 end Expand_Interface_Actuals;
1396
1397 ----------------------------
1398 -- Expand_Interface_Thunk --
1399 ----------------------------
1400
1401 function Expand_Interface_Thunk
1402 (N : Node_Id;
1403 Thunk_Alias : Entity_Id;
1404 Thunk_Id : Entity_Id) return Node_Id
1405 is
1406 Loc : constant Source_Ptr := Sloc (N);
1407 Actuals : constant List_Id := New_List;
1408 Decl : constant List_Id := New_List;
1409 Formals : constant List_Id := New_List;
1410 Target : Entity_Id;
1411 New_Code : Node_Id;
1412 Formal : Node_Id;
1413 New_Formal : Node_Id;
1414 Decl_1 : Node_Id;
1415 Decl_2 : Node_Id;
1416 E : Entity_Id;
1417
1418 begin
1419 -- Traverse the list of alias to find the final target
1420
1421 Target := Thunk_Alias;
1422 while Present (Alias (Target)) loop
1423 Target := Alias (Target);
1424 end loop;
1425
1426 -- Duplicate the formals
1427
1428 Formal := First_Formal (Target);
1429 E := First_Formal (N);
1430 while Present (Formal) loop
1431 New_Formal := Copy_Separate_Tree (Parent (Formal));
1432
1433 -- Propagate the parameter type to the copy. This is required to
1434 -- properly handle the case in which the subprogram covering the
1435 -- interface has been inherited:
1436
1437 -- Example:
1438 -- type I is interface;
1439 -- procedure P (X : I) is abstract;
1440
1441 -- type T is tagged null record;
1442 -- procedure P (X : T);
1443
1444 -- type DT is new T and I with ...
1445
1446 Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
1447 Append_To (Formals, New_Formal);
1448
1449 Next_Formal (Formal);
1450 Next_Formal (E);
1451 end loop;
1452
1453 -- Give message if configurable run-time and Offset_To_Top unavailable
1454
1455 if not RTE_Available (RE_Offset_To_Top) then
1456 Error_Msg_CRT ("abstract interface types", N);
1457 return Empty;
1458 end if;
1459
1460 if Ekind (First_Formal (Target)) = E_In_Parameter
1461 and then Ekind (Etype (First_Formal (Target)))
1462 = E_Anonymous_Access_Type
1463 then
1464 -- Generate:
1465
1466 -- type T is access all <<type of the first formal>>
1467 -- S1 := Storage_Offset!(First_formal)
1468 -- - Offset_To_Top (First_Formal.Tag)
1469
1470 -- ... and the first actual of the call is generated as T!(S1)
1471
1472 Decl_2 :=
1473 Make_Full_Type_Declaration (Loc,
1474 Defining_Identifier =>
1475 Make_Defining_Identifier (Loc,
1476 New_Internal_Name ('T')),
1477 Type_Definition =>
1478 Make_Access_To_Object_Definition (Loc,
1479 All_Present => True,
1480 Null_Exclusion_Present => False,
1481 Constant_Present => False,
1482 Subtype_Indication =>
1483 New_Reference_To
1484 (Directly_Designated_Type
1485 (Etype (First_Formal (Target))), Loc)));
1486
1487 Decl_1 :=
1488 Make_Object_Declaration (Loc,
1489 Defining_Identifier =>
1490 Make_Defining_Identifier (Loc,
1491 New_Internal_Name ('S')),
1492 Constant_Present => True,
1493 Object_Definition =>
1494 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1495 Expression =>
1496 Make_Op_Subtract (Loc,
1497 Left_Opnd =>
1498 Unchecked_Convert_To
1499 (RTE (RE_Storage_Offset),
1500 New_Reference_To
1501 (Defining_Identifier (First (Formals)), Loc)),
1502 Right_Opnd =>
1503 Make_Function_Call (Loc,
1504 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1505 Parameter_Associations => New_List (
1506 Unchecked_Convert_To
1507 (RTE (RE_Address),
1508 New_Reference_To
1509 (Defining_Identifier (First (Formals)), Loc))))));
1510
1511 Append_To (Decl, Decl_2);
1512 Append_To (Decl, Decl_1);
1513
1514 -- Reference the new first actual
1515
1516 Append_To (Actuals,
1517 Unchecked_Convert_To
1518 (Defining_Identifier (Decl_2),
1519 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1520
1521 else
1522 -- Generate:
1523
1524 -- S1 := Storage_Offset!(First_formal'Address)
1525 -- - Offset_To_Top (First_Formal.Tag)
1526 -- S2 := Tag_Ptr!(S3)
1527
1528 Decl_1 :=
1529 Make_Object_Declaration (Loc,
1530 Defining_Identifier =>
1531 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1532 Constant_Present => True,
1533 Object_Definition =>
1534 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1535 Expression =>
1536 Make_Op_Subtract (Loc,
1537 Left_Opnd =>
1538 Unchecked_Convert_To
1539 (RTE (RE_Storage_Offset),
1540 Make_Attribute_Reference (Loc,
1541 Prefix =>
1542 New_Reference_To
1543 (Defining_Identifier (First (Formals)), Loc),
1544 Attribute_Name => Name_Address)),
1545 Right_Opnd =>
1546 Make_Function_Call (Loc,
1547 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1548 Parameter_Associations => New_List (
1549 Make_Attribute_Reference (Loc,
1550 Prefix => New_Reference_To
1551 (Defining_Identifier (First (Formals)),
1552 Loc),
1553 Attribute_Name => Name_Address)))));
1554
1555 Decl_2 :=
1556 Make_Object_Declaration (Loc,
1557 Defining_Identifier =>
1558 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1559 Constant_Present => True,
1560 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1561 Expression =>
1562 Unchecked_Convert_To
1563 (RTE (RE_Addr_Ptr),
1564 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1565
1566 Append_To (Decl, Decl_1);
1567 Append_To (Decl, Decl_2);
1568
1569 -- Reference the new first actual
1570
1571 Append_To (Actuals,
1572 Unchecked_Convert_To
1573 (Etype (First_Entity (Target)),
1574 Make_Explicit_Dereference (Loc,
1575 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1576 end if;
1577
1578 Formal := Next (First (Formals));
1579 while Present (Formal) loop
1580 Append_To (Actuals,
1581 New_Reference_To (Defining_Identifier (Formal), Loc));
1582 Next (Formal);
1583 end loop;
1584
1585 if Ekind (Target) = E_Procedure then
1586 New_Code :=
1587 Make_Subprogram_Body (Loc,
1588 Specification =>
1589 Make_Procedure_Specification (Loc,
1590 Defining_Unit_Name => Thunk_Id,
1591 Parameter_Specifications => Formals),
1592 Declarations => Decl,
1593 Handled_Statement_Sequence =>
1594 Make_Handled_Sequence_Of_Statements (Loc,
1595 Statements => New_List (
1596 Make_Procedure_Call_Statement (Loc,
1597 Name => New_Occurrence_Of (Target, Loc),
1598 Parameter_Associations => Actuals))));
1599
1600 else pragma Assert (Ekind (Target) = E_Function);
1601
1602 New_Code :=
1603 Make_Subprogram_Body (Loc,
1604 Specification =>
1605 Make_Function_Specification (Loc,
1606 Defining_Unit_Name => Thunk_Id,
1607 Parameter_Specifications => Formals,
1608 Result_Definition =>
1609 New_Copy (Result_Definition (Parent (Target)))),
1610 Declarations => Decl,
1611 Handled_Statement_Sequence =>
1612 Make_Handled_Sequence_Of_Statements (Loc,
1613 Statements => New_List (
1614 Make_Return_Statement (Loc,
1615 Make_Function_Call (Loc,
1616 Name => New_Occurrence_Of (Target, Loc),
1617 Parameter_Associations => Actuals)))));
1618 end if;
1619
1620 -- Analyze the code of the thunk with checks suppressed because we are
1621 -- in the middle of building the dispatch information itself and some
1622 -- characteristics of the type may not be fully available.
1623
1624 Analyze (New_Code, Suppress => All_Checks);
1625 return New_Code;
1626 end Expand_Interface_Thunk;
1627
1628 -------------------
1629 -- Fill_DT_Entry --
1630 -------------------
1631
1632 function Fill_DT_Entry
1633 (Loc : Source_Ptr;
1634 Prim : Entity_Id) return Node_Id
1635 is
1636 Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
1637 DT_Ptr : constant Entity_Id :=
1638 Node (First_Elmt (Access_Disp_Table (Typ)));
1639 Pos : constant Uint := DT_Position (Prim);
1640 Tag : constant Entity_Id := First_Tag_Component (Typ);
1641
1642 begin
1643 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1644
1645 if Is_Predefined_Dispatching_Operation (Prim)
1646 or else Is_Predefined_Dispatching_Alias (Prim)
1647 then
1648 return
1649 Make_DT_Access_Action (Typ,
1650 Action => Set_Predefined_Prim_Op_Address,
1651 Args => New_List (
1652 Unchecked_Convert_To (RTE (RE_Tag),
1653 New_Reference_To (DT_Ptr, Loc)), -- DTptr
1654
1655 Make_Integer_Literal (Loc, Pos), -- Position
1656
1657 Make_Attribute_Reference (Loc, -- Value
1658 Prefix => New_Reference_To (Prim, Loc),
1659 Attribute_Name => Name_Address)));
1660 else
1661 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
1662
1663 return
1664 Make_DT_Access_Action (Typ,
1665 Action => Set_Prim_Op_Address,
1666 Args => New_List (
1667 Unchecked_Convert_To (RTE (RE_Tag),
1668 New_Reference_To (DT_Ptr, Loc)), -- DTptr
1669
1670 Make_Integer_Literal (Loc, Pos), -- Position
1671
1672 Make_Attribute_Reference (Loc, -- Value
1673 Prefix => New_Reference_To (Prim, Loc),
1674 Attribute_Name => Name_Address)));
1675 end if;
1676 end Fill_DT_Entry;
1677
1678 -----------------------------
1679 -- Fill_Secondary_DT_Entry --
1680 -----------------------------
1681
1682 function Fill_Secondary_DT_Entry
1683 (Loc : Source_Ptr;
1684 Prim : Entity_Id;
1685 Thunk_Id : Entity_Id;
1686 Iface_DT_Ptr : Entity_Id) return Node_Id
1687 is
1688 Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
1689 Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
1690 Pos : constant Uint := DT_Position (Iface_Prim);
1691 Tag : constant Entity_Id :=
1692 First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
1693
1694 begin
1695 if Is_Predefined_Dispatching_Operation (Prim)
1696 or else Is_Predefined_Dispatching_Alias (Prim)
1697 then
1698 return
1699 Make_DT_Access_Action (Typ,
1700 Action => Set_Predefined_Prim_Op_Address,
1701 Args => New_List (
1702 Unchecked_Convert_To (RTE (RE_Tag),
1703 New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
1704
1705 Make_Integer_Literal (Loc, Pos), -- Position
1706
1707 Make_Attribute_Reference (Loc, -- Value
1708 Prefix => New_Reference_To (Thunk_Id, Loc),
1709 Attribute_Name => Name_Address)));
1710 else
1711 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
1712
1713 return
1714 Make_DT_Access_Action (Typ,
1715 Action => Set_Prim_Op_Address,
1716 Args => New_List (
1717 Unchecked_Convert_To (RTE (RE_Tag),
1718 New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
1719
1720 Make_Integer_Literal (Loc, Pos), -- Position
1721
1722 Make_Attribute_Reference (Loc, -- Value
1723 Prefix => New_Reference_To (Thunk_Id, Loc),
1724 Attribute_Name => Name_Address)));
1725 end if;
1726 end Fill_Secondary_DT_Entry;
1727
1728 ---------------------------
1729 -- Get_Remotely_Callable --
1730 ---------------------------
1731
1732 function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
1733 Loc : constant Source_Ptr := Sloc (Obj);
1734 begin
1735 return Make_DT_Access_Action
1736 (Typ => Etype (Obj),
1737 Action => Get_Remotely_Callable,
1738 Args => New_List (
1739 Make_Selected_Component (Loc,
1740 Prefix => Obj,
1741 Selector_Name => Make_Identifier (Loc, Name_uTag))));
1742 end Get_Remotely_Callable;
1743
1744 ------------------------------------------
1745 -- Init_Predefined_Interface_Primitives --
1746 ------------------------------------------
1747
1748 function Init_Predefined_Interface_Primitives
1749 (Typ : Entity_Id) return List_Id
1750 is
1751 Loc : constant Source_Ptr := Sloc (Typ);
1752 DT_Ptr : constant Node_Id :=
1753 Node (First_Elmt (Access_Disp_Table (Typ)));
1754 Result : constant List_Id := New_List;
1755 AI : Elmt_Id;
1756
1757 begin
1758 -- No need to inherit primitives if we have an abstract interface
1759 -- type or a concurrent type.
1760
1761 if Is_Interface (Typ)
1762 or else Is_Concurrent_Record_Type (Typ)
1763 or else Restriction_Active (No_Dispatching_Calls)
1764 then
1765 return Result;
1766 end if;
1767
1768 AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
1769 while Present (AI) loop
1770
1771 -- All the secondary tables inherit the dispatch table entries
1772 -- associated with predefined primitives.
1773
1774 -- Generate:
1775 -- Inherit_DT (T'Tag, Iface'Tag, 0);
1776
1777 Append_To (Result,
1778 Make_DT_Access_Action (Typ,
1779 Action => Inherit_DT,
1780 Args => New_List (
1781 Node1 => New_Reference_To (DT_Ptr, Loc),
1782 Node2 => Unchecked_Convert_To (RTE (RE_Tag),
1783 New_Reference_To (Node (AI), Loc)),
1784 Node3 => Make_Integer_Literal (Loc, Uint_0))));
1785
1786 Next_Elmt (AI);
1787 end loop;
1788
1789 return Result;
1790 end Init_Predefined_Interface_Primitives;
1791
1792 -------------------------------------
1793 -- Is_Predefined_Dispatching_Alias --
1794 -------------------------------------
1795
1796 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1797 is
1798 E : Entity_Id;
1799
1800 begin
1801 if not Is_Predefined_Dispatching_Operation (Prim)
1802 and then Present (Alias (Prim))
1803 then
1804 E := Prim;
1805 while Present (Alias (E)) loop
1806 E := Alias (E);
1807 end loop;
1808
1809 if Is_Predefined_Dispatching_Operation (E) then
1810 return True;
1811 end if;
1812 end if;
1813
1814 return False;
1815 end Is_Predefined_Dispatching_Alias;
1816
1817 ----------------------------------------
1818 -- Make_Disp_Asynchronous_Select_Body --
1819 ----------------------------------------
1820
1821 function Make_Disp_Asynchronous_Select_Body
1822 (Typ : Entity_Id) return Node_Id
1823 is
1824 Conc_Typ : Entity_Id := Empty;
1825 Decls : constant List_Id := New_List;
1826 DT_Ptr : Entity_Id;
1827 Loc : constant Source_Ptr := Sloc (Typ);
1828 Stmts : constant List_Id := New_List;
1829
1830 begin
1831 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1832
1833 -- Null body is generated for interface types
1834
1835 if Is_Interface (Typ) then
1836 return
1837 Make_Subprogram_Body (Loc,
1838 Specification =>
1839 Make_Disp_Asynchronous_Select_Spec (Typ),
1840 Declarations =>
1841 New_List,
1842 Handled_Statement_Sequence =>
1843 Make_Handled_Sequence_Of_Statements (Loc,
1844 New_List (Make_Null_Statement (Loc))));
1845 end if;
1846
1847 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1848
1849 if Is_Concurrent_Record_Type (Typ) then
1850 Conc_Typ := Corresponding_Concurrent_Type (Typ);
1851
1852 -- Generate:
1853 -- I : Integer := Get_Entry_Index (tag! (<type>VP), S);
1854
1855 -- where I will be used to capture the entry index of the primitive
1856 -- wrapper at position S.
1857
1858 Append_To (Decls,
1859 Make_Object_Declaration (Loc,
1860 Defining_Identifier =>
1861 Make_Defining_Identifier (Loc, Name_uI),
1862 Object_Definition =>
1863 New_Reference_To (Standard_Integer, Loc),
1864 Expression =>
1865 Make_DT_Access_Action (Typ,
1866 Action =>
1867 Get_Entry_Index,
1868 Args =>
1869 New_List (
1870 Unchecked_Convert_To (RTE (RE_Tag),
1871 New_Reference_To (DT_Ptr, Loc)),
1872 Make_Identifier (Loc, Name_uS)))));
1873
1874 if Ekind (Conc_Typ) = E_Protected_Type then
1875
1876 -- Generate:
1877 -- Protected_Entry_Call (
1878 -- T._object'access,
1879 -- protected_entry_index! (I),
1880 -- P,
1881 -- Asynchronous_Call,
1882 -- B);
1883
1884 -- where T is the protected object, I is the entry index, P are
1885 -- the wrapped parameters and B is the name of the communication
1886 -- block.
1887
1888 Append_To (Stmts,
1889 Make_Procedure_Call_Statement (Loc,
1890 Name =>
1891 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1892 Parameter_Associations =>
1893 New_List (
1894
1895 Make_Attribute_Reference (Loc, -- T._object'access
1896 Attribute_Name =>
1897 Name_Unchecked_Access,
1898 Prefix =>
1899 Make_Selected_Component (Loc,
1900 Prefix =>
1901 Make_Identifier (Loc, Name_uT),
1902 Selector_Name =>
1903 Make_Identifier (Loc, Name_uObject))),
1904
1905 Make_Unchecked_Type_Conversion (Loc, -- entry index
1906 Subtype_Mark =>
1907 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1908 Expression =>
1909 Make_Identifier (Loc, Name_uI)),
1910
1911 Make_Identifier (Loc, Name_uP), -- parameter block
1912 New_Reference_To ( -- Asynchronous_Call
1913 RTE (RE_Asynchronous_Call), Loc),
1914 Make_Identifier (Loc, Name_uB)))); -- comm block
1915 else
1916 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1917
1918 -- Generate:
1919 -- Protected_Entry_Call (
1920 -- T._task_id,
1921 -- task_entry_index! (I),
1922 -- P,
1923 -- Conditional_Call,
1924 -- F);
1925
1926 -- where T is the task object, I is the entry index, P are the
1927 -- wrapped parameters and F is the status flag.
1928
1929 Append_To (Stmts,
1930 Make_Procedure_Call_Statement (Loc,
1931 Name =>
1932 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1933 Parameter_Associations =>
1934 New_List (
1935
1936 Make_Selected_Component (Loc, -- T._task_id
1937 Prefix =>
1938 Make_Identifier (Loc, Name_uT),
1939 Selector_Name =>
1940 Make_Identifier (Loc, Name_uTask_Id)),
1941
1942 Make_Unchecked_Type_Conversion (Loc, -- entry index
1943 Subtype_Mark =>
1944 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1945 Expression =>
1946 Make_Identifier (Loc, Name_uI)),
1947
1948 Make_Identifier (Loc, Name_uP), -- parameter block
1949 New_Reference_To ( -- Asynchronous_Call
1950 RTE (RE_Asynchronous_Call), Loc),
1951 Make_Identifier (Loc, Name_uF)))); -- status flag
1952 end if;
1953 end if;
1954
1955 return
1956 Make_Subprogram_Body (Loc,
1957 Specification =>
1958 Make_Disp_Asynchronous_Select_Spec (Typ),
1959 Declarations =>
1960 Decls,
1961 Handled_Statement_Sequence =>
1962 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1963 end Make_Disp_Asynchronous_Select_Body;
1964
1965 ----------------------------------------
1966 -- Make_Disp_Asynchronous_Select_Spec --
1967 ----------------------------------------
1968
1969 function Make_Disp_Asynchronous_Select_Spec
1970 (Typ : Entity_Id) return Node_Id
1971 is
1972 Loc : constant Source_Ptr := Sloc (Typ);
1973 Def_Id : constant Node_Id :=
1974 Make_Defining_Identifier (Loc,
1975 Name_uDisp_Asynchronous_Select);
1976 Params : constant List_Id := New_List;
1977
1978 begin
1979 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1980
1981 -- "T" - Object parameter
1982 -- "S" - Primitive operation slot
1983 -- "P" - Wrapped parameters
1984 -- "B" - Communication block
1985 -- "F" - Status flag
1986
1987 SEU.Build_T (Loc, Typ, Params);
1988 SEU.Build_S (Loc, Params);
1989 SEU.Build_P (Loc, Params);
1990 SEU.Build_B (Loc, Params);
1991 SEU.Build_F (Loc, Params);
1992
1993 Set_Is_Internal (Def_Id);
1994
1995 return
1996 Make_Procedure_Specification (Loc,
1997 Defining_Unit_Name => Def_Id,
1998 Parameter_Specifications => Params);
1999 end Make_Disp_Asynchronous_Select_Spec;
2000
2001 ---------------------------------------
2002 -- Make_Disp_Conditional_Select_Body --
2003 ---------------------------------------
2004
2005 function Make_Disp_Conditional_Select_Body
2006 (Typ : Entity_Id) return Node_Id
2007 is
2008 Loc : constant Source_Ptr := Sloc (Typ);
2009 Blk_Nam : Entity_Id;
2010 Conc_Typ : Entity_Id := Empty;
2011 Decls : constant List_Id := New_List;
2012 DT_Ptr : Entity_Id;
2013 Stmts : constant List_Id := New_List;
2014
2015 begin
2016 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2017
2018 -- Null body is generated for interface types
2019
2020 if Is_Interface (Typ) then
2021 return
2022 Make_Subprogram_Body (Loc,
2023 Specification =>
2024 Make_Disp_Conditional_Select_Spec (Typ),
2025 Declarations =>
2026 No_List,
2027 Handled_Statement_Sequence =>
2028 Make_Handled_Sequence_Of_Statements (Loc,
2029 New_List (Make_Null_Statement (Loc))));
2030 end if;
2031
2032 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2033
2034 if Is_Concurrent_Record_Type (Typ) then
2035 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2036
2037 -- Generate:
2038 -- I : Integer;
2039
2040 -- where I will be used to capture the entry index of the primitive
2041 -- wrapper at position S.
2042
2043 Append_To (Decls,
2044 Make_Object_Declaration (Loc,
2045 Defining_Identifier =>
2046 Make_Defining_Identifier (Loc, Name_uI),
2047 Object_Definition =>
2048 New_Reference_To (Standard_Integer, Loc)));
2049
2050 -- Generate:
2051 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2052
2053 -- if C = POK_Procedure
2054 -- or else C = POK_Protected_Procedure
2055 -- or else C = POK_Task_Procedure;
2056 -- then
2057 -- F := True;
2058 -- return;
2059 -- end if;
2060
2061 SEU.Build_Common_Dispatching_Select_Statements
2062 (Loc, Typ, DT_Ptr, Stmts);
2063
2064 -- Generate:
2065 -- Bnn : Communication_Block;
2066
2067 -- where Bnn is the name of the communication block used in
2068 -- the call to Protected_Entry_Call.
2069
2070 Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
2071
2072 Append_To (Decls,
2073 Make_Object_Declaration (Loc,
2074 Defining_Identifier =>
2075 Blk_Nam,
2076 Object_Definition =>
2077 New_Reference_To (RTE (RE_Communication_Block), Loc)));
2078
2079 -- Generate:
2080 -- I := Get_Entry_Index (tag! (<type>VP), S);
2081
2082 -- I is the entry index and S is the dispatch table slot
2083
2084 Append_To (Stmts,
2085 Make_Assignment_Statement (Loc,
2086 Name =>
2087 Make_Identifier (Loc, Name_uI),
2088 Expression =>
2089 Make_DT_Access_Action (Typ,
2090 Action =>
2091 Get_Entry_Index,
2092 Args =>
2093 New_List (
2094 Unchecked_Convert_To (RTE (RE_Tag),
2095 New_Reference_To (DT_Ptr, Loc)),
2096 Make_Identifier (Loc, Name_uS)))));
2097
2098 if Ekind (Conc_Typ) = E_Protected_Type then
2099
2100 -- Generate:
2101 -- Protected_Entry_Call (
2102 -- T._object'access,
2103 -- protected_entry_index! (I),
2104 -- P,
2105 -- Conditional_Call,
2106 -- Bnn);
2107
2108 -- where T is the protected object, I is the entry index, P are
2109 -- the wrapped parameters and Bnn is the name of the communication
2110 -- block.
2111
2112 Append_To (Stmts,
2113 Make_Procedure_Call_Statement (Loc,
2114 Name =>
2115 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2116 Parameter_Associations =>
2117 New_List (
2118
2119 Make_Attribute_Reference (Loc, -- T._object'access
2120 Attribute_Name =>
2121 Name_Unchecked_Access,
2122 Prefix =>
2123 Make_Selected_Component (Loc,
2124 Prefix =>
2125 Make_Identifier (Loc, Name_uT),
2126 Selector_Name =>
2127 Make_Identifier (Loc, Name_uObject))),
2128
2129 Make_Unchecked_Type_Conversion (Loc, -- entry index
2130 Subtype_Mark =>
2131 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
2132 Expression =>
2133 Make_Identifier (Loc, Name_uI)),
2134
2135 Make_Identifier (Loc, Name_uP), -- parameter block
2136 New_Reference_To ( -- Conditional_Call
2137 RTE (RE_Conditional_Call), Loc),
2138 New_Reference_To ( -- Bnn
2139 Blk_Nam, Loc))));
2140
2141 -- Generate:
2142 -- F := not Cancelled (Bnn);
2143
2144 -- where F is the success flag. The status of Cancelled is negated
2145 -- in order to match the behaviour of the version for task types.
2146
2147 Append_To (Stmts,
2148 Make_Assignment_Statement (Loc,
2149 Name =>
2150 Make_Identifier (Loc, Name_uF),
2151 Expression =>
2152 Make_Op_Not (Loc,
2153 Right_Opnd =>
2154 Make_Function_Call (Loc,
2155 Name =>
2156 New_Reference_To (RTE (RE_Cancelled), Loc),
2157 Parameter_Associations =>
2158 New_List (
2159 New_Reference_To (Blk_Nam, Loc))))));
2160 else
2161 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2162
2163 -- Generate:
2164 -- Protected_Entry_Call (
2165 -- T._task_id,
2166 -- task_entry_index! (I),
2167 -- P,
2168 -- Conditional_Call,
2169 -- F);
2170
2171 -- where T is the task object, I is the entry index, P are the
2172 -- wrapped parameters and F is the status flag.
2173
2174 Append_To (Stmts,
2175 Make_Procedure_Call_Statement (Loc,
2176 Name =>
2177 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2178 Parameter_Associations =>
2179 New_List (
2180
2181 Make_Selected_Component (Loc, -- T._task_id
2182 Prefix =>
2183 Make_Identifier (Loc, Name_uT),
2184 Selector_Name =>
2185 Make_Identifier (Loc, Name_uTask_Id)),
2186
2187 Make_Unchecked_Type_Conversion (Loc, -- entry index
2188 Subtype_Mark =>
2189 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2190 Expression =>
2191 Make_Identifier (Loc, Name_uI)),
2192
2193 Make_Identifier (Loc, Name_uP), -- parameter block
2194 New_Reference_To ( -- Conditional_Call
2195 RTE (RE_Conditional_Call), Loc),
2196 Make_Identifier (Loc, Name_uF)))); -- status flag
2197 end if;
2198 end if;
2199
2200 return
2201 Make_Subprogram_Body (Loc,
2202 Specification =>
2203 Make_Disp_Conditional_Select_Spec (Typ),
2204 Declarations =>
2205 Decls,
2206 Handled_Statement_Sequence =>
2207 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2208 end Make_Disp_Conditional_Select_Body;
2209
2210 ---------------------------------------
2211 -- Make_Disp_Conditional_Select_Spec --
2212 ---------------------------------------
2213
2214 function Make_Disp_Conditional_Select_Spec
2215 (Typ : Entity_Id) return Node_Id
2216 is
2217 Loc : constant Source_Ptr := Sloc (Typ);
2218 Def_Id : constant Node_Id :=
2219 Make_Defining_Identifier (Loc,
2220 Name_uDisp_Conditional_Select);
2221 Params : constant List_Id := New_List;
2222
2223 begin
2224 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2225
2226 -- "T" - Object parameter
2227 -- "S" - Primitive operation slot
2228 -- "P" - Wrapped parameters
2229 -- "C" - Call kind
2230 -- "F" - Status flag
2231
2232 SEU.Build_T (Loc, Typ, Params);
2233 SEU.Build_S (Loc, Params);
2234 SEU.Build_P (Loc, Params);
2235 SEU.Build_C (Loc, Params);
2236 SEU.Build_F (Loc, Params);
2237
2238 Set_Is_Internal (Def_Id);
2239
2240 return
2241 Make_Procedure_Specification (Loc,
2242 Defining_Unit_Name => Def_Id,
2243 Parameter_Specifications => Params);
2244 end Make_Disp_Conditional_Select_Spec;
2245
2246 -------------------------------------
2247 -- Make_Disp_Get_Prim_Op_Kind_Body --
2248 -------------------------------------
2249
2250 function Make_Disp_Get_Prim_Op_Kind_Body
2251 (Typ : Entity_Id) return Node_Id
2252 is
2253 Loc : constant Source_Ptr := Sloc (Typ);
2254 DT_Ptr : Entity_Id;
2255
2256 begin
2257 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2258
2259 if Is_Interface (Typ) then
2260 return
2261 Make_Subprogram_Body (Loc,
2262 Specification =>
2263 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2264 Declarations =>
2265 New_List,
2266 Handled_Statement_Sequence =>
2267 Make_Handled_Sequence_Of_Statements (Loc,
2268 New_List (Make_Null_Statement (Loc))));
2269 end if;
2270
2271 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2272
2273 -- Generate:
2274 -- C := get_prim_op_kind (tag! (<type>VP), S);
2275
2276 -- where C is the out parameter capturing the call kind and S is the
2277 -- dispatch table slot number.
2278
2279 return
2280 Make_Subprogram_Body (Loc,
2281 Specification =>
2282 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2283 Declarations =>
2284 New_List,
2285 Handled_Statement_Sequence =>
2286 Make_Handled_Sequence_Of_Statements (Loc,
2287 New_List (
2288 Make_Assignment_Statement (Loc,
2289 Name =>
2290 Make_Identifier (Loc, Name_uC),
2291 Expression =>
2292 Make_DT_Access_Action (Typ,
2293 Action =>
2294 Get_Prim_Op_Kind,
2295 Args =>
2296 New_List (
2297 Unchecked_Convert_To (RTE (RE_Tag),
2298 New_Reference_To (DT_Ptr, Loc)),
2299 Make_Identifier (Loc, Name_uS)))))));
2300 end Make_Disp_Get_Prim_Op_Kind_Body;
2301
2302 -------------------------------------
2303 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2304 -------------------------------------
2305
2306 function Make_Disp_Get_Prim_Op_Kind_Spec
2307 (Typ : Entity_Id) return Node_Id
2308 is
2309 Loc : constant Source_Ptr := Sloc (Typ);
2310 Def_Id : constant Node_Id :=
2311 Make_Defining_Identifier (Loc,
2312 Name_uDisp_Get_Prim_Op_Kind);
2313 Params : constant List_Id := New_List;
2314
2315 begin
2316 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2317
2318 -- "T" - Object parameter
2319 -- "S" - Primitive operation slot
2320 -- "C" - Call kind
2321
2322 SEU.Build_T (Loc, Typ, Params);
2323 SEU.Build_S (Loc, Params);
2324 SEU.Build_C (Loc, Params);
2325
2326 Set_Is_Internal (Def_Id);
2327
2328 return
2329 Make_Procedure_Specification (Loc,
2330 Defining_Unit_Name => Def_Id,
2331 Parameter_Specifications => Params);
2332 end Make_Disp_Get_Prim_Op_Kind_Spec;
2333
2334 --------------------------------
2335 -- Make_Disp_Get_Task_Id_Body --
2336 --------------------------------
2337
2338 function Make_Disp_Get_Task_Id_Body
2339 (Typ : Entity_Id) return Node_Id
2340 is
2341 Loc : constant Source_Ptr := Sloc (Typ);
2342 Ret : Node_Id;
2343
2344 begin
2345 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2346
2347 if Is_Concurrent_Record_Type (Typ)
2348 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2349 then
2350 Ret :=
2351 Make_Return_Statement (Loc,
2352 Expression =>
2353 Make_Selected_Component (Loc,
2354 Prefix =>
2355 Make_Identifier (Loc, Name_uT),
2356 Selector_Name =>
2357 Make_Identifier (Loc, Name_uTask_Id)));
2358
2359 -- A null body is constructed for non-task types
2360
2361 else
2362 Ret :=
2363 Make_Return_Statement (Loc,
2364 Expression =>
2365 New_Reference_To (RTE (RO_ST_Null_Task), Loc));
2366 end if;
2367
2368 return
2369 Make_Subprogram_Body (Loc,
2370 Specification =>
2371 Make_Disp_Get_Task_Id_Spec (Typ),
2372 Declarations =>
2373 New_List,
2374 Handled_Statement_Sequence =>
2375 Make_Handled_Sequence_Of_Statements (Loc,
2376 New_List (Ret)));
2377 end Make_Disp_Get_Task_Id_Body;
2378
2379 --------------------------------
2380 -- Make_Disp_Get_Task_Id_Spec --
2381 --------------------------------
2382
2383 function Make_Disp_Get_Task_Id_Spec
2384 (Typ : Entity_Id) return Node_Id
2385 is
2386 Loc : constant Source_Ptr := Sloc (Typ);
2387 Def_Id : constant Node_Id :=
2388 Make_Defining_Identifier (Loc,
2389 Name_uDisp_Get_Task_Id);
2390
2391 begin
2392 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2393
2394 Set_Is_Internal (Def_Id);
2395
2396 return
2397 Make_Function_Specification (Loc,
2398 Defining_Unit_Name => Def_Id,
2399 Parameter_Specifications => New_List (
2400 Make_Parameter_Specification (Loc,
2401 Defining_Identifier =>
2402 Make_Defining_Identifier (Loc, Name_uT),
2403 Parameter_Type =>
2404 New_Reference_To (Typ, Loc))),
2405 Result_Definition =>
2406 New_Reference_To (RTE (RO_ST_Task_Id), Loc));
2407 end Make_Disp_Get_Task_Id_Spec;
2408
2409 ---------------------------------
2410 -- Make_Disp_Timed_Select_Body --
2411 ---------------------------------
2412
2413 function Make_Disp_Timed_Select_Body
2414 (Typ : Entity_Id) return Node_Id
2415 is
2416 Loc : constant Source_Ptr := Sloc (Typ);
2417 Conc_Typ : Entity_Id := Empty;
2418 Decls : constant List_Id := New_List;
2419 DT_Ptr : Entity_Id;
2420 Stmts : constant List_Id := New_List;
2421
2422 begin
2423 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2424
2425 -- Null body is generated for interface types
2426
2427 if Is_Interface (Typ) then
2428 return
2429 Make_Subprogram_Body (Loc,
2430 Specification =>
2431 Make_Disp_Timed_Select_Spec (Typ),
2432 Declarations =>
2433 New_List,
2434 Handled_Statement_Sequence =>
2435 Make_Handled_Sequence_Of_Statements (Loc,
2436 New_List (Make_Null_Statement (Loc))));
2437 end if;
2438
2439 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2440
2441 if Is_Concurrent_Record_Type (Typ) then
2442 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2443
2444 -- Generate:
2445 -- I : Integer;
2446
2447 -- where I will be used to capture the entry index of the primitive
2448 -- wrapper at position S.
2449
2450 Append_To (Decls,
2451 Make_Object_Declaration (Loc,
2452 Defining_Identifier =>
2453 Make_Defining_Identifier (Loc, Name_uI),
2454 Object_Definition =>
2455 New_Reference_To (Standard_Integer, Loc)));
2456
2457 -- Generate:
2458 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2459
2460 -- if C = POK_Procedure
2461 -- or else C = POK_Protected_Procedure
2462 -- or else C = POK_Task_Procedure;
2463 -- then
2464 -- F := True;
2465 -- return;
2466 -- end if;
2467
2468 SEU.Build_Common_Dispatching_Select_Statements
2469 (Loc, Typ, DT_Ptr, Stmts);
2470
2471 -- Generate:
2472 -- I := Get_Entry_Index (tag! (<type>VP), S);
2473
2474 -- I is the entry index and S is the dispatch table slot
2475
2476 Append_To (Stmts,
2477 Make_Assignment_Statement (Loc,
2478 Name =>
2479 Make_Identifier (Loc, Name_uI),
2480 Expression =>
2481 Make_DT_Access_Action (Typ,
2482 Action =>
2483 Get_Entry_Index,
2484 Args =>
2485 New_List (
2486 Unchecked_Convert_To (RTE (RE_Tag),
2487 New_Reference_To (DT_Ptr, Loc)),
2488 Make_Identifier (Loc, Name_uS)))));
2489
2490 if Ekind (Conc_Typ) = E_Protected_Type then
2491
2492 -- Generate:
2493 -- Timed_Protected_Entry_Call (
2494 -- T._object'access,
2495 -- protected_entry_index! (I),
2496 -- P,
2497 -- D,
2498 -- M,
2499 -- F);
2500
2501 -- where T is the protected object, I is the entry index, P are
2502 -- the wrapped parameters, D is the delay amount, M is the delay
2503 -- mode and F is the status flag.
2504
2505 Append_To (Stmts,
2506 Make_Procedure_Call_Statement (Loc,
2507 Name =>
2508 New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
2509 Parameter_Associations =>
2510 New_List (
2511
2512 Make_Attribute_Reference (Loc, -- T._object'access
2513 Attribute_Name =>
2514 Name_Unchecked_Access,
2515 Prefix =>
2516 Make_Selected_Component (Loc,
2517 Prefix =>
2518 Make_Identifier (Loc, Name_uT),
2519 Selector_Name =>
2520 Make_Identifier (Loc, Name_uObject))),
2521
2522 Make_Unchecked_Type_Conversion (Loc, -- entry index
2523 Subtype_Mark =>
2524 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
2525 Expression =>
2526 Make_Identifier (Loc, Name_uI)),
2527
2528 Make_Identifier (Loc, Name_uP), -- parameter block
2529 Make_Identifier (Loc, Name_uD), -- delay
2530 Make_Identifier (Loc, Name_uM), -- delay mode
2531 Make_Identifier (Loc, Name_uF)))); -- status flag
2532
2533 else
2534 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2535
2536 -- Generate:
2537 -- Timed_Task_Entry_Call (
2538 -- T._task_id,
2539 -- task_entry_index! (I),
2540 -- P,
2541 -- D,
2542 -- M,
2543 -- F);
2544
2545 -- where T is the task object, I is the entry index, P are the
2546 -- wrapped parameters, D is the delay amount, M is the delay
2547 -- mode and F is the status flag.
2548
2549 Append_To (Stmts,
2550 Make_Procedure_Call_Statement (Loc,
2551 Name =>
2552 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2553 Parameter_Associations =>
2554 New_List (
2555
2556 Make_Selected_Component (Loc, -- T._task_id
2557 Prefix =>
2558 Make_Identifier (Loc, Name_uT),
2559 Selector_Name =>
2560 Make_Identifier (Loc, Name_uTask_Id)),
2561
2562 Make_Unchecked_Type_Conversion (Loc, -- entry index
2563 Subtype_Mark =>
2564 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2565 Expression =>
2566 Make_Identifier (Loc, Name_uI)),
2567
2568 Make_Identifier (Loc, Name_uP), -- parameter block
2569 Make_Identifier (Loc, Name_uD), -- delay
2570 Make_Identifier (Loc, Name_uM), -- delay mode
2571 Make_Identifier (Loc, Name_uF)))); -- status flag
2572 end if;
2573 end if;
2574
2575 return
2576 Make_Subprogram_Body (Loc,
2577 Specification =>
2578 Make_Disp_Timed_Select_Spec (Typ),
2579 Declarations =>
2580 Decls,
2581 Handled_Statement_Sequence =>
2582 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2583 end Make_Disp_Timed_Select_Body;
2584
2585 ---------------------------------
2586 -- Make_Disp_Timed_Select_Spec --
2587 ---------------------------------
2588
2589 function Make_Disp_Timed_Select_Spec
2590 (Typ : Entity_Id) return Node_Id
2591 is
2592 Loc : constant Source_Ptr := Sloc (Typ);
2593 Def_Id : constant Node_Id :=
2594 Make_Defining_Identifier (Loc,
2595 Name_uDisp_Timed_Select);
2596 Params : constant List_Id := New_List;
2597
2598 begin
2599 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2600
2601 -- "T" - Object parameter
2602 -- "S" - Primitive operation slot
2603 -- "P" - Wrapped parameters
2604 -- "D" - Delay
2605 -- "M" - Delay Mode
2606 -- "C" - Call kind
2607 -- "F" - Status flag
2608
2609 SEU.Build_T (Loc, Typ, Params);
2610 SEU.Build_S (Loc, Params);
2611 SEU.Build_P (Loc, Params);
2612
2613 Append_To (Params,
2614 Make_Parameter_Specification (Loc,
2615 Defining_Identifier =>
2616 Make_Defining_Identifier (Loc, Name_uD),
2617 Parameter_Type =>
2618 New_Reference_To (Standard_Duration, Loc)));
2619
2620 Append_To (Params,
2621 Make_Parameter_Specification (Loc,
2622 Defining_Identifier =>
2623 Make_Defining_Identifier (Loc, Name_uM),
2624 Parameter_Type =>
2625 New_Reference_To (Standard_Integer, Loc)));
2626
2627 SEU.Build_C (Loc, Params);
2628 SEU.Build_F (Loc, Params);
2629
2630 Set_Is_Internal (Def_Id);
2631
2632 return
2633 Make_Procedure_Specification (Loc,
2634 Defining_Unit_Name => Def_Id,
2635 Parameter_Specifications => Params);
2636 end Make_Disp_Timed_Select_Spec;
2637
2638 -------------
2639 -- Make_DT --
2640 -------------
2641
2642 function Make_DT (Typ : Entity_Id) return List_Id is
2643 Loc : constant Source_Ptr := Sloc (Typ);
2644 Result : constant List_Id := New_List;
2645 Elab_Code : constant List_Id := New_List;
2646
2647 Tname : constant Name_Id := Chars (Typ);
2648 Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
2649 Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
2650 Name_SSD : constant Name_Id := New_External_Name (Tname, 'S');
2651 Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
2652 Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
2653 Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
2654 Name_ITable : Name_Id;
2655
2656 DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
2657 DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
2658 SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD);
2659 TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
2660 Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
2661 No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
2662 ITable : Node_Id;
2663
2664 Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
2665 AI : Elmt_Id;
2666 I_Depth : Int;
2667 Nb_Prim : Int;
2668 Num_Ifaces : Int;
2669 Old_Tag1 : Node_Id;
2670 Old_Tag2 : Node_Id;
2671 Parent_Num_Ifaces : Int;
2672 Size_Expr_Node : Node_Id;
2673 TSD_Num_Entries : Int;
2674
2675 Empty_DT : Boolean := False;
2676
2677 Ancestor_Ifaces : Elist_Id;
2678 Typ_Ifaces : Elist_Id;
2679
2680 begin
2681 if not RTE_Available (RE_Tag) then
2682 Error_Msg_CRT ("tagged types", Typ);
2683 return New_List;
2684 end if;
2685
2686 -- Calculate the size of the DT and the TSD. First we count the number
2687 -- of interfaces implemented by the ancestors
2688
2689 Parent_Num_Ifaces := 0;
2690 Num_Ifaces := 0;
2691
2692 -- Count the abstract interfaces of the ancestors
2693
2694 if Typ /= Etype (Typ) then
2695 Collect_Abstract_Interfaces (Etype (Typ), Ancestor_Ifaces);
2696
2697 AI := First_Elmt (Ancestor_Ifaces);
2698 while Present (AI) loop
2699 Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
2700 Next_Elmt (AI);
2701 end loop;
2702 end if;
2703
2704 -- Count the number of additional interfaces implemented by Typ
2705
2706 Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
2707
2708 AI := First_Elmt (Typ_Ifaces);
2709 while Present (AI) loop
2710 Num_Ifaces := Num_Ifaces + 1;
2711 Next_Elmt (AI);
2712 end loop;
2713
2714 -- Count ancestors to compute the inheritance depth. For private
2715 -- extensions, always go to the full view in order to compute the
2716 -- real inheritance depth.
2717
2718 declare
2719 Parent_Type : Entity_Id := Typ;
2720 P : Entity_Id;
2721
2722 begin
2723 I_Depth := 0;
2724 loop
2725 P := Etype (Parent_Type);
2726
2727 if Is_Private_Type (P) then
2728 P := Full_View (Base_Type (P));
2729 end if;
2730
2731 exit when P = Parent_Type;
2732
2733 I_Depth := I_Depth + 1;
2734 Parent_Type := P;
2735 end loop;
2736 end;
2737
2738 -- Abstract interfaces don't need the DT. We reserve a single entry
2739 -- for its DT because at run-time the pointer to this dummy DT will
2740 -- be used as the tag of this abstract interface type. The table of
2741 -- interfaces is required to give support to AI-405
2742
2743 if Is_Interface (Typ) then
2744 Empty_DT := True;
2745 Nb_Prim := 1;
2746 TSD_Num_Entries := 0;
2747
2748 else
2749 TSD_Num_Entries := I_Depth + 1;
2750 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
2751
2752 -- If the number of primitives of Typ is 0 (or we are compiling
2753 -- with the No_Dispatching_Calls restriction) we reserve a dummy
2754 -- single entry for its DT because at run-time the pointer to this
2755 -- dummy DT will be used as the tag of this tagged type.
2756
2757 if Nb_Prim = 0
2758 or else Restriction_Active (No_Dispatching_Calls)
2759 then
2760 Empty_DT := True;
2761 Nb_Prim := 1;
2762 end if;
2763 end if;
2764
2765 -- Dispatch table and related entities are allocated statically
2766
2767 Set_Ekind (DT, E_Variable);
2768 Set_Is_Statically_Allocated (DT);
2769
2770 Set_Ekind (DT_Ptr, E_Variable);
2771 Set_Is_Statically_Allocated (DT_Ptr);
2772
2773 if Num_Ifaces > 0 then
2774 Name_ITable := New_External_Name (Tname, 'I');
2775 ITable := Make_Defining_Identifier (Loc, Name_ITable);
2776
2777 Set_Ekind (ITable, E_Variable);
2778 Set_Is_Statically_Allocated (ITable);
2779 end if;
2780
2781 Set_Ekind (SSD, E_Variable);
2782 Set_Is_Statically_Allocated (SSD);
2783
2784 Set_Ekind (TSD, E_Variable);
2785 Set_Is_Statically_Allocated (TSD);
2786
2787 Set_Ekind (Exname, E_Variable);
2788 Set_Is_Statically_Allocated (Exname);
2789
2790 Set_Ekind (No_Reg, E_Variable);
2791 Set_Is_Statically_Allocated (No_Reg);
2792
2793 -- Generate code to create the storage for the Dispatch_Table object:
2794
2795 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
2796 -- for DT'Alignment use Address'Alignment
2797
2798 Size_Expr_Node :=
2799 Make_Op_Add (Loc,
2800 Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
2801 Right_Opnd =>
2802 Make_Op_Multiply (Loc,
2803 Left_Opnd =>
2804 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
2805 Right_Opnd =>
2806 Make_Integer_Literal (Loc, Nb_Prim)));
2807
2808 Append_To (Result,
2809 Make_Object_Declaration (Loc,
2810 Defining_Identifier => DT,
2811 Aliased_Present => True,
2812 Object_Definition =>
2813 Make_Subtype_Indication (Loc,
2814 Subtype_Mark => New_Reference_To
2815 (RTE (RE_Storage_Array), Loc),
2816 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
2817 Constraints => New_List (
2818 Make_Range (Loc,
2819 Low_Bound => Make_Integer_Literal (Loc, 1),
2820 High_Bound => Size_Expr_Node))))));
2821
2822 Append_To (Result,
2823 Make_Attribute_Definition_Clause (Loc,
2824 Name => New_Reference_To (DT, Loc),
2825 Chars => Name_Alignment,
2826 Expression =>
2827 Make_Attribute_Reference (Loc,
2828 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
2829 Attribute_Name => Name_Alignment)));
2830
2831 -- Generate code to create the pointer to the dispatch table
2832
2833 -- DT_Ptr : Tag := Tag!(DT'Address);
2834
2835 -- According to the C++ ABI, the base of the vtable is located after a
2836 -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
2837 -- down the pointer to the real base of the vtable
2838
2839 Append_To (Result,
2840 Make_Object_Declaration (Loc,
2841 Defining_Identifier => DT_Ptr,
2842 Constant_Present => True,
2843 Object_Definition => New_Reference_To (Generalized_Tag, Loc),
2844 Expression =>
2845 Unchecked_Convert_To (Generalized_Tag,
2846 Make_Op_Add (Loc,
2847 Left_Opnd =>
2848 Unchecked_Convert_To (RTE (RE_Storage_Offset),
2849 Make_Attribute_Reference (Loc,
2850 Prefix => New_Reference_To (DT, Loc),
2851 Attribute_Name => Name_Address)),
2852 Right_Opnd =>
2853 Make_DT_Access_Action (Typ,
2854 DT_Prologue_Size, No_List)))));
2855
2856 -- Generate code to define the boolean that controls registration, in
2857 -- order to avoid multiple registrations for tagged types defined in
2858 -- multiple-called scopes.
2859
2860 Append_To (Result,
2861 Make_Object_Declaration (Loc,
2862 Defining_Identifier => No_Reg,
2863 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
2864 Expression => New_Reference_To (Standard_True, Loc)));
2865
2866 -- Set Access_Disp_Table field to be the dispatch table pointer
2867
2868 if No (Access_Disp_Table (Typ)) then
2869 Set_Access_Disp_Table (Typ, New_Elmt_List);
2870 end if;
2871
2872 Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
2873
2874 -- Generate code to create the storage for the type specific data object
2875 -- with enough space to store the tags of the ancestors plus the tags
2876 -- of all the implemented interfaces (as described in a-tags.adb).
2877
2878 -- TSD: Storage_Array
2879 -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
2880 -- for TSD'Alignment use Address'Alignment
2881
2882 Size_Expr_Node :=
2883 Make_Op_Add (Loc,
2884 Left_Opnd =>
2885 Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
2886 Right_Opnd =>
2887 Make_Op_Multiply (Loc,
2888 Left_Opnd =>
2889 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
2890 Right_Opnd =>
2891 Make_Integer_Literal (Loc, TSD_Num_Entries)));
2892
2893 Append_To (Result,
2894 Make_Object_Declaration (Loc,
2895 Defining_Identifier => TSD,
2896 Aliased_Present => True,
2897 Object_Definition =>
2898 Make_Subtype_Indication (Loc,
2899 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
2900 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
2901 Constraints => New_List (
2902 Make_Range (Loc,
2903 Low_Bound => Make_Integer_Literal (Loc, 1),
2904 High_Bound => Size_Expr_Node))))));
2905
2906 Append_To (Result,
2907 Make_Attribute_Definition_Clause (Loc,
2908 Name => New_Reference_To (TSD, Loc),
2909 Chars => Name_Alignment,
2910 Expression =>
2911 Make_Attribute_Reference (Loc,
2912 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
2913 Attribute_Name => Name_Alignment)));
2914
2915 -- Generate:
2916 -- Set_Signature (DT_Ptr, Value);
2917
2918 if RTE_Available (RE_Set_Signature) then
2919 if Is_Interface (Typ) then
2920 Append_To (Elab_Code,
2921 Make_DT_Access_Action (Typ,
2922 Action => Set_Signature,
2923 Args => New_List (
2924 New_Reference_To (DT_Ptr, Loc), -- DTptr
2925 New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
2926
2927 else
2928 Append_To (Elab_Code,
2929 Make_DT_Access_Action (Typ,
2930 Action => Set_Signature,
2931 Args => New_List (
2932 New_Reference_To (DT_Ptr, Loc), -- DTptr
2933 New_Reference_To (RTE (RE_Primary_DT), Loc))));
2934 end if;
2935 end if;
2936
2937 -- Generate code to put the Address of the TSD in the dispatch table
2938 -- Set_TSD (DT_Ptr, TSD);
2939
2940 Append_To (Elab_Code,
2941 Make_DT_Access_Action (Typ,
2942 Action => Set_TSD,
2943 Args => New_List (
2944 New_Reference_To (DT_Ptr, Loc), -- DTptr
2945 Make_Attribute_Reference (Loc, -- Value
2946 Prefix => New_Reference_To (TSD, Loc),
2947 Attribute_Name => Name_Address))));
2948
2949 -- Set the pointer to the Interfaces_Table (if any). Otherwise the
2950 -- corresponding access component is set to null.
2951
2952 if Num_Ifaces = 0 then
2953 if RTE_Available (RE_Set_Interface_Table) then
2954 Append_To (Elab_Code,
2955 Make_DT_Access_Action (Typ,
2956 Action => Set_Interface_Table,
2957 Args => New_List (
2958 New_Reference_To (DT_Ptr, Loc), -- DTptr
2959 New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null
2960 end if;
2961
2962 -- Generate the Interface_Table object and set the access
2963 -- component if the TSD to it.
2964
2965 elsif RTE_Available (RE_Set_Interface_Table) then
2966 Append_To (Result,
2967 Make_Object_Declaration (Loc,
2968 Defining_Identifier => ITable,
2969 Aliased_Present => True,
2970 Object_Definition =>
2971 Make_Subtype_Indication (Loc,
2972 Subtype_Mark => New_Reference_To
2973 (RTE (RE_Interface_Data), Loc),
2974 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
2975 Constraints => New_List (
2976 Make_Integer_Literal (Loc,
2977 Num_Ifaces))))));
2978
2979 Append_To (Elab_Code,
2980 Make_DT_Access_Action (Typ,
2981 Action => Set_Interface_Table,
2982 Args => New_List (
2983 New_Reference_To (DT_Ptr, Loc), -- DTptr
2984 Make_Attribute_Reference (Loc, -- Value
2985 Prefix => New_Reference_To (ITable, Loc),
2986 Attribute_Name => Name_Address))));
2987 end if;
2988
2989 -- Generate:
2990 -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
2991
2992 if RTE_Available (RE_Set_Num_Prim_Ops) then
2993 if not Is_Interface (Typ) then
2994 if Empty_DT then
2995 Append_To (Elab_Code,
2996 Make_Procedure_Call_Statement (Loc,
2997 Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
2998 Parameter_Associations => New_List (
2999 New_Reference_To (DT_Ptr, Loc),
3000 Make_Integer_Literal (Loc, Uint_0))));
3001 else
3002 Append_To (Elab_Code,
3003 Make_Procedure_Call_Statement (Loc,
3004 Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
3005 Parameter_Associations => New_List (
3006 New_Reference_To (DT_Ptr, Loc),
3007 Make_Integer_Literal (Loc, Nb_Prim))));
3008 end if;
3009 end if;
3010
3011 if Ada_Version >= Ada_05
3012 and then not Is_Interface (Typ)
3013 and then not Is_Abstract (Typ)
3014 and then not Is_Controlled (Typ)
3015 and then not Restriction_Active (No_Dispatching_Calls)
3016 then
3017 -- Generate:
3018 -- Set_Type_Kind (T'Tag, Type_Kind (Typ));
3019
3020 Append_To (Elab_Code,
3021 Make_DT_Access_Action (Typ,
3022 Action => Set_Tagged_Kind,
3023 Args => New_List (
3024 New_Reference_To (DT_Ptr, Loc), -- DTptr
3025 Tagged_Kind (Typ)))); -- Value
3026
3027 -- Generate the Select Specific Data table for synchronized
3028 -- types that implement a synchronized interface. The size
3029 -- of the table is constrained by the number of non-predefined
3030 -- primitive operations.
3031
3032 if not Empty_DT
3033 and then Is_Concurrent_Record_Type (Typ)
3034 and then Implements_Interface (
3035 Typ => Typ,
3036 Kind => Any_Limited_Interface,
3037 Check_Parent => True)
3038 then
3039 Append_To (Result,
3040 Make_Object_Declaration (Loc,
3041 Defining_Identifier => SSD,
3042 Aliased_Present => True,
3043 Object_Definition =>
3044 Make_Subtype_Indication (Loc,
3045 Subtype_Mark => New_Reference_To (
3046 RTE (RE_Select_Specific_Data), Loc),
3047 Constraint =>
3048 Make_Index_Or_Discriminant_Constraint (Loc,
3049 Constraints => New_List (
3050 Make_Integer_Literal (Loc, Nb_Prim))))));
3051
3052 -- Set the pointer to the Select Specific Data table in the TSD
3053
3054 Append_To (Elab_Code,
3055 Make_DT_Access_Action (Typ,
3056 Action => Set_SSD,
3057 Args => New_List (
3058 New_Reference_To (DT_Ptr, Loc), -- DTptr
3059 Make_Attribute_Reference (Loc, -- Value
3060 Prefix => New_Reference_To (SSD, Loc),
3061 Attribute_Name => Name_Address))));
3062 end if;
3063 end if;
3064 end if;
3065
3066 -- Generate: Exname : constant String := full_qualified_name (typ);
3067 -- The type itself may be an anonymous parent type, so use the first
3068 -- subtype to have a user-recognizable name.
3069
3070 Append_To (Result,
3071 Make_Object_Declaration (Loc,
3072 Defining_Identifier => Exname,
3073 Constant_Present => True,
3074 Object_Definition => New_Reference_To (Standard_String, Loc),
3075 Expression =>
3076 Make_String_Literal (Loc,
3077 Full_Qualified_Name (First_Subtype (Typ)))));
3078
3079 -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
3080
3081 Append_To (Elab_Code,
3082 Make_DT_Access_Action (Typ,
3083 Action => Set_Expanded_Name,
3084 Args => New_List (
3085 Node1 => New_Reference_To (DT_Ptr, Loc),
3086 Node2 =>
3087 Make_Attribute_Reference (Loc,
3088 Prefix => New_Reference_To (Exname, Loc),
3089 Attribute_Name => Name_Address))));
3090
3091 if not Is_Interface (Typ) then
3092 -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
3093
3094 Append_To (Elab_Code,
3095 Make_DT_Access_Action (Typ,
3096 Action => Set_Access_Level,
3097 Args => New_List (
3098 Node1 => New_Reference_To (DT_Ptr, Loc),
3099 Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
3100 end if;
3101
3102 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
3103 -- in the init proc, and we don't need to fill them in here.
3104
3105 if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
3106 null;
3107
3108 -- Otherwise we fill in the dispatch tables here
3109
3110 else
3111 if Typ = Etype (Typ)
3112 or else Is_CPP_Class (Etype (Typ))
3113 or else Is_Interface (Typ)
3114 then
3115 Old_Tag1 :=
3116 Unchecked_Convert_To (Generalized_Tag,
3117 Make_Integer_Literal (Loc, 0));
3118 Old_Tag2 :=
3119 Unchecked_Convert_To (Generalized_Tag,
3120 Make_Integer_Literal (Loc, 0));
3121
3122 else
3123 Old_Tag1 :=
3124 New_Reference_To
3125 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
3126 Old_Tag2 :=
3127 New_Reference_To
3128 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
3129 end if;
3130
3131 if Typ /= Etype (Typ)
3132 and then not Is_Interface (Typ)
3133 and then not Restriction_Active (No_Dispatching_Calls)
3134 then
3135 -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
3136
3137 if not Is_Interface (Etype (Typ)) then
3138 if Restriction_Active (No_Dispatching_Calls) then
3139 Append_To (Elab_Code,
3140 Make_DT_Access_Action (Typ,
3141 Action => Inherit_DT,
3142 Args => New_List (
3143 Node1 => Old_Tag1,
3144 Node2 => New_Reference_To (DT_Ptr, Loc),
3145 Node3 => Make_Integer_Literal (Loc, Uint_0))));
3146 else
3147 Append_To (Elab_Code,
3148 Make_DT_Access_Action (Typ,
3149 Action => Inherit_DT,
3150 Args => New_List (
3151 Node1 => Old_Tag1,
3152 Node2 => New_Reference_To (DT_Ptr, Loc),
3153 Node3 => Make_Integer_Literal (Loc,
3154 DT_Entry_Count
3155 (First_Tag_Component (Etype (Typ)))))));
3156 end if;
3157 end if;
3158
3159 -- Inherit the secondary dispatch tables of the ancestor
3160
3161 if not Restriction_Active (No_Dispatching_Calls)
3162 and then not Is_CPP_Class (Etype (Typ))
3163 then
3164 declare
3165 Sec_DT_Ancestor : Elmt_Id :=
3166 Next_Elmt
3167 (First_Elmt
3168 (Access_Disp_Table (Etype (Typ))));
3169 Sec_DT_Typ : Elmt_Id :=
3170 Next_Elmt
3171 (First_Elmt
3172 (Access_Disp_Table (Typ)));
3173
3174 procedure Copy_Secondary_DTs (Typ : Entity_Id);
3175 -- Local procedure required to climb through the ancestors
3176 -- and copy the contents of all their secondary dispatch
3177 -- tables.
3178
3179 ------------------------
3180 -- Copy_Secondary_DTs --
3181 ------------------------
3182
3183 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
3184 E : Entity_Id;
3185 Iface : Elmt_Id;
3186
3187 begin
3188 -- Climb to the ancestor (if any) handling private types
3189
3190 if Present (Full_View (Etype (Typ))) then
3191 if Full_View (Etype (Typ)) /= Typ then
3192 Copy_Secondary_DTs (Full_View (Etype (Typ)));
3193 end if;
3194
3195 elsif Etype (Typ) /= Typ then
3196 Copy_Secondary_DTs (Etype (Typ));
3197 end if;
3198
3199 if Present (Abstract_Interfaces (Typ))
3200 and then not Is_Empty_Elmt_List
3201 (Abstract_Interfaces (Typ))
3202 then
3203 Iface := First_Elmt (Abstract_Interfaces (Typ));
3204 E := First_Entity (Typ);
3205 while Present (E)
3206 and then Present (Node (Sec_DT_Ancestor))
3207 loop
3208 if Is_Tag (E) and then Chars (E) /= Name_uTag then
3209 if not Is_Interface (Etype (Typ)) then
3210 Append_To (Elab_Code,
3211 Make_DT_Access_Action (Typ,
3212 Action => Inherit_DT,
3213 Args => New_List (
3214 Node1 => Unchecked_Convert_To
3215 (RTE (RE_Tag),
3216 New_Reference_To
3217 (Node (Sec_DT_Ancestor),
3218 Loc)),
3219 Node2 => Unchecked_Convert_To
3220 (RTE (RE_Tag),
3221 New_Reference_To
3222 (Node (Sec_DT_Typ), Loc)),
3223 Node3 => Make_Integer_Literal (Loc,
3224 DT_Entry_Count (E)))));
3225 end if;
3226
3227 Next_Elmt (Sec_DT_Ancestor);
3228 Next_Elmt (Sec_DT_Typ);
3229 Next_Elmt (Iface);
3230 end if;
3231
3232 Next_Entity (E);
3233 end loop;
3234 end if;
3235 end Copy_Secondary_DTs;
3236
3237 begin
3238 if Present (Node (Sec_DT_Ancestor)) then
3239
3240 -- Handle private types
3241
3242 if Present (Full_View (Typ)) then
3243 Copy_Secondary_DTs (Full_View (Typ));
3244 else
3245 Copy_Secondary_DTs (Typ);
3246 end if;
3247 end if;
3248 end;
3249 end if;
3250 end if;
3251
3252 -- Generate:
3253 -- Inherit_TSD (parent'tag, DT_Ptr);
3254
3255 if not Is_Interface (Typ) then
3256 Append_To (Elab_Code,
3257 Make_DT_Access_Action (Typ,
3258 Action => Inherit_TSD,
3259 Args => New_List (
3260 Node1 => Old_Tag2,
3261 Node2 => New_Reference_To (DT_Ptr, Loc))));
3262 end if;
3263 end if;
3264
3265 if not Is_Interface (Typ) then
3266
3267 -- For types with no controlled components, generate:
3268 -- Set_RC_Offset (DT_Ptr, 0);
3269
3270 -- For simple types with controlled components, generate:
3271 -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
3272
3273 -- For complex types with controlled components where the position
3274 -- of the record controller is not statically computable, if there
3275 -- are controlled components at this level, generate:
3276 -- Set_RC_Offset (DT_Ptr, -1);
3277 -- to indicate that the _controller field is right after the _parent
3278
3279 -- Or if there are no controlled components at this level, generate:
3280 -- Set_RC_Offset (DT_Ptr, -2);
3281 -- to indicate that we need to get the position from the parent.
3282
3283 declare
3284 Position : Node_Id;
3285
3286 begin
3287 if not Has_Controlled_Component (Typ) then
3288 Position := Make_Integer_Literal (Loc, 0);
3289
3290 elsif Etype (Typ) /= Typ
3291 and then Has_Discriminants (Etype (Typ))
3292 then
3293 if Has_New_Controlled_Component (Typ) then
3294 Position := Make_Integer_Literal (Loc, -1);
3295 else
3296 Position := Make_Integer_Literal (Loc, -2);
3297 end if;
3298 else
3299 Position :=
3300 Make_Attribute_Reference (Loc,
3301 Prefix =>
3302 Make_Selected_Component (Loc,
3303 Prefix => New_Reference_To (Typ, Loc),
3304 Selector_Name =>
3305 New_Reference_To (Controller_Component (Typ), Loc)),
3306 Attribute_Name => Name_Position);
3307
3308 -- This is not proper Ada code to use the attribute 'Position
3309 -- on something else than an object but this is supported by
3310 -- the back end (see comment on the Bit_Component attribute in
3311 -- sem_attr). So we avoid semantic checking here.
3312
3313 -- Is this documented in sinfo.ads??? it should be!
3314
3315 Set_Analyzed (Position);
3316 Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
3317 Set_Etype (Prefix (Prefix (Position)), Typ);
3318 Set_Etype (Selector_Name (Prefix (Position)),
3319 RTE (RE_Record_Controller));
3320 Set_Etype (Position, RTE (RE_Storage_Offset));
3321 end if;
3322
3323 Append_To (Elab_Code,
3324 Make_DT_Access_Action (Typ,
3325 Action => Set_RC_Offset,
3326 Args => New_List (
3327 Node1 => New_Reference_To (DT_Ptr, Loc),
3328 Node2 => Position)));
3329 end;
3330
3331 -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
3332 -- described in E.4 (18)
3333
3334 declare
3335 Status : Entity_Id;
3336
3337 begin
3338 Status :=
3339 Boolean_Literals
3340 (Is_Pure (Typ)
3341 or else Is_Shared_Passive (Typ)
3342 or else
3343 ((Is_Remote_Types (Typ)
3344 or else Is_Remote_Call_Interface (Typ))
3345 and then Original_View_In_Visible_Part (Typ))
3346 or else not Comes_From_Source (Typ));
3347
3348 Append_To (Elab_Code,
3349 Make_DT_Access_Action (Typ,
3350 Action => Set_Remotely_Callable,
3351 Args => New_List (
3352 New_Occurrence_Of (DT_Ptr, Loc),
3353 New_Occurrence_Of (Status, Loc))));
3354 end;
3355
3356 if RTE_Available (RE_Set_Offset_To_Top) then
3357 -- Generate:
3358 -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
3359
3360 Append_To (Elab_Code,
3361 Make_Procedure_Call_Statement (Loc,
3362 Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
3363 Parameter_Associations => New_List (
3364 New_Reference_To (RTE (RE_Null_Address), Loc),
3365 New_Reference_To (DT_Ptr, Loc),
3366 New_Occurrence_Of (Standard_True, Loc),
3367 Make_Integer_Literal (Loc, Uint_0),
3368 New_Reference_To (RTE (RE_Null_Address), Loc))));
3369 end if;
3370 end if;
3371
3372 -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
3373 -- Should be the external name not the qualified name???
3374
3375 if not Has_External_Tag_Rep_Clause (Typ) then
3376 Append_To (Elab_Code,
3377 Make_DT_Access_Action (Typ,
3378 Action => Set_External_Tag,
3379 Args => New_List (
3380 Node1 => New_Reference_To (DT_Ptr, Loc),
3381 Node2 =>
3382 Make_Attribute_Reference (Loc,
3383 Prefix => New_Reference_To (Exname, Loc),
3384 Attribute_Name => Name_Address))));
3385
3386 -- Generate code to register the Tag in the External_Tag hash
3387 -- table for the pure Ada type only.
3388
3389 -- Register_Tag (Dt_Ptr);
3390
3391 -- Skip this if routine not available, or in No_Run_Time mode
3392 -- or Typ is an abstract interface type (because the table to
3393 -- register it is not available in the abstract type but in
3394 -- types implementing this interface)
3395
3396 if not No_Run_Time_Mode
3397 and then RTE_Available (RE_Register_Tag)
3398 and then Is_RTE (Generalized_Tag, RE_Tag)
3399 and then not Is_Interface (Typ)
3400 then
3401 Append_To (Elab_Code,
3402 Make_Procedure_Call_Statement (Loc,
3403 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
3404 Parameter_Associations =>
3405 New_List (New_Reference_To (DT_Ptr, Loc))));
3406 end if;
3407 end if;
3408
3409 -- Generate:
3410 -- if No_Reg then
3411 -- <elab_code>
3412 -- No_Reg := False;
3413 -- end if;
3414
3415 Append_To (Elab_Code,
3416 Make_Assignment_Statement (Loc,
3417 Name => New_Reference_To (No_Reg, Loc),
3418 Expression => New_Reference_To (Standard_False, Loc)));
3419
3420 Append_To (Result,
3421 Make_Implicit_If_Statement (Typ,
3422 Condition => New_Reference_To (No_Reg, Loc),
3423 Then_Statements => Elab_Code));
3424
3425 -- Ada 2005 (AI-251): Register the tag of the interfaces into
3426 -- the table of implemented interfaces.
3427
3428 if Num_Ifaces > 0 then
3429 declare
3430 Position : Int;
3431
3432 begin
3433 -- If the parent is an interface we must generate code to register
3434 -- all its interfaces; otherwise this code is not needed because
3435 -- Inherit_TSD has already inherited such interfaces.
3436
3437 if Etype (Typ) /= Typ
3438 and then Is_Interface (Etype (Typ))
3439 then
3440 Position := 1;
3441
3442 AI := First_Elmt (Ancestor_Ifaces);
3443 while Present (AI) loop
3444 -- Generate:
3445 -- Register_Interface (DT_Ptr, Interface'Tag);
3446
3447 Append_To (Result,
3448 Make_DT_Access_Action (Typ,
3449 Action => Register_Interface_Tag,
3450 Args => New_List (
3451 Node1 => New_Reference_To (DT_Ptr, Loc),
3452 Node2 => New_Reference_To
3453 (Node
3454 (First_Elmt
3455 (Access_Disp_Table (Node (AI)))),
3456 Loc),
3457 Node3 => Make_Integer_Literal (Loc, Position))));
3458
3459 Position := Position + 1;
3460 Next_Elmt (AI);
3461 end loop;
3462 end if;
3463
3464 -- Register the interfaces that are not implemented by the
3465 -- ancestor
3466
3467 AI := First_Elmt (Typ_Ifaces);
3468
3469 -- Skip the interfaces implemented by the ancestor
3470
3471 for Count in 1 .. Parent_Num_Ifaces loop
3472 Next_Elmt (AI);
3473 end loop;
3474
3475 -- Register the additional interfaces
3476
3477 Position := Parent_Num_Ifaces + 1;
3478 while Present (AI) loop
3479
3480 -- Generate:
3481 -- Register_Interface (DT_Ptr, Interface'Tag);
3482
3483 if not Is_Interface (Typ)
3484 or else Typ /= Node (AI)
3485 then
3486 Append_To (Result,
3487 Make_DT_Access_Action (Typ,
3488 Action => Register_Interface_Tag,
3489 Args => New_List (
3490 Node1 => New_Reference_To (DT_Ptr, Loc),
3491 Node2 => New_Reference_To
3492 (Node
3493 (First_Elmt
3494 (Access_Disp_Table (Node (AI)))),
3495 Loc),
3496 Node3 => Make_Integer_Literal (Loc, Position))));
3497
3498 Position := Position + 1;
3499 end if;
3500
3501 Next_Elmt (AI);
3502 end loop;
3503
3504 pragma Assert (Position = Num_Ifaces + 1);
3505 end;
3506 end if;
3507
3508 return Result;
3509 end Make_DT;
3510
3511 ---------------------------
3512 -- Make_DT_Access_Action --
3513 ---------------------------
3514
3515 function Make_DT_Access_Action
3516 (Typ : Entity_Id;
3517 Action : DT_Access_Action;
3518 Args : List_Id) return Node_Id
3519 is
3520 Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
3521 Loc : Source_Ptr;
3522
3523 begin
3524 if No (Args) then
3525
3526 -- This is a constant
3527
3528 return New_Reference_To (Action_Name, Sloc (Typ));
3529 end if;
3530
3531 pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
3532
3533 Loc := Sloc (First (Args));
3534
3535 if Action_Is_Proc (Action) then
3536 return
3537 Make_Procedure_Call_Statement (Loc,
3538 Name => New_Reference_To (Action_Name, Loc),
3539 Parameter_Associations => Args);
3540
3541 else
3542 return
3543 Make_Function_Call (Loc,
3544 Name => New_Reference_To (Action_Name, Loc),
3545 Parameter_Associations => Args);
3546 end if;
3547 end Make_DT_Access_Action;
3548
3549 -----------------------
3550 -- Make_Secondary_DT --
3551 -----------------------
3552
3553 procedure Make_Secondary_DT
3554 (Typ : Entity_Id;
3555 Ancestor_Typ : Entity_Id;
3556 Suffix_Index : Int;
3557 Iface : Entity_Id;
3558 AI_Tag : Entity_Id;
3559 Acc_Disp_Tables : in out Elist_Id;
3560 Result : out List_Id)
3561 is
3562 Loc : constant Source_Ptr := Sloc (AI_Tag);
3563 Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
3564 Name_DT : constant Name_Id := New_Internal_Name ('T');
3565 Empty_DT : Boolean := False;
3566 Iface_DT : Node_Id;
3567 Iface_DT_Ptr : Node_Id;
3568 Name_DT_Ptr : Name_Id;
3569 Nb_Prim : Int;
3570 OSD : Entity_Id;
3571 Size_Expr_Node : Node_Id;
3572 Tname : Name_Id;
3573
3574 begin
3575 Result := New_List;
3576
3577 -- Generate a unique external name associated with the secondary
3578 -- dispatch table. This external name will be used to declare an
3579 -- access to this secondary dispatch table, value that will be used
3580 -- for the elaboration of Typ's objects and also for the elaboration
3581 -- of objects of any derivation of Typ that do not override any
3582 -- primitive operation of Typ.
3583
3584 Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);
3585
3586 Tname := Name_Find;
3587 Name_DT_Ptr := New_External_Name (Tname, "P");
3588 Iface_DT := Make_Defining_Identifier (Loc, Name_DT);
3589 Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
3590
3591 -- Dispatch table and related entities are allocated statically
3592
3593 Set_Ekind (Iface_DT, E_Variable);
3594 Set_Is_Statically_Allocated (Iface_DT);
3595
3596 Set_Ekind (Iface_DT_Ptr, E_Variable);
3597 Set_Is_Statically_Allocated (Iface_DT_Ptr);
3598
3599 -- Generate code to create the storage for the Dispatch_Table object.
3600 -- If the number of primitives of Typ is 0 we reserve a dummy single
3601 -- entry for its DT because at run-time the pointer to this dummy entry
3602 -- will be used as the tag.
3603
3604 Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
3605
3606 if Nb_Prim = 0 then
3607 Empty_DT := True;
3608 Nb_Prim := 1;
3609 end if;
3610
3611 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
3612 -- for DT'Alignment use Address'Alignment
3613
3614 Size_Expr_Node :=
3615 Make_Op_Add (Loc,
3616 Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
3617 DT_Prologue_Size,
3618 No_List),
3619 Right_Opnd =>
3620 Make_Op_Multiply (Loc,
3621 Left_Opnd =>
3622 Make_DT_Access_Action (Etype (AI_Tag),
3623 DT_Entry_Size,
3624 No_List),
3625 Right_Opnd =>
3626 Make_Integer_Literal (Loc, Nb_Prim)));
3627
3628 Append_To (Result,
3629 Make_Object_Declaration (Loc,
3630 Defining_Identifier => Iface_DT,
3631 Aliased_Present => True,
3632 Object_Definition =>
3633 Make_Subtype_Indication (Loc,
3634 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3635 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3636 Constraints => New_List (
3637 Make_Range (Loc,
3638 Low_Bound => Make_Integer_Literal (Loc, 1),
3639 High_Bound => Size_Expr_Node))))));
3640
3641 Append_To (Result,
3642 Make_Attribute_Definition_Clause (Loc,
3643 Name => New_Reference_To (Iface_DT, Loc),
3644 Chars => Name_Alignment,
3645 Expression =>
3646 Make_Attribute_Reference (Loc,
3647 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
3648 Attribute_Name => Name_Alignment)));
3649
3650 -- Generate code to create the pointer to the dispatch table
3651
3652 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
3653
3654 -- According to the C++ ABI, the base of the vtable is located
3655 -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
3656 -- Hence, move the pointer down to the real base of the vtable.
3657
3658 Append_To (Result,
3659 Make_Object_Declaration (Loc,
3660 Defining_Identifier => Iface_DT_Ptr,
3661 Constant_Present => True,
3662 Object_Definition => New_Reference_To (Generalized_Tag, Loc),
3663 Expression =>
3664 Unchecked_Convert_To (Generalized_Tag,
3665 Make_Op_Add (Loc,
3666 Left_Opnd =>
3667 Unchecked_Convert_To (RTE (RE_Storage_Offset),
3668 Make_Attribute_Reference (Loc,
3669 Prefix => New_Reference_To (Iface_DT, Loc),
3670 Attribute_Name => Name_Address)),
3671 Right_Opnd =>
3672 Make_DT_Access_Action (Etype (AI_Tag),
3673 DT_Prologue_Size, No_List)))));
3674
3675 -- Note: Offset_To_Top will be initialized by the init subprogram
3676
3677 -- Set Access_Disp_Table field to be the dispatch table pointer
3678
3679 if not (Present (Acc_Disp_Tables)) then
3680 Acc_Disp_Tables := New_Elmt_List;
3681 end if;
3682
3683 Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
3684
3685 -- Step 1: Generate an Object Specific Data (OSD) table
3686
3687 OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
3688
3689 -- Nothing to do if configurable run time does not support the
3690 -- Object_Specific_Data entity.
3691
3692 if not RTE_Available (RE_Object_Specific_Data) then
3693 Error_Msg_CRT ("abstract interface types", Typ);
3694 return;
3695 end if;
3696
3697 -- Generate:
3698 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
3699 -- where the constraint is used to allocate space for the
3700 -- non-predefined primitive operations only.
3701
3702 Append_To (Result,
3703 Make_Object_Declaration (Loc,
3704 Defining_Identifier => OSD,
3705 Object_Definition =>
3706 Make_Subtype_Indication (Loc,
3707 Subtype_Mark => New_Reference_To (
3708 RTE (RE_Object_Specific_Data), Loc),
3709 Constraint =>
3710 Make_Index_Or_Discriminant_Constraint (Loc,
3711 Constraints => New_List (
3712 Make_Integer_Literal (Loc, Nb_Prim))))));
3713
3714 Append_To (Result,
3715 Make_DT_Access_Action (Typ,
3716 Action => Set_Signature,
3717 Args => New_List (
3718 Unchecked_Convert_To (RTE (RE_Tag),
3719 New_Reference_To (Iface_DT_Ptr, Loc)),
3720 New_Reference_To (RTE (RE_Secondary_DT), Loc))));
3721
3722 -- Generate:
3723 -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
3724
3725 Append_To (Result,
3726 Make_DT_Access_Action (Typ,
3727 Action => Set_OSD,
3728 Args => New_List (
3729 Unchecked_Convert_To (RTE (RE_Tag),
3730 New_Reference_To (Iface_DT_Ptr, Loc)),
3731 Make_Attribute_Reference (Loc,
3732 Prefix => New_Reference_To (OSD, Loc),
3733 Attribute_Name => Name_Address))));
3734
3735 -- Generate:
3736 -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
3737
3738 if RTE_Available (RE_Set_Num_Prim_Ops) then
3739 if Empty_DT then
3740 Append_To (Result,
3741 Make_Procedure_Call_Statement (Loc,
3742 Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
3743 Parameter_Associations => New_List (
3744 Unchecked_Convert_To (RTE (RE_Tag),
3745 New_Reference_To (Iface_DT_Ptr, Loc)),
3746 Make_Integer_Literal (Loc, Uint_0))));
3747 else
3748 Append_To (Result,
3749 Make_Procedure_Call_Statement (Loc,
3750 Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
3751 Parameter_Associations => New_List (
3752 Unchecked_Convert_To (RTE (RE_Tag),
3753 New_Reference_To (Iface_DT_Ptr, Loc)),
3754 Make_Integer_Literal (Loc, Nb_Prim))));
3755 end if;
3756 end if;
3757
3758 if Ada_Version >= Ada_05
3759 and then not Is_Interface (Typ)
3760 and then not Is_Abstract (Typ)
3761 and then not Is_Controlled (Typ)
3762 and then RTE_Available (RE_Set_Tagged_Kind)
3763 and then not Restriction_Active (No_Dispatching_Calls)
3764 then
3765 -- Generate:
3766 -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));
3767
3768 Append_To (Result,
3769 Make_DT_Access_Action (Typ,
3770 Action => Set_Tagged_Kind,
3771 Args => New_List (
3772 Unchecked_Convert_To (RTE (RE_Tag), -- DTptr
3773 New_Reference_To (Iface_DT_Ptr, Loc)),
3774 Tagged_Kind (Typ)))); -- Value
3775
3776 if not Empty_DT
3777 and then Is_Concurrent_Record_Type (Typ)
3778 and then Implements_Interface (
3779 Typ => Typ,
3780 Kind => Any_Limited_Interface,
3781 Check_Parent => True)
3782 then
3783 declare
3784 Prim : Entity_Id;
3785 Prim_Alias : Entity_Id;
3786 Prim_Elmt : Elmt_Id;
3787
3788 begin
3789 -- Step 2: Populate the OSD table
3790
3791 Prim_Alias := Empty;
3792 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3793 while Present (Prim_Elmt) loop
3794 Prim := Node (Prim_Elmt);
3795
3796 if Present (Abstract_Interface_Alias (Prim))
3797 and then Find_Dispatching_Type
3798 (Abstract_Interface_Alias (Prim)) = Iface
3799 then
3800 Prim_Alias := Abstract_Interface_Alias (Prim);
3801
3802 -- Generate:
3803 -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr),
3804 -- Secondary_DT_Pos, Primary_DT_pos);
3805
3806 Append_To (Result,
3807 Make_DT_Access_Action (Iface,
3808 Action => Set_Offset_Index,
3809 Args => New_List (
3810 Unchecked_Convert_To (RTE (RE_Tag),
3811 New_Reference_To (Iface_DT_Ptr, Loc)),
3812 Make_Integer_Literal (Loc,
3813 DT_Position (Prim_Alias)),
3814 Make_Integer_Literal (Loc,
3815 DT_Position (Alias (Prim))))));
3816 end if;
3817
3818 Next_Elmt (Prim_Elmt);
3819 end loop;
3820 end;
3821 end if;
3822 end if;
3823 end Make_Secondary_DT;
3824
3825 -------------------------------------
3826 -- Make_Select_Specific_Data_Table --
3827 -------------------------------------
3828
3829 function Make_Select_Specific_Data_Table
3830 (Typ : Entity_Id) return List_Id
3831 is
3832 Assignments : constant List_Id := New_List;
3833 Loc : constant Source_Ptr := Sloc (Typ);
3834
3835 Conc_Typ : Entity_Id;
3836 Decls : List_Id;
3837 DT_Ptr : Entity_Id;
3838 Prim : Entity_Id;
3839 Prim_Als : Entity_Id;
3840 Prim_Elmt : Elmt_Id;
3841 Prim_Pos : Uint;
3842 Nb_Prim : Int := 0;
3843
3844 type Examined_Array is array (Int range <>) of Boolean;
3845
3846 function Find_Entry_Index (E : Entity_Id) return Uint;
3847 -- Given an entry, find its index in the visible declarations of the
3848 -- corresponding concurrent type of Typ.
3849
3850 ----------------------
3851 -- Find_Entry_Index --
3852 ----------------------
3853
3854 function Find_Entry_Index (E : Entity_Id) return Uint is
3855 Index : Uint := Uint_1;
3856 Subp_Decl : Entity_Id;
3857
3858 begin
3859 if Present (Decls)
3860 and then not Is_Empty_List (Decls)
3861 then
3862 Subp_Decl := First (Decls);
3863 while Present (Subp_Decl) loop
3864 if Nkind (Subp_Decl) = N_Entry_Declaration then
3865 if Defining_Identifier (Subp_Decl) = E then
3866 return Index;
3867 end if;
3868
3869 Index := Index + 1;
3870 end if;
3871
3872 Next (Subp_Decl);
3873 end loop;
3874 end if;
3875
3876 return Uint_0;
3877 end Find_Entry_Index;
3878
3879 -- Start of processing for Make_Select_Specific_Data_Table
3880
3881 begin
3882 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3883
3884 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
3885
3886 if Present (Corresponding_Concurrent_Type (Typ)) then
3887 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3888
3889 if Ekind (Conc_Typ) = E_Protected_Type then
3890 Decls := Visible_Declarations (Protected_Definition (
3891 Parent (Conc_Typ)));
3892 else
3893 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3894 Decls := Visible_Declarations (Task_Definition (
3895 Parent (Conc_Typ)));
3896 end if;
3897 end if;
3898
3899 -- Count the non-predefined primitive operations
3900
3901 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3902 while Present (Prim_Elmt) loop
3903 Prim := Node (Prim_Elmt);
3904
3905 if not (Is_Predefined_Dispatching_Operation (Prim)
3906 or else Is_Predefined_Dispatching_Alias (Prim))
3907 then
3908 Nb_Prim := Nb_Prim + 1;
3909 end if;
3910
3911 Next_Elmt (Prim_Elmt);
3912 end loop;
3913
3914 declare
3915 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
3916
3917 begin
3918 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3919 while Present (Prim_Elmt) loop
3920 Prim := Node (Prim_Elmt);
3921
3922 -- Look for primitive overriding an abstract interface subprogram
3923
3924 if Present (Abstract_Interface_Alias (Prim))
3925 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
3926 then
3927 Prim_Pos := DT_Position (Alias (Prim));
3928 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
3929 Examined (UI_To_Int (Prim_Pos)) := True;
3930
3931 -- Set the primitive operation kind regardless of subprogram
3932 -- type. Generate:
3933 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
3934
3935 Append_To (Assignments,
3936 Make_DT_Access_Action (Typ,
3937 Action => Set_Prim_Op_Kind,
3938 Args => New_List (
3939 New_Reference_To (DT_Ptr, Loc),
3940 Make_Integer_Literal (Loc, Prim_Pos),
3941 Prim_Op_Kind (Alias (Prim), Typ))));
3942
3943 -- Retrieve the root of the alias chain
3944
3945 Prim_Als := Prim;
3946 while Present (Alias (Prim_Als)) loop
3947 Prim_Als := Alias (Prim_Als);
3948 end loop;
3949
3950 -- In the case of an entry wrapper, set the entry index
3951
3952 if Ekind (Prim) = E_Procedure
3953 and then Is_Primitive_Wrapper (Prim_Als)
3954 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
3955 then
3956 -- Generate:
3957 -- Ada.Tags.Set_Entry_Index
3958 -- (DT_Ptr, <position>, <index>);
3959
3960 Append_To (Assignments,
3961 Make_DT_Access_Action (Typ,
3962 Action => Set_Entry_Index,
3963 Args => New_List (
3964 New_Reference_To (DT_Ptr, Loc),
3965 Make_Integer_Literal (Loc, Prim_Pos),
3966 Make_Integer_Literal (Loc,
3967 Find_Entry_Index
3968 (Wrapped_Entity (Prim_Als))))));
3969 end if;
3970 end if;
3971
3972 Next_Elmt (Prim_Elmt);
3973 end loop;
3974 end;
3975
3976 return Assignments;
3977 end Make_Select_Specific_Data_Table;
3978
3979 -----------------------------------
3980 -- Original_View_In_Visible_Part --
3981 -----------------------------------
3982
3983 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
3984 Scop : constant Entity_Id := Scope (Typ);
3985
3986 begin
3987 -- The scope must be a package
3988
3989 if Ekind (Scop) /= E_Package
3990 and then Ekind (Scop) /= E_Generic_Package
3991 then
3992 return False;
3993 end if;
3994
3995 -- A type with a private declaration has a private view declared in
3996 -- the visible part.
3997
3998 if Has_Private_Declaration (Typ) then
3999 return True;
4000 end if;
4001
4002 return List_Containing (Parent (Typ)) =
4003 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
4004 end Original_View_In_Visible_Part;
4005
4006 ------------------
4007 -- Prim_Op_Kind --
4008 ------------------
4009
4010 function Prim_Op_Kind
4011 (Prim : Entity_Id;
4012 Typ : Entity_Id) return Node_Id
4013 is
4014 Full_Typ : Entity_Id := Typ;
4015 Loc : constant Source_Ptr := Sloc (Prim);
4016 Prim_Op : Entity_Id;
4017
4018 begin
4019 -- Retrieve the original primitive operation
4020
4021 Prim_Op := Prim;
4022 while Present (Alias (Prim_Op)) loop
4023 Prim_Op := Alias (Prim_Op);
4024 end loop;
4025
4026 if Ekind (Typ) = E_Record_Type
4027 and then Present (Corresponding_Concurrent_Type (Typ))
4028 then
4029 Full_Typ := Corresponding_Concurrent_Type (Typ);
4030 end if;
4031
4032 if Ekind (Prim_Op) = E_Function then
4033
4034 -- Protected function
4035
4036 if Ekind (Full_Typ) = E_Protected_Type then
4037 return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
4038
4039 -- Task function
4040
4041 elsif Ekind (Full_Typ) = E_Task_Type then
4042 return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
4043
4044 -- Regular function
4045
4046 else
4047 return New_Reference_To (RTE (RE_POK_Function), Loc);
4048 end if;
4049
4050 else
4051 pragma Assert (Ekind (Prim_Op) = E_Procedure);
4052
4053 if Ekind (Full_Typ) = E_Protected_Type then
4054
4055 -- Protected entry
4056
4057 if Is_Primitive_Wrapper (Prim_Op)
4058 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
4059 then
4060 return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
4061
4062 -- Protected procedure
4063
4064 else
4065 return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
4066 end if;
4067
4068 elsif Ekind (Full_Typ) = E_Task_Type then
4069
4070 -- Task entry
4071
4072 if Is_Primitive_Wrapper (Prim_Op)
4073 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
4074 then
4075 return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
4076
4077 -- Task "procedure". These are the internally Expander-generated
4078 -- procedures (task body for instance).
4079
4080 else
4081 return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
4082 end if;
4083
4084 -- Regular procedure
4085
4086 else
4087 return New_Reference_To (RTE (RE_POK_Procedure), Loc);
4088 end if;
4089 end if;
4090 end Prim_Op_Kind;
4091
4092 -------------------------
4093 -- Set_All_DT_Position --
4094 -------------------------
4095
4096 procedure Set_All_DT_Position (Typ : Entity_Id) is
4097
4098 procedure Validate_Position (Prim : Entity_Id);
4099 -- Check that the position assignated to Prim is completely safe
4100 -- (it has not been assigned to a previously defined primitive
4101 -- operation of Typ)
4102
4103 -----------------------
4104 -- Validate_Position --
4105 -----------------------
4106
4107 procedure Validate_Position (Prim : Entity_Id) is
4108 Op_Elmt : Elmt_Id;
4109 Op : Entity_Id;
4110
4111 begin
4112 -- Aliased primitives are safe
4113
4114 if Present (Alias (Prim)) then
4115 return;
4116 end if;
4117
4118 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4119 while Present (Op_Elmt) loop
4120 Op := Node (Op_Elmt);
4121
4122 -- No need to check against itself
4123
4124 if Op = Prim then
4125 null;
4126
4127 -- Primitive operations covering abstract interfaces are
4128 -- allocated later
4129
4130 elsif Present (Abstract_Interface_Alias (Op)) then
4131 null;
4132
4133 -- Predefined dispatching operations are completely safe. They
4134 -- are allocated at fixed positions in a separate table.
4135
4136 elsif Is_Predefined_Dispatching_Operation (Op)
4137 or else Is_Predefined_Dispatching_Alias (Op)
4138 then
4139 null;
4140
4141 -- Aliased subprograms are safe
4142
4143 elsif Present (Alias (Op)) then
4144 null;
4145
4146 elsif DT_Position (Op) = DT_Position (Prim)
4147 and then not Is_Predefined_Dispatching_Operation (Op)
4148 and then not Is_Predefined_Dispatching_Operation (Prim)
4149 and then not Is_Predefined_Dispatching_Alias (Op)
4150 and then not Is_Predefined_Dispatching_Alias (Prim)
4151 then
4152
4153 -- Handle aliased subprograms
4154
4155 declare
4156 Op_1 : Entity_Id;
4157 Op_2 : Entity_Id;
4158
4159 begin
4160 Op_1 := Op;
4161 loop
4162 if Present (Overridden_Operation (Op_1)) then
4163 Op_1 := Overridden_Operation (Op_1);
4164 elsif Present (Alias (Op_1)) then
4165 Op_1 := Alias (Op_1);
4166 else
4167 exit;
4168 end if;
4169 end loop;
4170
4171 Op_2 := Prim;
4172 loop
4173 if Present (Overridden_Operation (Op_2)) then
4174 Op_2 := Overridden_Operation (Op_2);
4175 elsif Present (Alias (Op_2)) then
4176 Op_2 := Alias (Op_2);
4177 else
4178 exit;
4179 end if;
4180 end loop;
4181
4182 if Op_1 /= Op_2 then
4183 raise Program_Error;
4184 end if;
4185 end;
4186 end if;
4187
4188 Next_Elmt (Op_Elmt);
4189 end loop;
4190 end Validate_Position;
4191
4192 -- Local variables
4193
4194 Parent_Typ : constant Entity_Id := Etype (Typ);
4195 Root_Typ : constant Entity_Id := Root_Type (Typ);
4196 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
4197 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
4198
4199 Adjusted : Boolean := False;
4200 Finalized : Boolean := False;
4201
4202 Count_Prim : Int;
4203 DT_Length : Int;
4204 Nb_Prim : Int;
4205 Parent_EC : Int;
4206 Prim : Entity_Id;
4207 Prim_Elmt : Elmt_Id;
4208
4209 -- Start of processing for Set_All_DT_Position
4210
4211 begin
4212 -- Get Entry_Count of the parent
4213
4214 if Parent_Typ /= Typ
4215 and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
4216 then
4217 Parent_EC := UI_To_Int (DT_Entry_Count
4218 (First_Tag_Component (Parent_Typ)));
4219 else
4220 Parent_EC := 0;
4221 end if;
4222
4223 -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
4224 -- give a coherent set of information
4225
4226 if Is_CPP_Class (Root_Typ) and then Debug_Flag_QQ then
4227
4228 -- Compute the number of primitive operations in the main Vtable
4229 -- Set their position:
4230 -- - where it was set if overriden or inherited
4231 -- - after the end of the parent vtable otherwise
4232
4233 Prim_Elmt := First_Prim;
4234 Nb_Prim := 0;
4235 while Present (Prim_Elmt) loop
4236 Prim := Node (Prim_Elmt);
4237
4238 if not Is_CPP_Class (Typ) then
4239 Set_DTC_Entity (Prim, The_Tag);
4240
4241 elsif Present (Alias (Prim)) then
4242 Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
4243 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
4244
4245 elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
4246 Error_Msg_NE ("is a primitive operation of&," &
4247 " pragma Cpp_Virtual required", Prim, Typ);
4248 end if;
4249
4250 if DTC_Entity (Prim) = The_Tag then
4251
4252 -- Get the slot from the parent subprogram if any
4253
4254 declare
4255 H : Entity_Id;
4256
4257 begin
4258 H := Homonym (Prim);
4259 while Present (H) loop
4260 if Present (DTC_Entity (H))
4261 and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
4262 then
4263 Set_DT_Position (Prim, DT_Position (H));
4264 exit;
4265 end if;
4266
4267 H := Homonym (H);
4268 end loop;
4269 end;
4270
4271 -- Otherwise take the canonical slot after the end of the
4272 -- parent Vtable
4273
4274 if DT_Position (Prim) = No_Uint then
4275 Nb_Prim := Nb_Prim + 1;
4276 Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
4277
4278 elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
4279 Nb_Prim := Nb_Prim + 1;
4280 end if;
4281 end if;
4282
4283 Next_Elmt (Prim_Elmt);
4284 end loop;
4285
4286 -- Check that the declared size of the Vtable is bigger or equal
4287 -- than the number of primitive operations (if bigger it means that
4288 -- some of the c++ virtual functions were not imported, that is
4289 -- allowed).
4290
4291 if DT_Entry_Count (The_Tag) = No_Uint
4292 or else not Is_CPP_Class (Typ)
4293 then
4294 Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
4295
4296 elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
4297 Error_Msg_N ("not enough room in the Vtable for all virtual"
4298 & " functions", The_Tag);
4299 end if;
4300
4301 -- Check that Positions are not duplicate nor outside the range of
4302 -- the Vtable.
4303
4304 declare
4305 Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
4306 Pos : Int;
4307 Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
4308 (others => Empty);
4309
4310 begin
4311 Prim_Elmt := First_Prim;
4312 while Present (Prim_Elmt) loop
4313 Prim := Node (Prim_Elmt);
4314
4315 if DTC_Entity (Prim) = The_Tag then
4316 Pos := UI_To_Int (DT_Position (Prim));
4317
4318 if Pos not in Prim_Pos_Table'Range then
4319 Error_Msg_N
4320 ("position not in range of virtual table", Prim);
4321
4322 elsif Present (Prim_Pos_Table (Pos)) then
4323 Error_Msg_NE ("cannot be at the same position in the"
4324 & " vtable than&", Prim, Prim_Pos_Table (Pos));
4325
4326 else
4327 Prim_Pos_Table (Pos) := Prim;
4328 end if;
4329 end if;
4330
4331 Next_Elmt (Prim_Elmt);
4332 end loop;
4333 end;
4334
4335 -- Generate listing showing the contents of the dispatch tables
4336
4337 if Debug_Flag_ZZ then
4338 Write_DT (Typ);
4339 end if;
4340
4341 -- For regular Ada tagged types, just set the DT_Position for
4342 -- each primitive operation. Perform some sanity checks to avoid
4343 -- to build completely inconsistant dispatch tables.
4344
4345 -- Note that the _Size primitive is always set at position 1 in order
4346 -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
4347 -- in Ada.Tags).
4348
4349 else
4350 -- First stage: Set the DTC entity of all the primitive operations
4351 -- This is required to properly read the DT_Position attribute in
4352 -- the latter stages.
4353
4354 Prim_Elmt := First_Prim;
4355 Count_Prim := 0;
4356 while Present (Prim_Elmt) loop
4357 Prim := Node (Prim_Elmt);
4358
4359 -- Predefined primitives have a separate dispatch table
4360
4361 if not (Is_Predefined_Dispatching_Operation (Prim)
4362 or else Is_Predefined_Dispatching_Alias (Prim))
4363 then
4364 Count_Prim := Count_Prim + 1;
4365 end if;
4366
4367 -- Ada 2005 (AI-251)
4368
4369 if Present (Abstract_Interface_Alias (Prim))
4370 and then Is_Interface
4371 (Find_Dispatching_Type
4372 (Abstract_Interface_Alias (Prim)))
4373 then
4374 Set_DTC_Entity (Prim,
4375 Find_Interface_Tag
4376 (T => Typ,
4377 Iface => Find_Dispatching_Type
4378 (Abstract_Interface_Alias (Prim))));
4379 else
4380 Set_DTC_Entity (Prim, The_Tag);
4381 end if;
4382
4383 -- Clear any previous value of the DT_Position attribute. In this
4384 -- way we ensure that the final position of all the primitives is
4385 -- stablished by the following stages of this algorithm.
4386
4387 Set_DT_Position (Prim, No_Uint);
4388
4389 Next_Elmt (Prim_Elmt);
4390 end loop;
4391
4392 declare
4393 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
4394 := (others => False);
4395 E : Entity_Id;
4396
4397 procedure Set_Fixed_Prim (Pos : Int);
4398 -- Sets to true an element of the Fixed_Prim table to indicate
4399 -- that this entry of the dispatch table of Typ is occupied.
4400
4401 --------------------
4402 -- Set_Fixed_Prim --
4403 --------------------
4404
4405 procedure Set_Fixed_Prim (Pos : Int) is
4406 begin
4407 pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
4408 Fixed_Prim (Pos) := True;
4409 exception
4410 when Constraint_Error =>
4411 raise Program_Error;
4412 end Set_Fixed_Prim;
4413
4414 begin
4415 -- Second stage: Register fixed entries
4416
4417 Nb_Prim := 0;
4418 Prim_Elmt := First_Prim;
4419 while Present (Prim_Elmt) loop
4420 Prim := Node (Prim_Elmt);
4421
4422 -- Predefined primitives have a separate table and all its
4423 -- entries are at predefined fixed positions.
4424
4425 if Is_Predefined_Dispatching_Operation (Prim) then
4426 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
4427
4428 elsif Is_Predefined_Dispatching_Alias (Prim) then
4429 E := Alias (Prim);
4430 while Present (Alias (E)) loop
4431 E := Alias (E);
4432 end loop;
4433
4434 Set_DT_Position (Prim, Default_Prim_Op_Position (E));
4435
4436 -- Overriding primitives of ancestor abstract interfaces
4437
4438 elsif Present (Abstract_Interface_Alias (Prim))
4439 and then Is_Ancestor
4440 (Find_Dispatching_Type
4441 (Abstract_Interface_Alias (Prim)),
4442 Typ)
4443 then
4444 pragma Assert (DT_Position (Prim) = No_Uint
4445 and then Present (DTC_Entity
4446 (Abstract_Interface_Alias (Prim))));
4447
4448 E := Abstract_Interface_Alias (Prim);
4449 Set_DT_Position (Prim, DT_Position (E));
4450
4451 pragma Assert
4452 (DT_Position (Alias (Prim)) = No_Uint
4453 or else DT_Position (Alias (Prim)) = DT_Position (E));
4454 Set_DT_Position (Alias (Prim), DT_Position (E));
4455 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
4456
4457 -- Overriding primitives must use the same entry as the
4458 -- overriden primitive
4459
4460 elsif not Present (Abstract_Interface_Alias (Prim))
4461 and then Present (Alias (Prim))
4462 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
4463 and then Is_Ancestor
4464 (Find_Dispatching_Type (Alias (Prim)), Typ)
4465 and then Present (DTC_Entity (Alias (Prim)))
4466 then
4467 E := Alias (Prim);
4468 Set_DT_Position (Prim, DT_Position (E));
4469
4470 if not Is_Predefined_Dispatching_Alias (E) then
4471 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
4472 end if;
4473 end if;
4474
4475 Next_Elmt (Prim_Elmt);
4476 end loop;
4477
4478 -- Third stage: Fix the position of all the new primitives
4479 -- Entries associated with primitives covering interfaces
4480 -- are handled in a latter round.
4481
4482 Prim_Elmt := First_Prim;
4483 while Present (Prim_Elmt) loop
4484 Prim := Node (Prim_Elmt);
4485
4486 -- Skip primitives previously set entries
4487
4488 if DT_Position (Prim) /= No_Uint then
4489 null;
4490
4491 -- Primitives covering interface primitives are handled later
4492
4493 elsif Present (Abstract_Interface_Alias (Prim)) then
4494 null;
4495
4496 else
4497 -- Take the next available position in the DT
4498
4499 loop
4500 Nb_Prim := Nb_Prim + 1;
4501 pragma Assert (Nb_Prim <= Count_Prim);
4502 exit when not Fixed_Prim (Nb_Prim);
4503 end loop;
4504
4505 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
4506 Set_Fixed_Prim (Nb_Prim);
4507 end if;
4508
4509 Next_Elmt (Prim_Elmt);
4510 end loop;
4511 end;
4512
4513 -- Fourth stage: Complete the decoration of primitives covering
4514 -- interfaces (that is, propagate the DT_Position attribute
4515 -- from the aliased primitive)
4516
4517 Prim_Elmt := First_Prim;
4518 while Present (Prim_Elmt) loop
4519 Prim := Node (Prim_Elmt);
4520
4521 if DT_Position (Prim) = No_Uint
4522 and then Present (Abstract_Interface_Alias (Prim))
4523 then
4524 pragma Assert (Present (Alias (Prim))
4525 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
4526
4527 -- Check if this entry will be placed in the primary DT
4528
4529 if Is_Ancestor (Find_Dispatching_Type
4530 (Abstract_Interface_Alias (Prim)),
4531 Typ)
4532 then
4533 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
4534 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
4535
4536 -- Otherwise it will be placed in the secondary DT
4537
4538 else
4539 pragma Assert
4540 (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
4541 Set_DT_Position (Prim,
4542 DT_Position (Abstract_Interface_Alias (Prim)));
4543 end if;
4544 end if;
4545
4546 Next_Elmt (Prim_Elmt);
4547 end loop;
4548
4549 -- Generate listing showing the contents of the dispatch tables.
4550 -- This action is done before some further static checks because
4551 -- in case of critical errors caused by a wrong dispatch table
4552 -- we need to see the contents of such table.
4553
4554 if Debug_Flag_ZZ then
4555 Write_DT (Typ);
4556 end if;
4557
4558 -- Final stage: Ensure that the table is correct plus some further
4559 -- verifications concerning the primitives.
4560
4561 Prim_Elmt := First_Prim;
4562 DT_Length := 0;
4563 while Present (Prim_Elmt) loop
4564 Prim := Node (Prim_Elmt);
4565
4566 -- At this point all the primitives MUST have a position
4567 -- in the dispatch table
4568
4569 if DT_Position (Prim) = No_Uint then
4570 raise Program_Error;
4571 end if;
4572
4573 -- Calculate real size of the dispatch table
4574
4575 if not (Is_Predefined_Dispatching_Operation (Prim)
4576 or else Is_Predefined_Dispatching_Alias (Prim))
4577 and then UI_To_Int (DT_Position (Prim)) > DT_Length
4578 then
4579 DT_Length := UI_To_Int (DT_Position (Prim));
4580 end if;
4581
4582 -- Ensure that the asignated position to non-predefined
4583 -- dispatching operations in the dispatch table is correct.
4584
4585 if not (Is_Predefined_Dispatching_Operation (Prim)
4586 or else Is_Predefined_Dispatching_Alias (Prim))
4587 then
4588 Validate_Position (Prim);
4589 end if;
4590
4591 if Chars (Prim) = Name_Finalize then
4592 Finalized := True;
4593 end if;
4594
4595 if Chars (Prim) = Name_Adjust then
4596 Adjusted := True;
4597 end if;
4598
4599 -- An abstract operation cannot be declared in the private part
4600 -- for a visible abstract type, because it could never be over-
4601 -- ridden. For explicit declarations this is checked at the
4602 -- point of declaration, but for inherited operations it must
4603 -- be done when building the dispatch table.
4604
4605 -- Ada 2005 (AI-251): Hidden entities associated with abstract
4606 -- interface primitives are not taken into account because the
4607 -- check is done with the aliased primitive.
4608
4609 if Is_Abstract (Typ)
4610 and then Is_Abstract (Prim)
4611 and then Present (Alias (Prim))
4612 and then not Present (Abstract_Interface_Alias (Prim))
4613 and then Is_Derived_Type (Typ)
4614 and then In_Private_Part (Current_Scope)
4615 and then
4616 List_Containing (Parent (Prim)) =
4617 Private_Declarations
4618 (Specification (Unit_Declaration_Node (Current_Scope)))
4619 and then Original_View_In_Visible_Part (Typ)
4620 then
4621 -- We exclude Input and Output stream operations because
4622 -- Limited_Controlled inherits useless Input and Output
4623 -- stream operations from Root_Controlled, which can
4624 -- never be overridden.
4625
4626 if not Is_TSS (Prim, TSS_Stream_Input)
4627 and then
4628 not Is_TSS (Prim, TSS_Stream_Output)
4629 then
4630 Error_Msg_NE
4631 ("abstract inherited private operation&" &
4632 " must be overridden ('R'M 3.9.3(10))",
4633 Parent (Typ), Prim);
4634 end if;
4635 end if;
4636
4637 Next_Elmt (Prim_Elmt);
4638 end loop;
4639
4640 -- Additional check
4641
4642 if Is_Controlled (Typ) then
4643 if not Finalized then
4644 Error_Msg_N
4645 ("controlled type has no explicit Finalize method?", Typ);
4646
4647 elsif not Adjusted then
4648 Error_Msg_N
4649 ("controlled type has no explicit Adjust method?", Typ);
4650 end if;
4651 end if;
4652
4653 -- Set the final size of the Dispatch Table
4654
4655 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
4656
4657 -- The derived type must have at least as many components as its
4658 -- parent (for root types, the Etype points back to itself
4659 -- and the test should not fail)
4660
4661 -- This test fails compiling the partial view of a tagged type
4662 -- derived from an interface which defines the overriding subprogram
4663 -- in the private part. This needs further investigation???
4664
4665 if not Has_Private_Declaration (Typ) then
4666 pragma Assert (
4667 DT_Entry_Count (The_Tag) >=
4668 DT_Entry_Count (First_Tag_Component (Parent_Typ)));
4669 null;
4670 end if;
4671 end if;
4672 end Set_All_DT_Position;
4673
4674 -----------------------------
4675 -- Set_Default_Constructor --
4676 -----------------------------
4677
4678 procedure Set_Default_Constructor (Typ : Entity_Id) is
4679 Loc : Source_Ptr;
4680 Init : Entity_Id;
4681 Param : Entity_Id;
4682 E : Entity_Id;
4683
4684 begin
4685 -- Look for the default constructor entity. For now only the
4686 -- default constructor has the flag Is_Constructor.
4687
4688 E := Next_Entity (Typ);
4689 while Present (E)
4690 and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
4691 loop
4692 Next_Entity (E);
4693 end loop;
4694
4695 -- Create the init procedure
4696
4697 if Present (E) then
4698 Loc := Sloc (E);
4699 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
4700 Param := Make_Defining_Identifier (Loc, Name_X);
4701
4702 Discard_Node (
4703 Make_Subprogram_Declaration (Loc,
4704 Make_Procedure_Specification (Loc,
4705 Defining_Unit_Name => Init,
4706 Parameter_Specifications => New_List (
4707 Make_Parameter_Specification (Loc,
4708 Defining_Identifier => Param,
4709 Parameter_Type => New_Reference_To (Typ, Loc))))));
4710
4711 Set_Init_Proc (Typ, Init);
4712 Set_Is_Imported (Init);
4713 Set_Interface_Name (Init, Interface_Name (E));
4714 Set_Convention (Init, Convention_C);
4715 Set_Is_Public (Init);
4716 Set_Has_Completion (Init);
4717
4718 -- If there are no constructors, mark the type as abstract since we
4719 -- won't be able to declare objects of that type.
4720
4721 else
4722 Set_Is_Abstract (Typ);
4723 end if;
4724 end Set_Default_Constructor;
4725
4726 -----------------
4727 -- Tagged_Kind --
4728 -----------------
4729
4730 function Tagged_Kind (T : Entity_Id) return Node_Id is
4731 Conc_Typ : Entity_Id;
4732 Loc : constant Source_Ptr := Sloc (T);
4733
4734 begin
4735 pragma Assert
4736 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
4737
4738 -- Abstract kinds
4739
4740 if Is_Abstract (T) then
4741 if Is_Limited_Record (T) then
4742 return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
4743 else
4744 return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
4745 end if;
4746
4747 -- Concurrent kinds
4748
4749 elsif Is_Concurrent_Record_Type (T) then
4750 Conc_Typ := Corresponding_Concurrent_Type (T);
4751
4752 if Ekind (Conc_Typ) = E_Protected_Type then
4753 return New_Reference_To (RTE (RE_TK_Protected), Loc);
4754 else
4755 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
4756 return New_Reference_To (RTE (RE_TK_Task), Loc);
4757 end if;
4758
4759 -- Regular tagged kinds
4760
4761 else
4762 if Is_Limited_Record (T) then
4763 return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
4764 else
4765 return New_Reference_To (RTE (RE_TK_Tagged), Loc);
4766 end if;
4767 end if;
4768 end Tagged_Kind;
4769
4770 --------------
4771 -- Write_DT --
4772 --------------
4773
4774 procedure Write_DT (Typ : Entity_Id) is
4775 Elmt : Elmt_Id;
4776 Prim : Node_Id;
4777
4778 begin
4779 -- Protect this procedure against wrong usage. Required because it will
4780 -- be used directly from GDB
4781
4782 if not (Typ in First_Node_Id .. Last_Node_Id)
4783 or else not Is_Tagged_Type (Typ)
4784 then
4785 Write_Str ("wrong usage: Write_DT must be used with tagged types");
4786 Write_Eol;
4787 return;
4788 end if;
4789
4790 Write_Int (Int (Typ));
4791 Write_Str (": ");
4792 Write_Name (Chars (Typ));
4793
4794 if Is_Interface (Typ) then
4795 Write_Str (" is interface");
4796 end if;
4797
4798 Write_Eol;
4799
4800 Elmt := First_Elmt (Primitive_Operations (Typ));
4801 while Present (Elmt) loop
4802 Prim := Node (Elmt);
4803 Write_Str (" - ");
4804
4805 -- Indicate if this primitive will be allocated in the primary
4806 -- dispatch table or in a secondary dispatch table associated
4807 -- with an abstract interface type
4808
4809 if Present (DTC_Entity (Prim)) then
4810 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
4811 Write_Str ("[P] ");
4812 else
4813 Write_Str ("[s] ");
4814 end if;
4815 end if;
4816
4817 -- Output the node of this primitive operation and its name
4818
4819 Write_Int (Int (Prim));
4820 Write_Str (": ");
4821
4822 if Is_Predefined_Dispatching_Operation (Prim) then
4823 Write_Str ("(predefined) ");
4824 end if;
4825
4826 Write_Name (Chars (Prim));
4827
4828 -- Indicate if this primitive has an aliased primitive
4829
4830 if Present (Alias (Prim)) then
4831 Write_Str (" (alias = ");
4832 Write_Int (Int (Alias (Prim)));
4833
4834 -- If the DTC_Entity attribute is already set we can also output
4835 -- the name of the interface covered by this primitive (if any)
4836
4837 if Present (DTC_Entity (Alias (Prim)))
4838 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
4839 then
4840 Write_Str (" from interface ");
4841 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
4842 end if;
4843
4844 if Present (Abstract_Interface_Alias (Prim)) then
4845 Write_Str (", AI_Alias of ");
4846 Write_Name (Chars (Scope (DTC_Entity
4847 (Abstract_Interface_Alias (Prim)))));
4848 Write_Char (':');
4849 Write_Int (Int (Abstract_Interface_Alias (Prim)));
4850 end if;
4851
4852 Write_Str (")");
4853 end if;
4854
4855 -- Display the final position of this primitive in its associated
4856 -- (primary or secondary) dispatch table
4857
4858 if Present (DTC_Entity (Prim))
4859 and then DT_Position (Prim) /= No_Uint
4860 then
4861 Write_Str (" at #");
4862 Write_Int (UI_To_Int (DT_Position (Prim)));
4863 end if;
4864
4865 if Is_Abstract (Prim) then
4866 Write_Str (" is abstract;");
4867
4868 -- Check if this is a null primitive
4869
4870 elsif Comes_From_Source (Prim)
4871 and then Ekind (Prim) = E_Procedure
4872 and then Null_Present (Parent (Prim))
4873 then
4874 Write_Str (" is null;");
4875 end if;
4876
4877 Write_Eol;
4878
4879 Next_Elmt (Elmt);
4880 end loop;
4881 end Write_DT;
4882
4883 end Exp_Disp;
Mirror of the offical gcc git repository hosted at gcc.gnu.org