]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/exp_disp.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2005-07-07 Eric Botcazou <ebotcazou@adacore.com>
[thirdparty/gcc.git] / gcc / ada / exp_disp.adb
CommitLineData
ee6ba406 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ D I S P --
6-- --
7-- B o d y --
8-- --
7189d17f 9-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
ee6ba406 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 --
f27cea3a 19-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20-- Boston, MA 02110-1301, USA. --
ee6ba406 21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
e78e8c8e 23-- Extensive contributions were provided by Ada Core Technologies Inc. --
ee6ba406 24-- --
25------------------------------------------------------------------------------
26
27with Atree; use Atree;
28with Checks; use Checks;
aad6babd 29with Debug; use Debug;
ee6ba406 30with Einfo; use Einfo;
31with Elists; use Elists;
32with Errout; use Errout;
33with Exp_Ch7; use Exp_Ch7;
34with Exp_Tss; use Exp_Tss;
35with Exp_Util; use Exp_Util;
ee6ba406 36with Itypes; use Itypes;
ee6ba406 37with Nlists; use Nlists;
38with Nmake; use Nmake;
aad6babd 39with Namet; use Namet;
ee6ba406 40with Opt; use Opt;
aad6babd 41with Output; use Output;
ee6ba406 42with Rtsfind; use Rtsfind;
aad6babd 43with Sem; use Sem;
ee6ba406 44with Sem_Disp; use Sem_Disp;
45with Sem_Res; use Sem_Res;
aad6babd 46with Sem_Type; use Sem_Type;
ee6ba406 47with Sem_Util; use Sem_Util;
48with Sinfo; use Sinfo;
49with Snames; use Snames;
50with Stand; use Stand;
51with Tbuild; use Tbuild;
aad6babd 52with Ttypes; use Ttypes;
ee6ba406 53with Uintp; use Uintp;
54
55package body Exp_Disp is
56
57 Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
58 (CW_Membership => RE_CW_Membership,
aad6babd 59 IW_Membership => RE_IW_Membership,
ee6ba406 60 DT_Entry_Size => RE_DT_Entry_Size,
61 DT_Prologue_Size => RE_DT_Prologue_Size,
aad6babd 62 Get_Access_Level => RE_Get_Access_Level,
ee6ba406 63 Get_External_Tag => RE_Get_External_Tag,
64 Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
65 Get_RC_Offset => RE_Get_RC_Offset,
66 Get_Remotely_Callable => RE_Get_Remotely_Callable,
ee6ba406 67 Inherit_DT => RE_Inherit_DT,
68 Inherit_TSD => RE_Inherit_TSD,
aad6babd 69 Register_Interface_Tag => RE_Register_Interface_Tag,
ee6ba406 70 Register_Tag => RE_Register_Tag,
aad6babd 71 Set_Access_Level => RE_Set_Access_Level,
ee6ba406 72 Set_Expanded_Name => RE_Set_Expanded_Name,
73 Set_External_Tag => RE_Set_External_Tag,
74 Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
75 Set_RC_Offset => RE_Set_RC_Offset,
76 Set_Remotely_Callable => RE_Set_Remotely_Callable,
77 Set_TSD => RE_Set_TSD,
78 TSD_Entry_Size => RE_TSD_Entry_Size,
79 TSD_Prologue_Size => RE_TSD_Prologue_Size);
80
ee6ba406 81 Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
82 (CW_Membership => False,
aad6babd 83 IW_Membership => False,
ee6ba406 84 DT_Entry_Size => False,
85 DT_Prologue_Size => False,
aad6babd 86 Get_Access_Level => False,
ee6ba406 87 Get_External_Tag => False,
88 Get_Prim_Op_Address => False,
89 Get_Remotely_Callable => False,
90 Get_RC_Offset => False,
ee6ba406 91 Inherit_DT => True,
92 Inherit_TSD => True,
aad6babd 93 Register_Interface_Tag => True,
ee6ba406 94 Register_Tag => True,
aad6babd 95 Set_Access_Level => True,
ee6ba406 96 Set_Expanded_Name => True,
97 Set_External_Tag => True,
98 Set_Prim_Op_Address => True,
99 Set_RC_Offset => True,
100 Set_Remotely_Callable => True,
101 Set_TSD => True,
102 TSD_Entry_Size => False,
103 TSD_Prologue_Size => False);
104
105 Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
106 (CW_Membership => 2,
aad6babd 107 IW_Membership => 2,
ee6ba406 108 DT_Entry_Size => 0,
109 DT_Prologue_Size => 0,
aad6babd 110 Get_Access_Level => 1,
ee6ba406 111 Get_External_Tag => 1,
112 Get_Prim_Op_Address => 2,
113 Get_RC_Offset => 1,
114 Get_Remotely_Callable => 1,
ee6ba406 115 Inherit_DT => 3,
116 Inherit_TSD => 2,
aad6babd 117 Register_Interface_Tag => 2,
ee6ba406 118 Register_Tag => 1,
aad6babd 119 Set_Access_Level => 2,
ee6ba406 120 Set_Expanded_Name => 2,
121 Set_External_Tag => 2,
122 Set_Prim_Op_Address => 3,
123 Set_RC_Offset => 2,
124 Set_Remotely_Callable => 2,
125 Set_TSD => 2,
126 TSD_Entry_Size => 0,
127 TSD_Prologue_Size => 0);
128
aad6babd 129 function Build_Anonymous_Access_Type
130 (Directly_Designated_Type : Entity_Id;
131 Related_Nod : Node_Id) return Entity_Id;
132 -- Returns a decorated entity corresponding with an anonymous access type.
133 -- Used to generate unchecked type conversion of an address.
134
135 procedure Collect_All_Interfaces (T : Entity_Id);
136 -- Ada 2005 (AI-251): Collect the whole list of interfaces that are
137 -- directly or indirectly implemented by T. Used to compute the size
138 -- of the table of interfaces.
139
140 function Default_Prim_Op_Position (Subp : Entity_Id) return Uint;
141 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
142 -- of the default primitive operations.
143
ee6ba406 144 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
145 -- Check if the type has a private view or if the public view appears
146 -- in the visible part of a package spec.
147
aad6babd 148 ----------------------------------
149 -- Build_Anonymous_Access_Type --
150 ----------------------------------
151
152 function Build_Anonymous_Access_Type
153 (Directly_Designated_Type : Entity_Id;
154 Related_Nod : Node_Id) return Entity_Id
155 is
156 New_E : Entity_Id;
157
158 begin
159 New_E := Create_Itype (Ekind => E_Anonymous_Access_Type,
160 Related_Nod => Related_Nod,
161 Scope_Id => Current_Scope);
162
163 Set_Etype (New_E, New_E);
164 Init_Size_Align (New_E);
165 Init_Size (New_E, System_Address_Size);
166 Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
167 Set_Is_First_Subtype (New_E);
168
169 return New_E;
170 end Build_Anonymous_Access_Type;
171
172 ----------------------------
173 -- Collect_All_Interfaces --
174 ----------------------------
175
176 procedure Collect_All_Interfaces (T : Entity_Id) is
177
178 procedure Add_Interface (Iface : Entity_Id);
179 -- Add the interface it if is not already in the list
180
181 procedure Collect (Typ : Entity_Id);
182 -- Subsidiary subprogram used to traverse the whole list
183 -- of directly and indirectly implemented interfaces
184
185 -------------------
186 -- Add_Interface --
187 -------------------
188
189 procedure Add_Interface (Iface : Entity_Id) is
190 Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T));
191
192 begin
193 while Present (Elmt) and then Node (Elmt) /= Iface loop
194 Next_Elmt (Elmt);
195 end loop;
196
197 if not Present (Elmt) then
198 Append_Elmt (Iface, Abstract_Interfaces (T));
199 end if;
200 end Add_Interface;
201
202 -------------
203 -- Collect --
204 -------------
205
206 procedure Collect (Typ : Entity_Id) is
207 Nod : constant Node_Id := Type_Definition (Parent (Typ));
208 Id : Node_Id;
209 Iface : Entity_Id;
210 Ancestor : Entity_Id;
211
212 begin
213 pragma Assert (False
214 or else Nkind (Nod) = N_Derived_Type_Definition
215 or else Nkind (Nod) = N_Record_Definition);
216
217 if Nkind (Nod) = N_Record_Definition then
218 return;
219 end if;
220
221 -- Include the ancestor if we are generating the whole list
222 -- of interfaces. This is used to know the size of the table
223 -- that stores the tag of all the ancestor interfaces.
224
225 Ancestor := Etype (Typ);
226
227 if Is_Interface (Ancestor) then
228 Add_Interface (Ancestor);
229 end if;
230
231 if Ancestor /= Typ
232 and then Ekind (Ancestor) /= E_Record_Type_With_Private
233 then
234 Collect (Ancestor);
235 end if;
236
237 -- Traverse the graph of ancestor interfaces
238
239 if Is_Non_Empty_List (Interface_List (Nod)) then
240 Id := First (Interface_List (Nod));
241
242 while Present (Id) loop
243
244 Iface := Etype (Id);
245
246 if Is_Interface (Iface) then
247 Add_Interface (Iface);
248 Collect (Iface);
249 end if;
250
251 Next (Id);
252 end loop;
253 end if;
254 end Collect;
255
256 -- Start of processing for Collect_All_Interfaces
257
258 begin
259 Collect (T);
260 end Collect_All_Interfaces;
261
262 ------------------------------
263 -- Default_Prim_Op_Position --
264 ------------------------------
265
266 function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
267 TSS_Name : TSS_Name_Type;
268 E : Entity_Id := Subp;
269
270 begin
271 -- Handle overriden subprograms
272
273 while Present (Alias (E)) loop
274 E := Alias (E);
275 end loop;
276
277 Get_Name_String (Chars (E));
278 TSS_Name :=
279 TSS_Name_Type
280 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
281
282 if Chars (E) = Name_uSize then
283 return Uint_1;
284
285 elsif Chars (E) = Name_uAlignment then
286 return Uint_2;
287
288 elsif TSS_Name = TSS_Stream_Read then
289 return Uint_3;
290
291 elsif TSS_Name = TSS_Stream_Write then
292 return Uint_4;
293
294 elsif TSS_Name = TSS_Stream_Input then
295 return Uint_5;
296
297 elsif TSS_Name = TSS_Stream_Output then
298 return Uint_6;
299
300 elsif Chars (E) = Name_Op_Eq then
301 return Uint_7;
302
303 elsif Chars (E) = Name_uAssign then
304 return Uint_8;
305
306 elsif TSS_Name = TSS_Deep_Adjust then
307 return Uint_9;
308
309 elsif TSS_Name = TSS_Deep_Finalize then
310 return Uint_10;
311
312 else
313 raise Program_Error;
314 end if;
315 end Default_Prim_Op_Position;
316
7189d17f 317 -----------------------------
318 -- Expand_Dispatching_Call --
319 -----------------------------
ee6ba406 320
7189d17f 321 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
ee6ba406 322 Loc : constant Source_Ptr := Sloc (Call_Node);
323 Call_Typ : constant Entity_Id := Etype (Call_Node);
324
325 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
326 Param_List : constant List_Id := Parameter_Associations (Call_Node);
327 Subp : Entity_Id := Entity (Name (Call_Node));
328
7189d17f 329 CW_Typ : Entity_Id;
330 New_Call : Node_Id;
331 New_Call_Name : Node_Id;
332 New_Params : List_Id := No_List;
333 Param : Node_Id;
334 Res_Typ : Entity_Id;
335 Subp_Ptr_Typ : Entity_Id;
336 Subp_Typ : Entity_Id;
337 Typ : Entity_Id;
338 Eq_Prim_Op : Entity_Id := Empty;
339 Controlling_Tag : Node_Id;
ee6ba406 340
341 function New_Value (From : Node_Id) return Node_Id;
9dfe12ae 342 -- From is the original Expression. New_Value is equivalent to a call
343 -- to Duplicate_Subexpr with an explicit dereference when From is an
7189d17f 344 -- access parameter.
345
346 function Controlling_Type (Subp : Entity_Id) return Entity_Id;
347 -- Returns the tagged type for which Subp is a primitive subprogram
ee6ba406 348
9dfe12ae 349 ---------------
350 -- New_Value --
351 ---------------
352
ee6ba406 353 function New_Value (From : Node_Id) return Node_Id is
354 Res : constant Node_Id := Duplicate_Subexpr (From);
ee6ba406 355 begin
356 if Is_Access_Type (Etype (From)) then
357 return Make_Explicit_Dereference (Sloc (From), Res);
358 else
359 return Res;
360 end if;
361 end New_Value;
362
7189d17f 363 ----------------------
364 -- Controlling_Type --
365 ----------------------
366
367 function Controlling_Type (Subp : Entity_Id) return Entity_Id is
368 begin
369 if Ekind (Subp) = E_Function
370 and then Has_Controlling_Result (Subp)
371 then
372 return Base_Type (Etype (Subp));
373
374 else
375 declare
376 Formal : Entity_Id := First_Formal (Subp);
377
378 begin
379 while Present (Formal) loop
380 if Is_Controlling_Formal (Formal) then
381 if Is_Access_Type (Etype (Formal)) then
382 return Base_Type (Designated_Type (Etype (Formal)));
383 else
384 return Base_Type (Etype (Formal));
385 end if;
386 end if;
387
388 Next_Formal (Formal);
389 end loop;
390 end;
391 end if;
392
393 -- Controlling type not found (should never happen)
394
395 return Empty;
396 end Controlling_Type;
397
398 -- Start of processing for Expand_Dispatching_Call
ee6ba406 399
400 begin
7189d17f 401 -- If this is an inherited operation that was overridden, the body
ee6ba406 402 -- that is being called is its alias.
403
404 if Present (Alias (Subp))
405 and then Is_Inherited_Operation (Subp)
406 and then No (DTC_Entity (Subp))
407 then
408 Subp := Alias (Subp);
409 end if;
410
7189d17f 411 -- Expand_Dispatching_Call is called directly from the semantics,
412 -- so we need a check to see whether expansion is active before
413 -- proceeding.
ee6ba406 414
415 if not Expander_Active then
416 return;
417 end if;
418
7189d17f 419 -- Definition of the class-wide type and the tagged type
ee6ba406 420
7189d17f 421 -- If the controlling argument is itself a tag rather than a tagged
422 -- object, then use the class-wide type associated with the subprogram's
423 -- controlling type. This case can occur when a call to an inherited
424 -- primitive has an actual that originated from a default parameter
425 -- given by a tag-indeterminate call and when there is no other
426 -- controlling argument providing the tag (AI-239 requires dispatching).
427 -- This capability of dispatching directly by tag is also needed by the
428 -- implementation of AI-260 (for the generic dispatching constructors).
429
aad6babd 430 if Etype (Ctrl_Arg) = RTE (RE_Tag)
431 or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
432 then
7189d17f 433 CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
434
435 elsif Is_Access_Type (Etype (Ctrl_Arg)) then
ee6ba406 436 CW_Typ := Designated_Type (Etype (Ctrl_Arg));
7189d17f 437
ee6ba406 438 else
439 CW_Typ := Etype (Ctrl_Arg);
440 end if;
441
442 Typ := Root_Type (CW_Typ);
443
444 if not Is_Limited_Type (Typ) then
445 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
446 end if;
447
448 if Is_CPP_Class (Root_Type (Typ)) then
449
450 -- Create a new parameter list with the displaced 'this'
451
452 New_Params := New_List;
453 Param := First_Actual (Call_Node);
454 while Present (Param) loop
aad6babd 455 Append_To (New_Params, Relocate_Node (Param));
ee6ba406 456 Next_Actual (Param);
457 end loop;
458
459 elsif Present (Param_List) then
460
461 -- Generate the Tag checks when appropriate
462
463 New_Params := New_List;
464
465 Param := First_Actual (Call_Node);
466 while Present (Param) loop
467
468 -- No tag check with itself
469
470 if Param = Ctrl_Arg then
9dfe12ae 471 Append_To (New_Params,
472 Duplicate_Subexpr_Move_Checks (Param));
ee6ba406 473
474 -- No tag check for parameter whose type is neither tagged nor
475 -- access to tagged (for access parameters)
476
477 elsif No (Find_Controlling_Arg (Param)) then
478 Append_To (New_Params, Relocate_Node (Param));
479
7189d17f 480 -- No tag check for function dispatching on result if the
ee6ba406 481 -- Tag given by the context is this one
482
483 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
484 Append_To (New_Params, Relocate_Node (Param));
485
486 -- "=" is the only dispatching operation allowed to get
487 -- operands with incompatible tags (it just returns false).
9dfe12ae 488 -- We use Duplicate_Subexpr_Move_Checks instead of calling
489 -- Relocate_Node because the value will be duplicated to
490 -- check the tags.
ee6ba406 491
492 elsif Subp = Eq_Prim_Op then
9dfe12ae 493 Append_To (New_Params,
494 Duplicate_Subexpr_Move_Checks (Param));
ee6ba406 495
496 -- No check in presence of suppress flags
497
498 elsif Tag_Checks_Suppressed (Etype (Param))
499 or else (Is_Access_Type (Etype (Param))
500 and then Tag_Checks_Suppressed
501 (Designated_Type (Etype (Param))))
502 then
503 Append_To (New_Params, Relocate_Node (Param));
504
505 -- Optimization: no tag checks if the parameters are identical
506
507 elsif Is_Entity_Name (Param)
508 and then Is_Entity_Name (Ctrl_Arg)
509 and then Entity (Param) = Entity (Ctrl_Arg)
510 then
511 Append_To (New_Params, Relocate_Node (Param));
512
513 -- Now we need to generate the Tag check
514
515 else
516 -- Generate code for tag equality check
517 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
518
519 Insert_Action (Ctrl_Arg,
520 Make_Implicit_If_Statement (Call_Node,
521 Condition =>
522 Make_Op_Ne (Loc,
523 Left_Opnd =>
524 Make_Selected_Component (Loc,
525 Prefix => New_Value (Ctrl_Arg),
526 Selector_Name =>
4660e715 527 New_Reference_To
528 (First_Tag_Component (Typ), Loc)),
ee6ba406 529
530 Right_Opnd =>
531 Make_Selected_Component (Loc,
532 Prefix =>
533 Unchecked_Convert_To (Typ, New_Value (Param)),
534 Selector_Name =>
4660e715 535 New_Reference_To
536 (First_Tag_Component (Typ), Loc))),
ee6ba406 537
538 Then_Statements =>
539 New_List (New_Constraint_Error (Loc))));
540
541 Append_To (New_Params, Relocate_Node (Param));
542 end if;
543
544 Next_Actual (Param);
545 end loop;
546 end if;
547
548 -- Generate the appropriate subprogram pointer type
549
550 if Etype (Subp) = Typ then
551 Res_Typ := CW_Typ;
552 else
7189d17f 553 Res_Typ := Etype (Subp);
ee6ba406 554 end if;
555
556 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
557 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
558 Set_Etype (Subp_Typ, Res_Typ);
559 Init_Size_Align (Subp_Ptr_Typ);
560 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
561
562 -- Create a new list of parameters which is a copy of the old formal
563 -- list including the creation of a new set of matching entities.
564
565 declare
566 Old_Formal : Entity_Id := First_Formal (Subp);
567 New_Formal : Entity_Id;
568 Extra : Entity_Id;
569
570 begin
571 if Present (Old_Formal) then
572 New_Formal := New_Copy (Old_Formal);
573 Set_First_Entity (Subp_Typ, New_Formal);
574 Param := First_Actual (Call_Node);
575
576 loop
577 Set_Scope (New_Formal, Subp_Typ);
578
579 -- Change all the controlling argument types to be class-wide
7189d17f 580 -- to avoid a recursion in dispatching.
ee6ba406 581
7189d17f 582 if Is_Controlling_Formal (New_Formal) then
ee6ba406 583 Set_Etype (New_Formal, Etype (Param));
584 end if;
585
586 if Is_Itype (Etype (New_Formal)) then
587 Extra := New_Copy (Etype (New_Formal));
588
589 if Ekind (Extra) = E_Record_Subtype
590 or else Ekind (Extra) = E_Class_Wide_Subtype
591 then
592 Set_Cloned_Subtype (Extra, Etype (New_Formal));
593 end if;
594
595 Set_Etype (New_Formal, Extra);
596 Set_Scope (Etype (New_Formal), Subp_Typ);
597 end if;
598
599 Extra := New_Formal;
600 Next_Formal (Old_Formal);
601 exit when No (Old_Formal);
602
603 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
604 Next_Entity (New_Formal);
605 Next_Actual (Param);
606 end loop;
607 Set_Last_Entity (Subp_Typ, Extra);
608
609 -- Copy extra formals
610
611 New_Formal := First_Entity (Subp_Typ);
612 while Present (New_Formal) loop
613 if Present (Extra_Constrained (New_Formal)) then
614 Set_Extra_Formal (Extra,
615 New_Copy (Extra_Constrained (New_Formal)));
616 Extra := Extra_Formal (Extra);
617 Set_Extra_Constrained (New_Formal, Extra);
618
619 elsif Present (Extra_Accessibility (New_Formal)) then
620 Set_Extra_Formal (Extra,
621 New_Copy (Extra_Accessibility (New_Formal)));
622 Extra := Extra_Formal (Extra);
623 Set_Extra_Accessibility (New_Formal, Extra);
624 end if;
625
626 Next_Formal (New_Formal);
627 end loop;
628 end if;
629 end;
630
631 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
632 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
633
7189d17f 634 -- If the controlling argument is a value of type Ada.Tag then
635 -- use it directly. Otherwise, the tag must be extracted from
636 -- the controlling object.
637
aad6babd 638 if Etype (Ctrl_Arg) = RTE (RE_Tag)
639 or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
640 then
7189d17f 641 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
642
643 else
644 Controlling_Tag :=
645 Make_Selected_Component (Loc,
646 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
647 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
648 end if;
649
ee6ba406 650 -- Generate:
651 -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
652
653 New_Call_Name :=
654 Unchecked_Convert_To (Subp_Ptr_Typ,
655 Make_DT_Access_Action (Typ,
656 Action => Get_Prim_Op_Address,
657 Args => New_List (
658
659 -- Vptr
660
7189d17f 661 Controlling_Tag,
ee6ba406 662
663 -- Position
664
665 Make_Integer_Literal (Loc, DT_Position (Subp)))));
666
667 if Nkind (Call_Node) = N_Function_Call then
ee6ba406 668
aad6babd 669 -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface
670 -- just requires the comparison of the tags.
ee6ba406 671
aad6babd 672 if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
673 and then Is_Interface (Etype (Ctrl_Arg))
674 and then Subp = Eq_Prim_Op
675 then
ee6ba406 676 Param := First_Actual (Call_Node);
ee6ba406 677
aad6babd 678 New_Call :=
679 Make_Op_Eq (Loc,
680 Left_Opnd =>
681 Make_Selected_Component (Loc,
682 Prefix => New_Value (Param),
683 Selector_Name =>
684 New_Reference_To (First_Tag_Component (Typ), Loc)),
685
686 Right_Opnd =>
687 Make_Selected_Component (Loc,
688 Prefix =>
689 Unchecked_Convert_To (Typ,
690 New_Value (Next_Actual (Param))),
691 Selector_Name =>
692 New_Reference_To (First_Tag_Component (Typ), Loc)));
ee6ba406 693
aad6babd 694 else
695 New_Call :=
696 Make_Function_Call (Loc,
697 Name => New_Call_Name,
698 Parameter_Associations => New_Params);
699
700 -- If this is a dispatching "=", we must first compare the tags so
701 -- we generate: x.tag = y.tag and then x = y
702
703 if Subp = Eq_Prim_Op then
704 Param := First_Actual (Call_Node);
705 New_Call :=
706 Make_And_Then (Loc,
707 Left_Opnd =>
708 Make_Op_Eq (Loc,
709 Left_Opnd =>
710 Make_Selected_Component (Loc,
711 Prefix => New_Value (Param),
712 Selector_Name =>
713 New_Reference_To (First_Tag_Component (Typ),
714 Loc)),
715
716 Right_Opnd =>
717 Make_Selected_Component (Loc,
718 Prefix =>
719 Unchecked_Convert_To (Typ,
720 New_Value (Next_Actual (Param))),
721 Selector_Name =>
722 New_Reference_To (First_Tag_Component (Typ),
723 Loc))),
724 Right_Opnd => New_Call);
725 end if;
ee6ba406 726 end if;
727
728 else
729 New_Call :=
730 Make_Procedure_Call_Statement (Loc,
731 Name => New_Call_Name,
732 Parameter_Associations => New_Params);
733 end if;
734
735 Rewrite (Call_Node, New_Call);
736 Analyze_And_Resolve (Call_Node, Call_Typ);
7189d17f 737 end Expand_Dispatching_Call;
ee6ba406 738
aad6babd 739 ---------------------------------
740 -- Expand_Interface_Conversion --
741 ---------------------------------
742
743 procedure Expand_Interface_Conversion (N : Node_Id) is
744 Loc : constant Source_Ptr := Sloc (N);
745 Operand : constant Node_Id := Expression (N);
746 Operand_Typ : Entity_Id := Etype (Operand);
747 Target_Type : Entity_Id := Etype (N);
748 Iface_Tag : Entity_Id;
749
750 begin
751 pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
752
753 -- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces
754
755 if Ekind (Operand_Typ) = E_Task_Type
756 or else Ekind (Operand_Typ) = E_Protected_Type
757 then
758 Operand_Typ := Corresponding_Record_Type (Operand_Typ);
759 end if;
760
761 if Is_Access_Type (Target_Type) then
762 Target_Type := Etype (Directly_Designated_Type (Target_Type));
763
764 elsif Is_Class_Wide_Type (Target_Type) then
765 Target_Type := Etype (Target_Type);
766 end if;
767
768 pragma Assert (not Is_Class_Wide_Type (Target_Type)
769 and then Is_Interface (Target_Type));
770
771 Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type);
772
773 pragma Assert (Iface_Tag /= Empty);
774
775 Rewrite (N,
776 Unchecked_Convert_To (Etype (N),
777 Make_Attribute_Reference (Loc,
778 Prefix => Make_Selected_Component (Loc,
779 Prefix => Relocate_Node (Expression (N)),
780 Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)),
781 Attribute_Name => Name_Address)));
782
783 Analyze (N);
784 end Expand_Interface_Conversion;
785
786 ------------------------------
787 -- Expand_Interface_Actuals --
788 ------------------------------
789
790 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
791 Loc : constant Source_Ptr := Sloc (Call_Node);
792 Actual : Node_Id;
793 Actual_Typ : Entity_Id;
794 Conversion : Node_Id;
795 Formal : Entity_Id;
796 Formal_Typ : Entity_Id;
797 Subp : Entity_Id;
798 Nam : Name_Id;
799
800 begin
801 -- This subprogram is called directly from the semantics, so we need a
802 -- check to see whether expansion is active before proceeding.
803
804 if not Expander_Active then
805 return;
806 end if;
807
808 -- Call using access to subprogram with explicit dereference
809
810 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
811 Subp := Etype (Name (Call_Node));
812
813 -- Normal case
814
815 else
816 Subp := Entity (Name (Call_Node));
817 end if;
818
819 Formal := First_Formal (Subp);
820 Actual := First_Actual (Call_Node);
821
822 while Present (Formal) loop
823
824 pragma Assert (Ekind (Etype (Etype (Formal)))
825 /= E_Record_Type_With_Private);
826
827 -- Ada 2005 (AI-251): Conversion to interface to force "this"
828 -- displacement
829
830 Formal_Typ := Etype (Etype (Formal));
831 Actual_Typ := Etype (Actual);
832
833 if Is_Interface (Formal_Typ) then
834
835 Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual));
836 Rewrite (Actual, Conversion);
837 Analyze_And_Resolve (Actual, Formal_Typ);
838
839 Rewrite (Actual,
840 Make_Explicit_Dereference (Loc,
841 Unchecked_Convert_To
842 (Build_Anonymous_Access_Type (Formal_Typ, Call_Node),
843 Relocate_Node (Expression (Actual)))));
844
845 Analyze_And_Resolve (Actual, Formal_Typ);
846
847 -- Anonymous access type
848
849 elsif Is_Access_Type (Formal_Typ)
850 and then Is_Interface (Etype
851 (Directly_Designated_Type
852 (Formal_Typ)))
853 and then Interface_Present_In_Ancestor
854 (Typ => Etype (Directly_Designated_Type
855 (Actual_Typ)),
856 Iface => Etype (Directly_Designated_Type
857 (Formal_Typ)))
858 then
859
860 if Nkind (Actual) = N_Attribute_Reference
861 and then
862 (Attribute_Name (Actual) = Name_Access
863 or else Attribute_Name (Actual) = Name_Unchecked_Access)
864 then
865 Nam := Attribute_Name (Actual);
866
867 Conversion :=
868 Convert_To
869 (Etype (Directly_Designated_Type (Formal_Typ)),
870 Prefix (Actual));
871
872 Rewrite (Actual, Conversion);
873
874 Analyze_And_Resolve (Actual,
875 Etype (Directly_Designated_Type (Formal_Typ)));
876
877 Rewrite (Actual,
878 Unchecked_Convert_To (Formal_Typ,
879 Make_Attribute_Reference (Loc,
880 Prefix =>
881 Relocate_Node (Prefix (Expression (Actual))),
882 Attribute_Name => Nam)));
883
884 Analyze_And_Resolve (Actual, Formal_Typ);
885
886 else
887 Conversion :=
888 Convert_To (Formal_Typ, New_Copy_Tree (Actual));
889 Rewrite (Actual, Conversion);
890 Analyze_And_Resolve (Actual, Formal_Typ);
891 end if;
892 end if;
893
894 Next_Actual (Actual);
895 Next_Formal (Formal);
896 end loop;
897 end Expand_Interface_Actuals;
898
899 ----------------------------
900 -- Expand_Interface_Thunk --
901 ----------------------------
902
903 function Expand_Interface_Thunk
904 (N : Node_Id;
905 Thunk_Id : Entity_Id;
906 Iface_Tag : Entity_Id) return Node_Id
907 is
908 Loc : constant Source_Ptr := Sloc (N);
909 Actuals : constant List_Id := New_List;
910 Decl : constant List_Id := New_List;
911 Formals : constant List_Id := New_List;
912 Thunk_Tag : constant Node_Id := Iface_Tag;
913 Thunk_Alias : constant Entity_Id := Alias (Entity (N));
914 Target : Entity_Id;
915 New_Code : Node_Id;
916 Formal : Node_Id;
917 New_Formal : Node_Id;
918 Decl_1 : Node_Id;
919 Decl_2 : Node_Id;
920 Subtyp_Mark : Node_Id;
921
922 begin
923
924 -- Traverse the list of alias to find the final target
925
926 Target := Thunk_Alias;
927
928 while Present (Alias (Target)) loop
929 Target := Alias (Target);
930 end loop;
931
932 -- Duplicate the formals
933
934 Formal := First_Formal (Thunk_Alias);
935
936 while Present (Formal) loop
937 New_Formal := Copy_Separate_Tree (Parent (Formal));
938
939 -- Handle the case in which the subprogram covering
940 -- the interface has been inherited:
941
942 -- Example:
943 -- type I is interface;
944 -- procedure P (X : in I) is abstract;
945
946 -- type T is tagged null record;
947 -- procedure P (X : T);
948
949 -- type DT is new T and I with ...
950
951 if Is_Controlling_Formal (Formal) then
952 Set_Parameter_Type (New_Formal,
953 New_Reference_To (Etype (First_Entity (Entity (N))), Loc));
954
955 -- Why is this line silently commented out ???
956
957 -- New_Reference_To (Etype (Formal), Loc));
958 end if;
959
960 Append_To (Formals, New_Formal);
961 Next_Formal (Formal);
962 end loop;
963
964 if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
965 and then Ekind (Etype (First_Formal (Thunk_Alias)))
966 = E_Anonymous_Access_Type
967 then
968
969 -- Generate:
970
971 -- type T is access all <<type of the first formal>>
972 -- S1 := Storage_Offset!(First_formal)
973 -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
974
975 -- ... and the first actual of the call is generated as T!(S1)
976
977 Decl_2 :=
978 Make_Full_Type_Declaration (Loc,
979 Defining_Identifier =>
980 Make_Defining_Identifier (Loc,
981 New_Internal_Name ('T')),
982 Type_Definition =>
983 Make_Access_To_Object_Definition (Loc,
984 All_Present => True,
985 Null_Exclusion_Present => False,
986 Constant_Present => False,
987 Subtype_Indication =>
988 New_Reference_To
989 (Directly_Designated_Type
990 (Etype (First_Formal (Thunk_Alias))), Loc)
991 ));
992
993 Decl_1 :=
994 Make_Object_Declaration (Loc,
995 Defining_Identifier =>
996 Make_Defining_Identifier (Loc,
997 New_Internal_Name ('S')),
998 Constant_Present => True,
999 Object_Definition =>
1000 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1001 Expression =>
1002 Make_Op_Subtract (Loc,
1003 Left_Opnd =>
1004 Unchecked_Convert_To
1005 (RTE (RE_Storage_Offset),
1006 New_Reference_To
1007 (Defining_Identifier (First (Formals)), Loc)),
1008 Right_Opnd =>
1009 Unchecked_Convert_To
1010 (RTE (RE_Storage_Offset),
1011 Make_Attribute_Reference (Loc,
1012 Prefix =>
1013 Make_Selected_Component (Loc,
1014 Prefix =>
1015 New_Reference_To
1016 (Defining_Identifier (First (Formals)), Loc),
1017 Selector_Name =>
1018 New_Occurrence_Of (Thunk_Tag, Loc)),
1019 Attribute_Name => Name_Position))));
1020
1021 Append_To (Decl, Decl_2);
1022 Append_To (Decl, Decl_1);
1023
1024 -- Reference the new first actual
1025
1026 Append_To (Actuals,
1027 Unchecked_Convert_To
1028 (Defining_Identifier (Decl_2),
1029 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1030
1031 -- Side note: The reverse order of declarations is just to ensure
1032 -- that the call to RE_Print is correct.
1033
1034 else
1035 -- Generate:
1036 --
1037 -- S1 := Storage_Offset!(First_formal'Address)
1038 -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
1039 -- S2 := Tag_Ptr!(S3)
1040
1041 Decl_1 :=
1042 Make_Object_Declaration (Loc,
1043 Defining_Identifier =>
1044 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1045 Constant_Present => True,
1046 Object_Definition =>
1047 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1048 Expression =>
1049 Make_Op_Subtract (Loc,
1050 Left_Opnd =>
1051 Unchecked_Convert_To
1052 (RTE (RE_Storage_Offset),
1053 Make_Attribute_Reference (Loc,
1054 Prefix =>
1055 New_Reference_To
1056 (Defining_Identifier (First (Formals)), Loc),
1057 Attribute_Name => Name_Address)),
1058 Right_Opnd =>
1059 Unchecked_Convert_To
1060 (RTE (RE_Storage_Offset),
1061 Make_Attribute_Reference (Loc,
1062 Prefix =>
1063 Make_Selected_Component (Loc,
1064 Prefix =>
1065 New_Reference_To
1066 (Defining_Identifier (First (Formals)), Loc),
1067 Selector_Name =>
1068 New_Occurrence_Of (Thunk_Tag, Loc)),
1069 Attribute_Name => Name_Position))));
1070
1071 Decl_2 :=
1072 Make_Object_Declaration (Loc,
1073 Defining_Identifier =>
1074 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1075 Constant_Present => True,
1076 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1077 Expression =>
1078 Unchecked_Convert_To
1079 (RTE (RE_Addr_Ptr),
1080 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1081
1082 Append_To (Decl, Decl_1);
1083 Append_To (Decl, Decl_2);
1084
1085 -- Reference the new first actual
1086
1087 Append_To (Actuals,
1088 Unchecked_Convert_To
1089 (Etype (First_Entity (Target)),
1090 Make_Explicit_Dereference (Loc,
1091 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1092
1093 end if;
1094
1095 Formal := Next (First (Formals));
1096 while Present (Formal) loop
1097 Append_To (Actuals,
1098 New_Reference_To (Defining_Identifier (Formal), Loc));
1099 Next (Formal);
1100 end loop;
1101
1102 if Ekind (Thunk_Alias) = E_Procedure then
1103 New_Code :=
1104 Make_Subprogram_Body (Loc,
1105 Specification =>
1106 Make_Procedure_Specification (Loc,
1107 Defining_Unit_Name => Thunk_Id,
1108 Parameter_Specifications => Formals),
1109 Declarations => Decl,
1110 Handled_Statement_Sequence =>
1111 Make_Handled_Sequence_Of_Statements (Loc,
1112 Statements => New_List (
1113 Make_Procedure_Call_Statement (Loc,
1114 Name => New_Occurrence_Of (Target, Loc),
1115 Parameter_Associations => Actuals))));
1116
1117 else pragma Assert (Ekind (Thunk_Alias) = E_Function);
1118
1119 if not Present (Alias (Thunk_Alias)) then
1120 Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
1121 else
1122 -- The last element in the alias list has the correct subtype_mark
1123 -- of the function result
1124
1125 declare
1126 E : Entity_Id := Alias (Thunk_Alias);
1127 begin
1128 while Present (Alias (E)) loop
1129 E := Alias (E);
1130 end loop;
1131 Subtyp_Mark := Subtype_Mark (Parent (E));
1132 end;
1133 end if;
1134
1135 New_Code :=
1136 Make_Subprogram_Body (Loc,
1137 Specification =>
1138 Make_Function_Specification (Loc,
1139 Defining_Unit_Name => Thunk_Id,
1140 Parameter_Specifications => Formals,
1141 Subtype_Mark => New_Copy (Subtyp_Mark)),
1142 Declarations => Decl,
1143 Handled_Statement_Sequence =>
1144 Make_Handled_Sequence_Of_Statements (Loc,
1145 Statements => New_List (
1146 Make_Return_Statement (Loc,
1147 Make_Function_Call (Loc,
1148 Name => New_Occurrence_Of (Target, Loc),
1149 Parameter_Associations => Actuals)))));
1150 end if;
1151
1152 Analyze (New_Code);
1153 Insert_After (N, New_Code);
1154 return New_Code;
1155 end Expand_Interface_Thunk;
1156
ee6ba406 1157 -------------
1158 -- Fill_DT --
1159 -------------
1160
1161 function Fill_DT_Entry
aad6babd 1162 (Loc : Source_Ptr;
1163 Prim : Entity_Id;
1164 Thunk_Id : Entity_Id := Empty) return Node_Id
ee6ba406 1165 is
aad6babd 1166 Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
1167 DT_Ptr : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ)));
1168 Target : Entity_Id;
1169 Tag : Entity_Id := First_Tag_Component (Typ);
1170 Prim_Op : Entity_Id := Prim;
ee6ba406 1171
1172 begin
aad6babd 1173 -- Ada 2005 (AI-251): If we have a thunk available then generate code
1174 -- that saves its address in the secondary dispatch table of its
1175 -- abstract interface; otherwise save the address of the primitive
1176 -- subprogram in the main virtual table.
1177
1178 if Thunk_Id /= Empty then
1179 Target := Thunk_Id;
1180 else
1181 Target := Prim;
1182 end if;
1183
1184 -- Ada 2005 (AI-251): If the subprogram is the alias of an abstract
1185 -- interface subprogram then find the correct dispatch table pointer
1186
1187 if Present (Abstract_Interface_Alias (Prim)) then
1188 Prim_Op := Abstract_Interface_Alias (Prim);
1189
1190 DT_Ptr := Find_Interface_ADT
1191 (T => Typ,
1192 Iface => Scope (DTC_Entity (Prim_Op)));
1193
1194 Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op)));
1195 end if;
1196
1197 pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag));
1198 pragma Assert (DT_Position (Prim_Op) > Uint_0);
1199
ee6ba406 1200 return
1201 Make_DT_Access_Action (Typ,
1202 Action => Set_Prim_Op_Address,
1203 Args => New_List (
aad6babd 1204 Unchecked_Convert_To (RTE (RE_Tag),
1205 New_Reference_To (DT_Ptr, Loc)), -- DTptr
ee6ba406 1206
aad6babd 1207 Make_Integer_Literal (Loc, DT_Position (Prim_Op)), -- Position
ee6ba406 1208
1209 Make_Attribute_Reference (Loc, -- Value
aad6babd 1210 Prefix => New_Reference_To (Target, Loc),
ee6ba406 1211 Attribute_Name => Name_Address)));
1212 end Fill_DT_Entry;
1213
1214 ---------------------------
1215 -- Get_Remotely_Callable --
1216 ---------------------------
1217
1218 function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
1219 Loc : constant Source_Ptr := Sloc (Obj);
1220
1221 begin
1222 return Make_DT_Access_Action
1223 (Typ => Etype (Obj),
1224 Action => Get_Remotely_Callable,
1225 Args => New_List (
1226 Make_Selected_Component (Loc,
1227 Prefix => Obj,
1228 Selector_Name => Make_Identifier (Loc, Name_uTag))));
1229 end Get_Remotely_Callable;
1230
1231 -------------
1232 -- Make_DT --
1233 -------------
1234
1235 function Make_DT (Typ : Entity_Id) return List_Id is
aad6babd 1236 Loc : constant Source_Ptr := Sloc (Typ);
1237 Result : constant List_Id := New_List;
1238 Elab_Code : constant List_Id := New_List;
ee6ba406 1239
1240 Tname : constant Name_Id := Chars (Typ);
1241 Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
1242 Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
1243 Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
1244 Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
1245 Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
1246
1247 DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
1248 DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
1249 TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
1250 Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
1251 No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
1252
aad6babd 1253 Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
ee6ba406 1254 I_Depth : Int;
ee6ba406 1255 Size_Expr_Node : Node_Id;
64cf6b82 1256 Old_Tag1 : Node_Id;
1257 Old_Tag2 : Node_Id;
aad6babd 1258 Num_Ifaces : Int;
1259 Nb_Prim : Int;
1260 TSD_Num_Entries : Int;
1261 Typ_Copy : constant Entity_Id := New_Copy (Typ);
1262 AI : Elmt_Id;
ee6ba406 1263
1264 begin
9dfe12ae 1265 if not RTE_Available (RE_Tag) then
1266 Error_Msg_CRT ("tagged types", Typ);
1267 return New_List;
1268 end if;
1269
aad6babd 1270 -- Collect the full list of directly and indirectly implemented
1271 -- interfaces
1272
1273 Set_Parent (Typ_Copy, Parent (Typ));
1274 Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
1275 Collect_All_Interfaces (Typ_Copy);
1276
1277 -- Calculate the number of entries required in the table of interfaces
1278
1279 Num_Ifaces := 0;
1280 AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
1281
1282 while Present (AI) loop
1283 Num_Ifaces := Num_Ifaces + 1;
1284 Next_Elmt (AI);
1285 end loop;
1286
1287 -- Count ancestors to compute the inheritance depth. For private
1288 -- extensions, always go to the full view in order to compute the real
1289 -- inheritance depth.
1290
1291 declare
1292 Parent_Type : Entity_Id := Typ;
1293 P : Entity_Id;
1294
1295 begin
1296 I_Depth := 0;
1297
1298 loop
1299 P := Etype (Parent_Type);
1300
1301 if Is_Private_Type (P) then
1302 P := Full_View (Base_Type (P));
1303 end if;
1304
1305 exit when P = Parent_Type;
1306
1307 I_Depth := I_Depth + 1;
1308 Parent_Type := P;
1309 end loop;
1310 end;
1311
1312 TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
1313 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
1314
1315 -- ----------------------------------------------------------------
ee6ba406 1316
1317 -- Dispatch table and related entities are allocated statically
1318
1319 Set_Ekind (DT, E_Variable);
1320 Set_Is_Statically_Allocated (DT);
1321
1322 Set_Ekind (DT_Ptr, E_Variable);
1323 Set_Is_Statically_Allocated (DT_Ptr);
1324
1325 Set_Ekind (TSD, E_Variable);
1326 Set_Is_Statically_Allocated (TSD);
1327
1328 Set_Ekind (Exname, E_Variable);
1329 Set_Is_Statically_Allocated (Exname);
1330
1331 Set_Ekind (No_Reg, E_Variable);
1332 Set_Is_Statically_Allocated (No_Reg);
1333
1334 -- Generate code to create the storage for the Dispatch_Table object:
1335
1336 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1337 -- for DT'Alignment use Address'Alignment
1338
1339 Size_Expr_Node :=
1340 Make_Op_Add (Loc,
1341 Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
1342 Right_Opnd =>
1343 Make_Op_Multiply (Loc,
1344 Left_Opnd =>
1345 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
1346 Right_Opnd =>
aad6babd 1347 Make_Integer_Literal (Loc, Nb_Prim)));
ee6ba406 1348
1349 Append_To (Result,
1350 Make_Object_Declaration (Loc,
1351 Defining_Identifier => DT,
1352 Aliased_Present => True,
1353 Object_Definition =>
1354 Make_Subtype_Indication (Loc,
1355 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1356 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
1357 Constraints => New_List (
1358 Make_Range (Loc,
1359 Low_Bound => Make_Integer_Literal (Loc, 1),
1360 High_Bound => Size_Expr_Node))))));
1361
1362 Append_To (Result,
1363 Make_Attribute_Definition_Clause (Loc,
1364 Name => New_Reference_To (DT, Loc),
1365 Chars => Name_Alignment,
1366 Expression =>
1367 Make_Attribute_Reference (Loc,
1368 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1369 Attribute_Name => Name_Alignment)));
1370
1371 -- Generate code to create the pointer to the dispatch table
1372
aad6babd 1373 -- DT_Ptr : Tag := Tag!(DT'Address);
ee6ba406 1374
aad6babd 1375 -- According to the C++ ABI, the base of the vtable is located after a
1376 -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
1377 -- down the pointer to the real base of the vtable
7189d17f 1378
ee6ba406 1379 Append_To (Result,
1380 Make_Object_Declaration (Loc,
1381 Defining_Identifier => DT_Ptr,
1382 Constant_Present => True,
1383 Object_Definition => New_Reference_To (Generalized_Tag, Loc),
1384 Expression =>
1385 Unchecked_Convert_To (Generalized_Tag,
7189d17f 1386 Make_Op_Add (Loc,
1387 Left_Opnd =>
1388 Unchecked_Convert_To (RTE (RE_Storage_Offset),
1389 Make_Attribute_Reference (Loc,
1390 Prefix => New_Reference_To (DT, Loc),
1391 Attribute_Name => Name_Address)),
1392 Right_Opnd =>
1393 Make_DT_Access_Action (Typ,
1394 DT_Prologue_Size, No_List)))));
ee6ba406 1395
1396 -- Generate code to define the boolean that controls registration, in
1397 -- order to avoid multiple registrations for tagged types defined in
1398 -- multiple-called scopes
1399
1400 Append_To (Result,
1401 Make_Object_Declaration (Loc,
1402 Defining_Identifier => No_Reg,
1403 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
1404 Expression => New_Reference_To (Standard_True, Loc)));
1405
1406 -- Set Access_Disp_Table field to be the dispatch table pointer
1407
aad6babd 1408 if not Present (Access_Disp_Table (Typ)) then
1409 Set_Access_Disp_Table (Typ, New_Elmt_List);
1410 end if;
ee6ba406 1411
aad6babd 1412 Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
ee6ba406 1413
1414 -- Generate code to create the storage for the type specific data object
aad6babd 1415 -- with enough space to store the tags of the ancestors plus the tags
1416 -- of all the implemented interfaces (as described in a-tags.adb)
1417 --
1418 -- TSD: Storage_Array
1419 -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
ee6ba406 1420 -- for TSD'Alignment use Address'Alignment
1421
1422 Size_Expr_Node :=
1423 Make_Op_Add (Loc,
1424 Left_Opnd =>
1425 Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
1426 Right_Opnd =>
1427 Make_Op_Multiply (Loc,
1428 Left_Opnd =>
1429 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
1430 Right_Opnd =>
aad6babd 1431 Make_Integer_Literal (Loc, TSD_Num_Entries)));
ee6ba406 1432
1433 Append_To (Result,
1434 Make_Object_Declaration (Loc,
1435 Defining_Identifier => TSD,
1436 Aliased_Present => True,
1437 Object_Definition =>
1438 Make_Subtype_Indication (Loc,
1439 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1440 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
1441 Constraints => New_List (
1442 Make_Range (Loc,
1443 Low_Bound => Make_Integer_Literal (Loc, 1),
1444 High_Bound => Size_Expr_Node))))));
1445
1446 Append_To (Result,
1447 Make_Attribute_Definition_Clause (Loc,
1448 Name => New_Reference_To (TSD, Loc),
1449 Chars => Name_Alignment,
1450 Expression =>
1451 Make_Attribute_Reference (Loc,
1452 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1453 Attribute_Name => Name_Alignment)));
1454
1455 -- Generate code to put the Address of the TSD in the dispatch table
1456 -- Set_TSD (DT_Ptr, TSD);
1457
1458 Append_To (Elab_Code,
1459 Make_DT_Access_Action (Typ,
1460 Action => Set_TSD,
1461 Args => New_List (
1462 New_Reference_To (DT_Ptr, Loc), -- DTptr
1463 Make_Attribute_Reference (Loc, -- Value
1464 Prefix => New_Reference_To (TSD, Loc),
1465 Attribute_Name => Name_Address))));
1466
aad6babd 1467 -- Generate: Exname : constant String := full_qualified_name (typ);
1468 -- The type itself may be an anonymous parent type, so use the first
1469 -- subtype to have a user-recognizable name.
1470
1471 Append_To (Result,
1472 Make_Object_Declaration (Loc,
1473 Defining_Identifier => Exname,
1474 Constant_Present => True,
1475 Object_Definition => New_Reference_To (Standard_String, Loc),
1476 Expression =>
1477 Make_String_Literal (Loc,
1478 Full_Qualified_Name (First_Subtype (Typ)))));
1479
1480 -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
1481
1482 Append_To (Elab_Code,
1483 Make_DT_Access_Action (Typ,
1484 Action => Set_Expanded_Name,
1485 Args => New_List (
1486 Node1 => New_Reference_To (DT_Ptr, Loc),
1487 Node2 =>
1488 Make_Attribute_Reference (Loc,
1489 Prefix => New_Reference_To (Exname, Loc),
1490 Attribute_Name => Name_Address))));
1491
1492 -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
1493
1494 Append_To (Elab_Code,
1495 Make_DT_Access_Action (Typ,
1496 Action => Set_Access_Level,
1497 Args => New_List (
1498 Node1 => New_Reference_To (DT_Ptr, Loc),
1499 Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
1500
1501 -- Generate:
1502 -- Set_Offset_To_Top (DT_Ptr, 0);
1503
1504 Append_To (Elab_Code,
1505 Make_Procedure_Call_Statement (Loc,
1506 Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
1507 Parameter_Associations => New_List (
1508 New_Reference_To (DT_Ptr, Loc),
1509 Make_Integer_Literal (Loc, Uint_0))));
1510
ee6ba406 1511 if Typ = Etype (Typ)
1512 or else Is_CPP_Class (Etype (Typ))
1513 then
64cf6b82 1514 Old_Tag1 :=
ee6ba406 1515 Unchecked_Convert_To (Generalized_Tag,
1516 Make_Integer_Literal (Loc, 0));
64cf6b82 1517 Old_Tag2 :=
1518 Unchecked_Convert_To (Generalized_Tag,
ee6ba406 1519 Make_Integer_Literal (Loc, 0));
1520
1521 else
64cf6b82 1522 Old_Tag1 :=
1523 New_Reference_To
1524 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
1525 Old_Tag2 :=
4660e715 1526 New_Reference_To
1527 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
ee6ba406 1528 end if;
1529
1530 -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
1531
1532 Append_To (Elab_Code,
1533 Make_DT_Access_Action (Typ,
1534 Action => Inherit_DT,
1535 Args => New_List (
64cf6b82 1536 Node1 => Old_Tag1,
ee6ba406 1537 Node2 => New_Reference_To (DT_Ptr, Loc),
1538 Node3 => Make_Integer_Literal (Loc,
4660e715 1539 DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
ee6ba406 1540
64cf6b82 1541 -- Generate: Inherit_TSD (parent'tag, DT_Ptr);
ee6ba406 1542
1543 Append_To (Elab_Code,
1544 Make_DT_Access_Action (Typ,
1545 Action => Inherit_TSD,
1546 Args => New_List (
64cf6b82 1547 Node1 => Old_Tag2,
ee6ba406 1548 Node2 => New_Reference_To (DT_Ptr, Loc))));
1549
ee6ba406 1550 -- for types with no controlled components
1551 -- Generate: Set_RC_Offset (DT_Ptr, 0);
1552 -- for simple types with controlled components
1553 -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
1554 -- for complex types with controlled components where the position
9dfe12ae 1555 -- of the record controller is not statically computable, if there are
1556 -- controlled components at this level
ee6ba406 1557 -- Generate: Set_RC_Offset (DT_Ptr, -1);
9dfe12ae 1558 -- to indicate that the _controller field is right after the _parent or
1559 -- if there are no controlled components at this level,
1560 -- Generate: Set_RC_Offset (DT_Ptr, -2);
1561 -- to indicate that we need to get the position from the parent.
ee6ba406 1562
1563 declare
1564 Position : Node_Id;
1565
1566 begin
1567 if not Has_Controlled_Component (Typ) then
1568 Position := Make_Integer_Literal (Loc, 0);
1569
1570 elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
9dfe12ae 1571 if Has_New_Controlled_Component (Typ) then
1572 Position := Make_Integer_Literal (Loc, -1);
1573 else
1574 Position := Make_Integer_Literal (Loc, -2);
1575 end if;
ee6ba406 1576 else
1577 Position :=
1578 Make_Attribute_Reference (Loc,
1579 Prefix =>
1580 Make_Selected_Component (Loc,
1581 Prefix => New_Reference_To (Typ, Loc),
1582 Selector_Name =>
1583 New_Reference_To (Controller_Component (Typ), Loc)),
1584 Attribute_Name => Name_Position);
1585
9dfe12ae 1586 -- This is not proper Ada code to use the attribute 'Position
ee6ba406 1587 -- on something else than an object but this is supported by
1588 -- the back end (see comment on the Bit_Component attribute in
1589 -- sem_attr). So we avoid semantic checking here.
1590
1591 Set_Analyzed (Position);
1592 Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
1593 Set_Etype (Prefix (Prefix (Position)), Typ);
1594 Set_Etype (Selector_Name (Prefix (Position)),
1595 RTE (RE_Record_Controller));
1596 Set_Etype (Position, RTE (RE_Storage_Offset));
ee6ba406 1597 end if;
1598
1599 Append_To (Elab_Code,
1600 Make_DT_Access_Action (Typ,
1601 Action => Set_RC_Offset,
1602 Args => New_List (
1603 Node1 => New_Reference_To (DT_Ptr, Loc),
1604 Node2 => Position)));
1605 end;
1606
1bbc9831 1607 -- Generate: Set_Remotely_Callable (DT_Ptr, Status);
1608 -- where Status is described in E.4 (18)
ee6ba406 1609
1610 declare
1611 Status : Entity_Id;
1612
1613 begin
1bbc9831 1614 Status :=
1615 Boolean_Literals
1616 (Is_Pure (Typ)
1617 or else Is_Shared_Passive (Typ)
1618 or else
1619 ((Is_Remote_Types (Typ)
1620 or else Is_Remote_Call_Interface (Typ))
1621 and then Original_View_In_Visible_Part (Typ))
1622 or else not Comes_From_Source (Typ));
ee6ba406 1623
1624 Append_To (Elab_Code,
1625 Make_DT_Access_Action (Typ,
1626 Action => Set_Remotely_Callable,
1627 Args => New_List (
1628 New_Occurrence_Of (DT_Ptr, Loc),
1629 New_Occurrence_Of (Status, Loc))));
1630 end;
1631
1632 -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
1633 -- Should be the external name not the qualified name???
1634
1635 if not Has_External_Tag_Rep_Clause (Typ) then
1636 Append_To (Elab_Code,
1637 Make_DT_Access_Action (Typ,
1638 Action => Set_External_Tag,
1639 Args => New_List (
1640 Node1 => New_Reference_To (DT_Ptr, Loc),
1641 Node2 =>
1642 Make_Attribute_Reference (Loc,
1643 Prefix => New_Reference_To (Exname, Loc),
1644 Attribute_Name => Name_Address))));
1645
1646 -- Generate code to register the Tag in the External_Tag hash
9dfe12ae 1647 -- table for the pure Ada type only.
ee6ba406 1648
1649 -- Register_Tag (Dt_Ptr);
1650
05e5286d 1651 -- Skip this if routine not available, or in No_Run_Time mode
9dfe12ae 1652
1653 if RTE_Available (RE_Register_Tag)
1654 and then Is_RTE (Generalized_Tag, RE_Tag)
05e5286d 1655 and then not No_Run_Time_Mode
ee6ba406 1656 then
1657 Append_To (Elab_Code,
1658 Make_Procedure_Call_Statement (Loc,
1659 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
1660 Parameter_Associations =>
1661 New_List (New_Reference_To (DT_Ptr, Loc))));
1662 end if;
1663 end if;
1664
1665 -- Generate:
1666 -- if No_Reg then
1667 -- <elab_code>
1668 -- No_Reg := False;
1669 -- end if;
1670
1671 Append_To (Elab_Code,
1672 Make_Assignment_Statement (Loc,
1673 Name => New_Reference_To (No_Reg, Loc),
1674 Expression => New_Reference_To (Standard_False, Loc)));
1675
1676 Append_To (Result,
1677 Make_Implicit_If_Statement (Typ,
1678 Condition => New_Reference_To (No_Reg, Loc),
1679 Then_Statements => Elab_Code));
1680
aad6babd 1681 -- Ada 2005 (AI-251): Register the tag of the interfaces into
1682 -- the table of implemented interfaces
1683
1684 if Present (Abstract_Interfaces (Typ))
1685 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1686 then
1687 AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
1688 while Present (AI) loop
1689
1690 -- Generate:
1691 -- Register_Interface (DT_Ptr, Interface'Tag);
1692
1693 Append_To (Result,
1694 Make_DT_Access_Action (Typ,
1695 Action => Register_Interface_Tag,
1696 Args => New_List (
1697 Node1 => New_Reference_To (DT_Ptr, Loc),
1698 Node2 => New_Reference_To
1699 (Node
1700 (First_Elmt
1701 (Access_Disp_Table (Node (AI)))),
1702 Loc))));
1703
1704 Next_Elmt (AI);
1705 end loop;
1706 end if;
1707
ee6ba406 1708 return Result;
1709 end Make_DT;
1710
aad6babd 1711 --------------------------------
1712 -- Make_Abstract_Interface_DT --
1713 --------------------------------
1714
1715 procedure Make_Abstract_Interface_DT
1716 (AI_Tag : Entity_Id;
1717 Acc_Disp_Tables : in out Elist_Id;
1718 Result : out List_Id)
1719 is
1720 Loc : constant Source_Ptr := Sloc (AI_Tag);
1721 Tname : constant Name_Id := Chars (AI_Tag);
1722 Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
1723 Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
1724
1725 Iface_DT : constant Node_Id :=
1726 Make_Defining_Identifier (Loc, Name_DT);
1727 Iface_DT_Ptr : constant Node_Id :=
1728 Make_Defining_Identifier (Loc, Name_DT_Ptr);
1729
1730 Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
1731 Size_Expr_Node : Node_Id;
1732 Nb_Prim : Int;
1733
1734 begin
1735 Result := New_List;
1736
1737 -- Dispatch table and related entities are allocated statically
1738
1739 Set_Ekind (Iface_DT, E_Variable);
1740 Set_Is_Statically_Allocated (Iface_DT);
1741
1742 Set_Ekind (Iface_DT_Ptr, E_Variable);
1743 Set_Is_Statically_Allocated (Iface_DT_Ptr);
1744
1745 -- Generate code to create the storage for the Dispatch_Table object
1746
1747 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1748 -- for DT'Alignment use Address'Alignment
1749
1750 Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
1751
1752 Size_Expr_Node :=
1753 Make_Op_Add (Loc,
1754 Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
1755 DT_Prologue_Size,
1756 No_List),
1757 Right_Opnd =>
1758 Make_Op_Multiply (Loc,
1759 Left_Opnd =>
1760 Make_DT_Access_Action (Etype (AI_Tag),
1761 DT_Entry_Size,
1762 No_List),
1763 Right_Opnd =>
1764 Make_Integer_Literal (Loc, Nb_Prim)));
1765
1766 Append_To (Result,
1767 Make_Object_Declaration (Loc,
1768 Defining_Identifier => Iface_DT,
1769 Aliased_Present => True,
1770 Object_Definition =>
1771 Make_Subtype_Indication (Loc,
1772 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1773 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
1774 Constraints => New_List (
1775 Make_Range (Loc,
1776 Low_Bound => Make_Integer_Literal (Loc, 1),
1777 High_Bound => Size_Expr_Node)))),
1778
1779 -- Initialize the signature of the interface tag. It is currently
1780 -- a sequence of four bytes located in the unused Typeinfo_Ptr
1781 -- field of the prologue). Its current value is the following
1782 -- sequence: (80, Nb_Prim, 0, 80)
1783
1784 Expression =>
1785 Make_Aggregate (Loc,
1786 Component_Associations => New_List (
1787 Make_Component_Association (Loc,
1788
1789 -- -80, 0, 0, -80
1790
1791 Choices => New_List (
1792 Make_Integer_Literal (Loc, Uint_5),
1793 Make_Integer_Literal (Loc, Uint_8)),
1794 Expression =>
1795 Make_Integer_Literal (Loc, Uint_80)),
1796
1797 Make_Component_Association (Loc,
1798 Choices => New_List (
1799 Make_Integer_Literal (Loc, Uint_2)),
1800 Expression =>
1801 Make_Integer_Literal (Loc, Nb_Prim)),
1802
1803 Make_Component_Association (Loc,
1804 Choices => New_List (
1805 Make_Others_Choice (Loc)),
1806 Expression => Make_Integer_Literal (Loc, Uint_0))))));
1807
1808 Append_To (Result,
1809 Make_Attribute_Definition_Clause (Loc,
1810 Name => New_Reference_To (Iface_DT, Loc),
1811 Chars => Name_Alignment,
1812 Expression =>
1813 Make_Attribute_Reference (Loc,
1814 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1815 Attribute_Name => Name_Alignment)));
1816
1817 -- Generate code to create the pointer to the dispatch table
1818
1819 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
1820
1821 -- According to the C++ ABI, the base of the vtable is located
1822 -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
1823 -- Hence, move the pointer down to the real base of the vtable.
1824
1825 Append_To (Result,
1826 Make_Object_Declaration (Loc,
1827 Defining_Identifier => Iface_DT_Ptr,
1828 Constant_Present => True,
1829 Object_Definition => New_Reference_To (Generalized_Tag, Loc),
1830 Expression =>
1831 Unchecked_Convert_To (Generalized_Tag,
1832 Make_Op_Add (Loc,
1833 Left_Opnd =>
1834 Unchecked_Convert_To (RTE (RE_Storage_Offset),
1835 Make_Attribute_Reference (Loc,
1836 Prefix => New_Reference_To (Iface_DT, Loc),
1837 Attribute_Name => Name_Address)),
1838 Right_Opnd =>
1839 Make_DT_Access_Action (Etype (AI_Tag),
1840 DT_Prologue_Size, No_List)))));
1841
1842 -- Note: Offset_To_Top will be initialized by the init subprogram
1843
1844 -- Set Access_Disp_Table field to be the dispatch table pointer
1845
1846 if not (Present (Acc_Disp_Tables)) then
1847 Acc_Disp_Tables := New_Elmt_List;
1848 end if;
1849
1850 Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
1851
1852 end Make_Abstract_Interface_DT;
1853
ee6ba406 1854 ---------------------------
1855 -- Make_DT_Access_Action --
1856 ---------------------------
1857
1858 function Make_DT_Access_Action
1859 (Typ : Entity_Id;
1860 Action : DT_Access_Action;
aad6babd 1861 Args : List_Id) return Node_Id
ee6ba406 1862 is
aad6babd 1863 Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
ee6ba406 1864 Loc : Source_Ptr;
1865
1866 begin
ee6ba406 1867 if No (Args) then
1868
1869 -- This is a constant
1870
1871 return New_Reference_To (Action_Name, Sloc (Typ));
1872 end if;
1873
1874 pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
1875
1876 Loc := Sloc (First (Args));
1877
1878 if Action_Is_Proc (Action) then
1879 return
1880 Make_Procedure_Call_Statement (Loc,
1881 Name => New_Reference_To (Action_Name, Loc),
1882 Parameter_Associations => Args);
1883
1884 else
1885 return
1886 Make_Function_Call (Loc,
1887 Name => New_Reference_To (Action_Name, Loc),
1888 Parameter_Associations => Args);
1889 end if;
1890 end Make_DT_Access_Action;
1891
1892 -----------------------------------
1893 -- Original_View_In_Visible_Part --
1894 -----------------------------------
1895
1896 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
1897 Scop : constant Entity_Id := Scope (Typ);
1898
1899 begin
1900 -- The scope must be a package
1901
1902 if Ekind (Scop) /= E_Package
1903 and then Ekind (Scop) /= E_Generic_Package
1904 then
1905 return False;
1906 end if;
1907
1908 -- A type with a private declaration has a private view declared in
1909 -- the visible part.
1910
1911 if Has_Private_Declaration (Typ) then
1912 return True;
1913 end if;
1914
1915 return List_Containing (Parent (Typ)) =
1916 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
1917 end Original_View_In_Visible_Part;
1918
1919 -------------------------
1920 -- Set_All_DT_Position --
1921 -------------------------
1922
1923 procedure Set_All_DT_Position (Typ : Entity_Id) is
1924 Parent_Typ : constant Entity_Id := Etype (Typ);
1925 Root_Typ : constant Entity_Id := Root_Type (Typ);
1926 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
4660e715 1927 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
aad6babd 1928
ee6ba406 1929 Adjusted : Boolean := False;
1930 Finalized : Boolean := False;
aad6babd 1931
1932 Count_Prim : Int;
1933 DT_Length : Int;
ee6ba406 1934 Nb_Prim : Int;
aad6babd 1935 Parent_EC : Int;
ee6ba406 1936 Prim : Entity_Id;
1937 Prim_Elmt : Elmt_Id;
1938
aad6babd 1939 procedure Validate_Position (Prim : Entity_Id);
1940 -- Check that the position assignated to Prim is completely safe
1941 -- (it has not been assigned to a previously defined primitive
1942 -- operation of Typ)
1943
1944 -----------------------
1945 -- Validate_Position --
1946 -----------------------
1947
1948 procedure Validate_Position (Prim : Entity_Id) is
1949 Prim_Elmt : Elmt_Id;
1950 begin
1951 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
1952 while Present (Prim_Elmt)
1953 and then Node (Prim_Elmt) /= Prim
1954 loop
1955 -- Primitive operations covering abstract interfaces are
1956 -- allocated later
1957
1958 if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
1959 null;
1960
1961 -- Predefined dispatching operations are completely safe.
1962 -- They are allocated at fixed positions.
1963
1964 elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
1965 null;
ee6ba406 1966
aad6babd 1967 -- Aliased subprograms are safe
1968
1969 elsif Present (Alias (Prim)) then
1970 null;
1971
1972 elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
1973 raise Program_Error;
1974 end if;
1975
1976 Next_Elmt (Prim_Elmt);
1977 end loop;
1978 end Validate_Position;
1979
1980 -- Start of processing for Set_All_DT_Position
1981
1982 begin
ee6ba406 1983 -- Get Entry_Count of the parent
1984
1985 if Parent_Typ /= Typ
4660e715 1986 and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
ee6ba406 1987 then
4660e715 1988 Parent_EC := UI_To_Int (DT_Entry_Count
1989 (First_Tag_Component (Parent_Typ)));
ee6ba406 1990 else
1991 Parent_EC := 0;
1992 end if;
1993
1994 -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1995 -- give a coherent set of information
1996
1997 if Is_CPP_Class (Root_Typ) then
1998
1999 -- Compute the number of primitive operations in the main Vtable
2000 -- Set their position:
2001 -- - where it was set if overriden or inherited
2002 -- - after the end of the parent vtable otherwise
2003
2004 Prim_Elmt := First_Prim;
2005 Nb_Prim := 0;
2006 while Present (Prim_Elmt) loop
2007 Prim := Node (Prim_Elmt);
2008
2009 if not Is_CPP_Class (Typ) then
2010 Set_DTC_Entity (Prim, The_Tag);
2011
2012 elsif Present (Alias (Prim)) then
2013 Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
2014 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2015
2016 elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
2017 Error_Msg_NE ("is a primitive operation of&," &
2018 " pragma Cpp_Virtual required", Prim, Typ);
2019 end if;
2020
2021 if DTC_Entity (Prim) = The_Tag then
2022
2023 -- Get the slot from the parent subprogram if any
2024
2025 declare
2026 H : Entity_Id := Homonym (Prim);
2027
2028 begin
2029 while Present (H) loop
2030 if Present (DTC_Entity (H))
2031 and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
2032 then
2033 Set_DT_Position (Prim, DT_Position (H));
2034 exit;
2035 end if;
2036
2037 H := Homonym (H);
2038 end loop;
2039 end;
2040
2041 -- Otherwise take the canonical slot after the end of the
2042 -- parent Vtable
2043
2044 if DT_Position (Prim) = No_Uint then
2045 Nb_Prim := Nb_Prim + 1;
2046 Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
2047
2048 elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
2049 Nb_Prim := Nb_Prim + 1;
2050 end if;
2051 end if;
2052
2053 Next_Elmt (Prim_Elmt);
2054 end loop;
2055
2056 -- Check that the declared size of the Vtable is bigger or equal
2057 -- than the number of primitive operations (if bigger it means that
2058 -- some of the c++ virtual functions were not imported, that is
2059 -- allowed)
2060
2061 if DT_Entry_Count (The_Tag) = No_Uint
2062 or else not Is_CPP_Class (Typ)
2063 then
2064 Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
2065
2066 elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
2067 Error_Msg_N ("not enough room in the Vtable for all virtual"
2068 & " functions", The_Tag);
2069 end if;
2070
2071 -- Check that Positions are not duplicate nor outside the range of
2072 -- the Vtable
2073
2074 declare
2075 Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
2076 Pos : Int;
2077 Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
2078 (others => Empty);
2079
2080 begin
2081 Prim_Elmt := First_Prim;
2082 while Present (Prim_Elmt) loop
2083 Prim := Node (Prim_Elmt);
2084
2085 if DTC_Entity (Prim) = The_Tag then
2086 Pos := UI_To_Int (DT_Position (Prim));
2087
2088 if Pos not in Prim_Pos_Table'Range then
2089 Error_Msg_N
2090 ("position not in range of virtual table", Prim);
2091
2092 elsif Present (Prim_Pos_Table (Pos)) then
2093 Error_Msg_NE ("cannot be at the same position in the"
2094 & " vtable than&", Prim, Prim_Pos_Table (Pos));
2095
2096 else
2097 Prim_Pos_Table (Pos) := Prim;
2098 end if;
2099 end if;
2100
2101 Next_Elmt (Prim_Elmt);
2102 end loop;
2103 end;
2104
2105 -- For regular Ada tagged types, just set the DT_Position for
2106 -- each primitive operation. Perform some sanity checks to avoid
2107 -- to build completely inconsistant dispatch tables.
2108
9dfe12ae 2109 -- Note that the _Size primitive is always set at position 1 in order
2110 -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
2111 -- in a-tags.ad?)
ee6ba406 2112
9dfe12ae 2113 else
aad6babd 2114 -- First stage: Set the DTC entity of all the primitive operations
2115 -- This is required to properly read the DT_Position attribute in
2116 -- the latter stages.
2117
2118 Prim_Elmt := First_Prim;
2119 Count_Prim := 0;
ee6ba406 2120 while Present (Prim_Elmt) loop
aad6babd 2121 Count_Prim := Count_Prim + 1;
2122 Prim := Node (Prim_Elmt);
2123
2124 -- Ada 2005 (AI-251)
2125
2126 if Present (Abstract_Interface_Alias (Prim)) then
2127 Set_DTC_Entity (Prim,
2128 Find_Interface_Tag
2129 (T => Typ,
2130 Iface => Scope (DTC_Entity
2131 (Abstract_Interface_Alias (Prim)))));
9dfe12ae 2132
9dfe12ae 2133 else
aad6babd 2134 Set_DTC_Entity (Prim, The_Tag);
9dfe12ae 2135 end if;
ee6ba406 2136
aad6babd 2137 -- Clear any previous value of the DT_Position attribute. In this
2138 -- way we ensure that the final position of all the primitives is
2139 -- stablished by the following stages of this algorithm.
2140
2141 Set_DT_Position (Prim, No_Uint);
2142
2143 Next_Elmt (Prim_Elmt);
2144 end loop;
2145
2146 declare
2147 Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
2148 of Boolean := (others => False);
2149 E : Entity_Id;
2150
2151 begin
2152 -- Second stage: Register fixed entries
2153
2154 Nb_Prim := 10;
2155 Prim_Elmt := First_Prim;
2156
2157 while Present (Prim_Elmt) loop
2158 Prim := Node (Prim_Elmt);
2159
2160 -- Predefined primitives have a fixed position in all the
2161 -- dispatch tables
2162
2163 if Is_Predefined_Dispatching_Operation (Prim) then
2164 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
2165 Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2166
2167 -- Overriding interface primitives of an ancestor
2168
2169 elsif DT_Position (Prim) = No_Uint
2170 and then Present (Abstract_Interface_Alias (Prim))
2171 and then Present (DTC_Entity
2172 (Abstract_Interface_Alias (Prim)))
2173 and then DT_Position (Abstract_Interface_Alias (Prim))
2174 /= No_Uint
2175 and then Is_Inherited_Operation (Prim)
2176 and then Is_Ancestor (Scope
2177 (DTC_Entity
2178 (Abstract_Interface_Alias (Prim))),
2179 Typ)
2180 then
2181 Set_DT_Position (Prim,
2182 DT_Position (Abstract_Interface_Alias (Prim)));
2183 Set_DT_Position (Alias (Prim),
2184 DT_Position (Abstract_Interface_Alias (Prim)));
2185 Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2186
2187 -- Overriding primitives must use the same entry as the
2188 -- overriden primitive
2189
2190 elsif DT_Position (Prim) = No_Uint
2191 and then Present (Alias (Prim))
2192 and then Present (DTC_Entity (Alias (Prim)))
2193 and then DT_Position (Alias (Prim)) /= No_Uint
2194 and then Is_Inherited_Operation (Prim)
2195 and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
2196 then
2197 E := Alias (Prim);
2198 while not (Present (DTC_Entity (E))
2199 or else DT_Position (E) = No_Uint)
2200 and then Present (Alias (E))
2201 loop
2202 E := Alias (E);
2203 end loop;
2204
2205 pragma Assert (Present (DTC_Entity (E))
2206 and then
2207 DT_Position (E) /= No_Uint);
2208
2209 Set_DT_Position (Prim, DT_Position (E));
2210 Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2211
2212 -- If this is not the last element in the chain continue
2213 -- traversing the chain. This is required to properly
2214 -- handling renamed primitives
2215
2216 if Present (Alias (E)) then
2217 while Present (Alias (E)) loop
2218 E := Alias (E);
2219 Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2220 end loop;
2221 end if;
2222 end if;
2223
2224 Next_Elmt (Prim_Elmt);
2225 end loop;
2226
2227 -- Third stage: Fix the position of all the new primitives
2228 -- Entries associated with primitives covering interfaces
2229 -- are handled in a latter round.
2230
2231 Prim_Elmt := First_Prim;
2232 while Present (Prim_Elmt) loop
2233 Prim := Node (Prim_Elmt);
2234
2235 -- Skip primitives previously set entries
2236
2237 if DT_Position (Prim) /= No_Uint then
2238 null;
2239
2240 elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
2241 null;
2242
2243 -- Primitives covering interface primitives are
2244 -- handled later
2245
2246 elsif Present (Abstract_Interface_Alias (Prim)) then
2247 null;
2248
2249 else
2250 -- Take the next available position in the DT
2251
2252 loop
2253 Nb_Prim := Nb_Prim + 1;
2254 exit when not Fixed_Prim (Nb_Prim);
2255 end loop;
2256
2257 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
2258 Fixed_Prim (Nb_Prim) := True;
2259 end if;
2260
2261 Next_Elmt (Prim_Elmt);
2262 end loop;
2263 end;
2264
2265 -- Fourth stage: Complete the decoration of primitives covering
2266 -- interfaces (that is, propagate the DT_Position attribute
2267 -- from the aliased primitive)
2268
2269 Prim_Elmt := First_Prim;
2270 while Present (Prim_Elmt) loop
2271 Prim := Node (Prim_Elmt);
2272
2273 if DT_Position (Prim) = No_Uint
2274 and then Present (Abstract_Interface_Alias (Prim))
ee6ba406 2275 then
aad6babd 2276 -- Check if this entry will be placed in the primary DT
2277
2278 if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
2279 = RTE (RE_Tag)
2280 then
2281 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
2282 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2283
2284 -- Otherwise it will be placed in the secondary DT
2285
2286 else
2287 pragma Assert
2288 (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
2289
2290 Set_DT_Position (Prim,
2291 DT_Position (Abstract_Interface_Alias (Prim)));
2292 end if;
2293 end if;
2294
2295 Next_Elmt (Prim_Elmt);
2296 end loop;
2297
2298 -- Final stage: Ensure that the table is correct plus some further
2299 -- verifications concerning the primitives.
2300
2301 Prim_Elmt := First_Prim;
2302 DT_Length := 0;
2303
2304 while Present (Prim_Elmt) loop
2305 Prim := Node (Prim_Elmt);
2306
2307 -- At this point all the primitives MUST have a position
2308 -- in the dispatch table
2309
2310 if DT_Position (Prim) = No_Uint then
2311 raise Program_Error;
2312 end if;
2313
2314 -- Calculate real size of the dispatch table
2315
2316 if UI_To_Int (DT_Position (Prim)) > DT_Length then
2317 DT_Length := UI_To_Int (DT_Position (Prim));
2318 end if;
2319
2320 -- Ensure that the asignated position in the dispatch
2321 -- table is correct
2322
2323 Validate_Position (Prim);
2324
2325 if Chars (Prim) = Name_Finalize then
ee6ba406 2326 Finalized := True;
2327 end if;
2328
2329 if Chars (Prim) = Name_Adjust then
2330 Adjusted := True;
2331 end if;
2332
2333 -- An abstract operation cannot be declared in the private part
2334 -- for a visible abstract type, because it could never be over-
aad6babd 2335 -- ridden. For explicit declarations this is checked at the
2336 -- point of declaration, but for inherited operations it must
2337 -- be done when building the dispatch table. Input is excluded
2338 -- because
ee6ba406 2339
2340 if Is_Abstract (Typ)
2341 and then Is_Abstract (Prim)
2342 and then Present (Alias (Prim))
2343 and then Is_Derived_Type (Typ)
2344 and then In_Private_Part (Current_Scope)
aad6babd 2345 and then
2346 List_Containing (Parent (Prim)) =
2347 Private_Declarations
ee6ba406 2348 (Specification (Unit_Declaration_Node (Current_Scope)))
2349 and then Original_View_In_Visible_Part (Typ)
ee6ba406 2350 then
9dfe12ae 2351 -- We exclude Input and Output stream operations because
2352 -- Limited_Controlled inherits useless Input and Output
2353 -- stream operations from Root_Controlled, which can
2354 -- never be overridden.
2355
2356 if not Is_TSS (Prim, TSS_Stream_Input)
2357 and then
2358 not Is_TSS (Prim, TSS_Stream_Output)
2359 then
2360 Error_Msg_NE
2361 ("abstract inherited private operation&" &
2362 " must be overridden ('R'M 3.9.3(10))",
aad6babd 2363 Parent (Typ), Prim);
9dfe12ae 2364 end if;
ee6ba406 2365 end if;
aad6babd 2366
ee6ba406 2367 Next_Elmt (Prim_Elmt);
2368 end loop;
2369
aad6babd 2370 -- Additional check
2371
ee6ba406 2372 if Is_Controlled (Typ) then
2373 if not Finalized then
2374 Error_Msg_N
2375 ("controlled type has no explicit Finalize method?", Typ);
2376
2377 elsif not Adjusted then
2378 Error_Msg_N
2379 ("controlled type has no explicit Adjust method?", Typ);
2380 end if;
2381 end if;
2382
aad6babd 2383 -- Set the final size of the Dispatch Table
2384
2385 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
ee6ba406 2386
9dfe12ae 2387 -- The derived type must have at least as many components as its
2388 -- parent (for root types, the Etype points back to itself
ee6ba406 2389 -- and the test should not fail)
2390
aad6babd 2391 -- This test fails compiling the partial view of a tagged type
2392 -- derived from an interface which defines the overriding subprogram
2393 -- in the private part. This needs further investigation???
2394
2395 if not Has_Private_Declaration (Typ) then
2396 pragma Assert (
2397 DT_Entry_Count (The_Tag) >=
2398 DT_Entry_Count (First_Tag_Component (Parent_Typ)));
2399 null;
2400 end if;
2401 end if;
2402
2403 if Debug_Flag_ZZ then
2404 Write_DT (Typ);
ee6ba406 2405 end if;
2406 end Set_All_DT_Position;
2407
2408 -----------------------------
2409 -- Set_Default_Constructor --
2410 -----------------------------
2411
2412 procedure Set_Default_Constructor (Typ : Entity_Id) is
2413 Loc : Source_Ptr;
2414 Init : Entity_Id;
2415 Param : Entity_Id;
ee6ba406 2416 E : Entity_Id;
2417
2418 begin
2419 -- Look for the default constructor entity. For now only the
2420 -- default constructor has the flag Is_Constructor.
2421
2422 E := Next_Entity (Typ);
2423 while Present (E)
2424 and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
2425 loop
2426 Next_Entity (E);
2427 end loop;
2428
2429 -- Create the init procedure
2430
2431 if Present (E) then
2432 Loc := Sloc (E);
9dfe12ae 2433 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
ee6ba406 2434 Param := Make_Defining_Identifier (Loc, Name_X);
9dfe12ae 2435
2436 Discard_Node (
ee6ba406 2437 Make_Subprogram_Declaration (Loc,
2438 Make_Procedure_Specification (Loc,
2439 Defining_Unit_Name => Init,
2440 Parameter_Specifications => New_List (
2441 Make_Parameter_Specification (Loc,
2442 Defining_Identifier => Param,
9dfe12ae 2443 Parameter_Type => New_Reference_To (Typ, Loc))))));
ee6ba406 2444
2445 Set_Init_Proc (Typ, Init);
9dfe12ae 2446 Set_Is_Imported (Init);
ee6ba406 2447 Set_Interface_Name (Init, Interface_Name (E));
9dfe12ae 2448 Set_Convention (Init, Convention_C);
2449 Set_Is_Public (Init);
ee6ba406 2450 Set_Has_Completion (Init);
2451
9dfe12ae 2452 -- If there are no constructors, mark the type as abstract since we
ee6ba406 2453 -- won't be able to declare objects of that type.
2454
2455 else
2456 Set_Is_Abstract (Typ);
2457 end if;
2458 end Set_Default_Constructor;
2459
aad6babd 2460 --------------
2461 -- Write_DT --
2462 --------------
2463
2464 procedure Write_DT (Typ : Entity_Id) is
2465 Elmt : Elmt_Id;
2466 Prim : Node_Id;
2467
2468 begin
2469 -- Protect this procedure against wrong usage. Required because it will
2470 -- be used directly from GDB
2471
2472 if not (Typ in First_Node_Id .. Last_Node_Id)
2473 or else not Is_Tagged_Type (Typ)
2474 then
2475 Write_Str ("wrong usage: write_dt must be used with tagged types");
2476 Write_Eol;
2477 return;
2478 end if;
2479
2480 Write_Int (Int (Typ));
2481 Write_Str (": ");
2482 Write_Name (Chars (Typ));
2483
2484 if Is_Interface (Typ) then
2485 Write_Str (" is interface");
2486 end if;
2487
2488 Write_Eol;
2489
2490 Elmt := First_Elmt (Primitive_Operations (Typ));
2491 while Present (Elmt) loop
2492 Prim := Node (Elmt);
2493 Write_Str (" - ");
2494
2495 -- Indicate if this primitive will be allocated in the primary
2496 -- dispatch table or in a secondary dispatch table associated
2497 -- with an abstract interface type
2498
2499 if Present (DTC_Entity (Prim)) then
2500 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
2501 Write_Str ("[P] ");
2502 else
2503 Write_Str ("[s] ");
2504 end if;
2505 end if;
2506
2507 -- Output the node of this primitive operation and its name
2508
2509 Write_Int (Int (Prim));
2510 Write_Str (": ");
2511 Write_Name (Chars (Prim));
2512
2513 -- Indicate if this primitive has an aliased primitive
2514
2515 if Present (Alias (Prim)) then
2516 Write_Str (" (alias = ");
2517 Write_Int (Int (Alias (Prim)));
2518
2519 -- If the DTC_Entity attribute is already set we can also output
2520 -- the name of the interface covered by this primitive (if any)
2521
2522 if Present (DTC_Entity (Alias (Prim)))
2523 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
2524 then
2525 Write_Str (" from interface ");
2526 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
2527 end if;
2528
2529 if Present (Abstract_Interface_Alias (Prim)) then
2530 Write_Str (", AI_Alias of ");
2531 Write_Name (Chars (Scope (DTC_Entity
2532 (Abstract_Interface_Alias (Prim)))));
2533 Write_Char (':');
2534 Write_Int (Int (Abstract_Interface_Alias (Prim)));
2535 end if;
2536
2537 Write_Str (")");
2538 end if;
2539
2540 -- Display the final position of this primitive in its associated
2541 -- (primary or secondary) dispatch table
2542
2543 if Present (DTC_Entity (Prim))
2544 and then DT_Position (Prim) /= No_Uint
2545 then
2546 Write_Str (" at #");
2547 Write_Int (UI_To_Int (DT_Position (Prim)));
2548 end if;
2549
2550 if Is_Abstract (Prim) then
2551 Write_Str (" is abstract;");
2552 end if;
2553
2554 Write_Eol;
2555
2556 Next_Elmt (Elmt);
2557 end loop;
2558 end Write_DT;
2559
ee6ba406 2560end Exp_Disp;
Mirror of https://gcc.gnu.org/git/gcc.git