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