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