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