]> gcc.gnu.org Git - gcc.git/blame - gcc/ada/exp_disp.adb
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
exp_disp.ads, [...] (Build_Dispatch_Tables): Handle tagged types declared in the...
[gcc.git] / gcc / ada / exp_disp.adb
CommitLineData
70482933
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ D I S P --
6-- --
7-- B o d y --
8-- --
d0dd5209 9-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
70482933
RK		 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 --
cb5fee25
KC		 19-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20-- Boston, MA 02110-1301, USA. --
70482933
RK		 21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 23-- Extensive contributions were provided by Ada Core Technologies Inc. --
70482933
RK		 24-- --
25------------------------------------------------------------------------------
26
27with Atree; use Atree;
28with Checks; use Checks;
758c442c 29with Debug; use Debug;
70482933
RK		 30with Einfo; use Einfo;
31with Elists; use Elists;
32with Errout; use Errout;
dee4682a 33with Exp_Atag; use Exp_Atag;
70482933 34with Exp_Ch7; use Exp_Ch7;
f4d379b8 35with Exp_Dbug; use Exp_Dbug;
70482933
RK		 36with Exp_Tss; use Exp_Tss;
37with Exp_Util; use Exp_Util;
bfef8d0d 38with Freeze; use Freeze;
70482933 39with Itypes; use Itypes;
70482933
RK		 40with Nlists; use Nlists;
41with Nmake; use Nmake;
758c442c 42with Namet; use Namet;
70482933 43with Opt; use Opt;
758c442c 44with Output; use Output;
b0efe69e
JM		 45with Restrict; use Restrict;
46with Rident; use Rident;
70482933 47with Rtsfind; use Rtsfind;
758c442c 48with Sem; use Sem;
d0dd5209
JM		 49with Sem_Ch6; use Sem_Ch6;
50with Sem_Ch8; use Sem_Ch8;
70482933 51with Sem_Disp; use Sem_Disp;
d0dd5209 52with Sem_Eval; use Sem_Eval;
70482933 53with Sem_Res; use Sem_Res;
758c442c 54with Sem_Type; use Sem_Type;
70482933
RK		 55with Sem_Util; use Sem_Util;
56with Sinfo; use Sinfo;
57with Snames; use Snames;
58with Stand; use Stand;
d0dd5209
JM		 59with Stringt; use Stringt;
60with Targparm; use Targparm;
70482933
RK		 61with Tbuild; use Tbuild;
62with Uintp; use Uintp;
63
64package body Exp_Disp is
65
d0dd5209
JM		 66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70482933 69
b0efe69e 70 function Default_Prim_Op_Position (E : Entity_Id) return Uint;
758c442c
GD		 71 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
72 -- of the default primitive operations.
73
bfef8d0d
JM		 74 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
75 -- Returns true if Prim is not a predefined dispatching primitive but it is
76 -- an alias of a predefined dispatching primitive (ie. through a renaming)
77
70482933
RK		 78 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
79 -- Check if the type has a private view or if the public view appears
80 -- in the visible part of a package spec.
81
10b93b2e
HK		 82 function Prim_Op_Kind
83 (Prim : Entity_Id;
84 Typ : Entity_Id) return Node_Id;
85 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
4d744221 86 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
10b93b2e 87 -- enumeration value.
758c442c 88
4d744221
JM		 89 function Tagged_Kind (T : Entity_Id) return Node_Id;
90 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
91 -- to an RE_Tagged_Kind enumeration value.
92
b2e1beb3
ES		 93 ----------------------------------
94 -- Build_Static_Dispatch_Tables --
95 ----------------------------------
96
97 procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
98 Target_List : List_Id;
99
100 procedure Build_Dispatch_Tables (List : List_Id);
101 -- Build the static dispatch table of tagged types found in the list of
102 -- declarations. The generated nodes are added at the end of Target_List
103
104 procedure Build_Package_Dispatch_Tables (N : Node_Id);
105 -- Build static dispatch tables associated with package declaration N
106
107 ---------------------------
108 -- Build_Dispatch_Tables --
109 ---------------------------
110
111 procedure Build_Dispatch_Tables (List : List_Id) is
112 D : Node_Id;
113
114 begin
115 D := First (List);
116 while Present (D) loop
117
118 -- Handle nested packages and package bodies recursively. The
119 -- generated code is placed on the Target_List established for
120 -- the enclosing compilation unit.
121
122 if Nkind (D) = N_Package_Declaration then
123 Build_Package_Dispatch_Tables (D);
124
125 elsif Nkind (D) = N_Package_Body then
126 Build_Dispatch_Tables (Declarations (D));
127
128 elsif Nkind (D) = N_Package_Body_Stub
129 and then Present (Library_Unit (D))
130 then
131 Build_Dispatch_Tables
132 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
133
134 -- Handle full type declarations and derivations of library
135 -- level tagged types
136
137 elsif (Nkind (D) = N_Full_Type_Declaration
138 or else Nkind (D) = N_Derived_Type_Definition)
139 and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
140 and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
141 and then not Is_Private_Type (Defining_Entity (D))
142 then
143 Insert_List_After_And_Analyze (Last (Target_List),
144 Make_DT (Defining_Entity (D)));
145
146 -- Handle private types of library level tagged types. We must
147 -- exchange the private and full-view to ensure the correct
148 -- expansion.
149
150 elsif (Nkind (D) = N_Private_Type_Declaration
151 or else Nkind (D) = N_Private_Extension_Declaration)
152 and then Present (Full_View (Defining_Entity (D)))
153 and then Is_Library_Level_Tagged_Type
154 (Full_View (Defining_Entity (D)))
155 and then Ekind (Full_View (Defining_Entity (D)))
156 /= E_Record_Subtype
157 then
158 declare
159 E1, E2 : Entity_Id;
160 begin
161 E1 := Defining_Entity (D);
162 E2 := Full_View (Defining_Entity (D));
163 Exchange_Entities (E1, E2);
164 Insert_List_After_And_Analyze (Last (Target_List),
165 Make_DT (E1));
166 Exchange_Entities (E1, E2);
167 end;
168 end if;
169
170 Next (D);
171 end loop;
172 end Build_Dispatch_Tables;
173
174 -----------------------------------
175 -- Build_Package_Dispatch_Tables --
176 -----------------------------------
177
178 procedure Build_Package_Dispatch_Tables (N : Node_Id) is
179 Spec : constant Node_Id := Specification (N);
180 Id : constant Entity_Id := Defining_Entity (N);
181 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
182 Priv_Decls : constant List_Id := Private_Declarations (Spec);
183
184 begin
185 Push_Scope (Id);
186
187 if Present (Priv_Decls) then
188 Build_Dispatch_Tables (Vis_Decls);
189 Build_Dispatch_Tables (Priv_Decls);
190
191 elsif Present (Vis_Decls) then
192 Build_Dispatch_Tables (Vis_Decls);
193 end if;
194
195 Pop_Scope;
196 end Build_Package_Dispatch_Tables;
197
198 -- Start of processing for Build_Static_Dispatch_Tables
199
200 begin
201 if not Expander_Active
202 or else VM_Target /= No_VM
203 then
204 return;
205 end if;
206
207 if Nkind (N) = N_Package_Declaration then
208 declare
209 Spec : constant Node_Id := Specification (N);
210 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
211 Priv_Decls : constant List_Id := Private_Declarations (Spec);
212
213 begin
214 if Present (Priv_Decls)
215 and then Is_Non_Empty_List (Priv_Decls)
216 then
217 Target_List := Priv_Decls;
218
219 elsif not Present (Vis_Decls) then
220 Target_List := New_List;
221 Set_Private_Declarations (Spec, Target_List);
222 else
223 Target_List := Vis_Decls;
224 end if;
225
226 Build_Package_Dispatch_Tables (N);
227 end;
228
229 else pragma Assert (Nkind (N) = N_Package_Body);
230 Target_List := Declarations (N);
231 Build_Dispatch_Tables (Target_List);
232 end if;
233 end Build_Static_Dispatch_Tables;
234
758c442c
GD		 235 ------------------------------
236 -- Default_Prim_Op_Position --
237 ------------------------------
238
b0efe69e 239 function Default_Prim_Op_Position (E : Entity_Id) return Uint is
758c442c 240 TSS_Name : TSS_Name_Type;
758c442c
GD		 241
242 begin
758c442c
GD		 243 Get_Name_String (Chars (E));
244 TSS_Name :=
245 TSS_Name_Type
246 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
247
248 if Chars (E) = Name_uSize then
249 return Uint_1;
250
251 elsif Chars (E) = Name_uAlignment then
252 return Uint_2;
253
254 elsif TSS_Name = TSS_Stream_Read then
255 return Uint_3;
256
257 elsif TSS_Name = TSS_Stream_Write then
258 return Uint_4;
259
260 elsif TSS_Name = TSS_Stream_Input then
261 return Uint_5;
262
263 elsif TSS_Name = TSS_Stream_Output then
264 return Uint_6;
265
266 elsif Chars (E) = Name_Op_Eq then
267 return Uint_7;
268
269 elsif Chars (E) = Name_uAssign then
270 return Uint_8;
271
272 elsif TSS_Name = TSS_Deep_Adjust then
273 return Uint_9;
274
275 elsif TSS_Name = TSS_Deep_Finalize then
276 return Uint_10;
277
f4d379b8
HK		 278 elsif Ada_Version >= Ada_05 then
279 if Chars (E) = Name_uDisp_Asynchronous_Select then
280 return Uint_11;
10b93b2e 281
f4d379b8
HK		 282 elsif Chars (E) = Name_uDisp_Conditional_Select then
283 return Uint_12;
10b93b2e 284
f4d379b8
HK		 285 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
286 return Uint_13;
10b93b2e 287
f4d379b8
HK		 288 elsif Chars (E) = Name_uDisp_Get_Task_Id then
289 return Uint_14;
10b93b2e 290
f4d379b8
HK		 291 elsif Chars (E) = Name_uDisp_Timed_Select then
292 return Uint_15;
293 end if;
758c442c 294 end if;
f4d379b8
HK		 295
296 raise Program_Error;
758c442c
GD		 297 end Default_Prim_Op_Position;
298
82c80734
RD		 299 -----------------------------
300 -- Expand_Dispatching_Call --
301 -----------------------------
70482933 302
82c80734 303 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
70482933
RK		 304 Loc : constant Source_Ptr := Sloc (Call_Node);
305 Call_Typ : constant Entity_Id := Etype (Call_Node);
306
307 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
308 Param_List : constant List_Id := Parameter_Associations (Call_Node);
70482933 309
bfef8d0d 310 Subp : Entity_Id;
82c80734
RD		 311 CW_Typ : Entity_Id;
312 New_Call : Node_Id;
313 New_Call_Name : Node_Id;
314 New_Params : List_Id := No_List;
315 Param : Node_Id;
316 Res_Typ : Entity_Id;
317 Subp_Ptr_Typ : Entity_Id;
318 Subp_Typ : Entity_Id;
319 Typ : Entity_Id;
320 Eq_Prim_Op : Entity_Id := Empty;
321 Controlling_Tag : Node_Id;
70482933
RK		 322
323 function New_Value (From : Node_Id) return Node_Id;
fbf5a39b
AC		 324 -- From is the original Expression. New_Value is equivalent to a call
325 -- to Duplicate_Subexpr with an explicit dereference when From is an
82c80734
RD		 326 -- access parameter.
327
fbf5a39b
AC		 328 ---------------
329 -- New_Value --
330 ---------------
331
70482933
RK		 332 function New_Value (From : Node_Id) return Node_Id is
333 Res : constant Node_Id := Duplicate_Subexpr (From);
70482933
RK		 334 begin
335 if Is_Access_Type (Etype (From)) then
bfef8d0d
JM		 336 return
337 Make_Explicit_Dereference (Sloc (From),
338 Prefix => Res);
70482933
RK		 339 else
340 return Res;
341 end if;
342 end New_Value;
343
82c80734 344 -- Start of processing for Expand_Dispatching_Call
70482933
RK		 345
346 begin
d0dd5209
JM		 347 if No_Run_Time_Mode then
348 Error_Msg_CRT ("tagged types", Call_Node);
349 return;
350 end if;
351
dee4682a
JM		 352 -- Expand_Dispatching_Call is called directly from the semantics,
353 -- so we need a check to see whether expansion is active before
354 -- proceeding. In addition, there is no need to expand the call
355 -- if we are compiling under restriction No_Dispatching_Calls;
356 -- the semantic analyzer has previously notified the violation
357 -- of this restriction.
358
359 if not Expander_Active
360 or else Restriction_Active (No_Dispatching_Calls)
361 then
362 return;
363 end if;
b0efe69e 364
bfef8d0d
JM		 365 -- Set subprogram. If this is an inherited operation that was
366 -- overridden, the body that is being called is its alias.
367
368 Subp := Entity (Name (Call_Node));
70482933
RK		 369
370 if Present (Alias (Subp))
371 and then Is_Inherited_Operation (Subp)
372 and then No (DTC_Entity (Subp))
373 then
374 Subp := Alias (Subp);
375 end if;
376
82c80734 377 -- Definition of the class-wide type and the tagged type
70482933 378
82c80734
RD		 379 -- If the controlling argument is itself a tag rather than a tagged
380 -- object, then use the class-wide type associated with the subprogram's
381 -- controlling type. This case can occur when a call to an inherited
382 -- primitive has an actual that originated from a default parameter
383 -- given by a tag-indeterminate call and when there is no other
384 -- controlling argument providing the tag (AI-239 requires dispatching).
385 -- This capability of dispatching directly by tag is also needed by the
386 -- implementation of AI-260 (for the generic dispatching constructors).
387
758c442c 388 if Etype (Ctrl_Arg) = RTE (RE_Tag)
b0efe69e
JM		 389 or else (RTE_Available (RE_Interface_Tag)
390 and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
758c442c 391 then
bfef8d0d 392 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
82c80734 393
d0dd5209
JM		 394 -- Class_Wide_Type is applied to the expressions used to initialize
395 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
396 -- there are cases where the controlling type is resolved to a specific
397 -- type (such as for designated types of arguments such as CW'Access).
398
82c80734 399 elsif Is_Access_Type (Etype (Ctrl_Arg)) then
d0dd5209 400 CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg)));
82c80734 401
70482933 402 else
d0dd5209 403 CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg));
70482933
RK		 404 end if;
405
406 Typ := Root_Type (CW_Typ);
407
10b93b2e
HK		 408 if Ekind (Typ) = E_Incomplete_Type then
409 Typ := Non_Limited_View (Typ);
410 end if;
411
70482933
RK		 412 if not Is_Limited_Type (Typ) then
413 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
414 end if;
415
dee4682a
JM		 416 -- Dispatching call to C++ primitive. Create a new parameter list
417 -- with no tag checks.
70482933 418
dee4682a 419 if Is_CPP_Class (Typ) then
70482933
RK		 420 New_Params := New_List;
421 Param := First_Actual (Call_Node);
422 while Present (Param) loop
758c442c 423 Append_To (New_Params, Relocate_Node (Param));
70482933
RK		 424 Next_Actual (Param);
425 end loop;
426
dee4682a
JM		 427 -- Dispatching call to Ada primitive
428
70482933
RK		 429 elsif Present (Param_List) then
430
431 -- Generate the Tag checks when appropriate
432
433 New_Params := New_List;
70482933
RK		 434 Param := First_Actual (Call_Node);
435 while Present (Param) loop
436
437 -- No tag check with itself
438
439 if Param = Ctrl_Arg then
fbf5a39b
AC		 440 Append_To (New_Params,
441 Duplicate_Subexpr_Move_Checks (Param));
70482933
RK		 442
443 -- No tag check for parameter whose type is neither tagged nor
444 -- access to tagged (for access parameters)
445
446 elsif No (Find_Controlling_Arg (Param)) then
447 Append_To (New_Params, Relocate_Node (Param));
448
82c80734 449 -- No tag check for function dispatching on result if the
70482933
RK		 450 -- Tag given by the context is this one
451
452 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
453 Append_To (New_Params, Relocate_Node (Param));
454
455 -- "=" is the only dispatching operation allowed to get
456 -- operands with incompatible tags (it just returns false).
fbf5a39b
AC		 457 -- We use Duplicate_Subexpr_Move_Checks instead of calling
458 -- Relocate_Node because the value will be duplicated to
459 -- check the tags.
70482933
RK		 460
461 elsif Subp = Eq_Prim_Op then
fbf5a39b
AC		 462 Append_To (New_Params,
463 Duplicate_Subexpr_Move_Checks (Param));
70482933
RK		 464
465 -- No check in presence of suppress flags
466
467 elsif Tag_Checks_Suppressed (Etype (Param))
468 or else (Is_Access_Type (Etype (Param))
469 and then Tag_Checks_Suppressed
470 (Designated_Type (Etype (Param))))
471 then
472 Append_To (New_Params, Relocate_Node (Param));
473
474 -- Optimization: no tag checks if the parameters are identical
475
476 elsif Is_Entity_Name (Param)
477 and then Is_Entity_Name (Ctrl_Arg)
478 and then Entity (Param) = Entity (Ctrl_Arg)
479 then
480 Append_To (New_Params, Relocate_Node (Param));
481
482 -- Now we need to generate the Tag check
483
484 else
485 -- Generate code for tag equality check
486 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
487
488 Insert_Action (Ctrl_Arg,
489 Make_Implicit_If_Statement (Call_Node,
490 Condition =>
491 Make_Op_Ne (Loc,
492 Left_Opnd =>
493 Make_Selected_Component (Loc,
494 Prefix => New_Value (Ctrl_Arg),
495 Selector_Name =>
a9d8907c
JM		 496 New_Reference_To
497 (First_Tag_Component (Typ), Loc)),
70482933
RK		 498
499 Right_Opnd =>
500 Make_Selected_Component (Loc,
501 Prefix =>
502 Unchecked_Convert_To (Typ, New_Value (Param)),
503 Selector_Name =>
a9d8907c
JM		 504 New_Reference_To
505 (First_Tag_Component (Typ), Loc))),
70482933
RK		 506
507 Then_Statements =>
508 New_List (New_Constraint_Error (Loc))));
509
510 Append_To (New_Params, Relocate_Node (Param));
511 end if;
512
513 Next_Actual (Param);
514 end loop;
515 end if;
516
517 -- Generate the appropriate subprogram pointer type
518
b0efe69e 519 if Etype (Subp) = Typ then
70482933
RK		 520 Res_Typ := CW_Typ;
521 else
82c80734 522 Res_Typ := Etype (Subp);
70482933
RK		 523 end if;
524
525 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
526 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
527 Set_Etype (Subp_Typ, Res_Typ);
528 Init_Size_Align (Subp_Ptr_Typ);
529 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
530
531 -- Create a new list of parameters which is a copy of the old formal
532 -- list including the creation of a new set of matching entities.
533
534 declare
535 Old_Formal : Entity_Id := First_Formal (Subp);
536 New_Formal : Entity_Id;
d0dd5209 537 Extra : Entity_Id := Empty;
70482933
RK		 538
539 begin
540 if Present (Old_Formal) then
541 New_Formal := New_Copy (Old_Formal);
542 Set_First_Entity (Subp_Typ, New_Formal);
543 Param := First_Actual (Call_Node);
544
545 loop
546 Set_Scope (New_Formal, Subp_Typ);
547
548 -- Change all the controlling argument types to be class-wide
82c80734 549 -- to avoid a recursion in dispatching.
70482933 550
82c80734 551 if Is_Controlling_Formal (New_Formal) then
70482933
RK		 552 Set_Etype (New_Formal, Etype (Param));
553 end if;
554
555 if Is_Itype (Etype (New_Formal)) then
556 Extra := New_Copy (Etype (New_Formal));
557
558 if Ekind (Extra) = E_Record_Subtype
559 or else Ekind (Extra) = E_Class_Wide_Subtype
560 then
561 Set_Cloned_Subtype (Extra, Etype (New_Formal));
562 end if;
563
564 Set_Etype (New_Formal, Extra);
565 Set_Scope (Etype (New_Formal), Subp_Typ);
566 end if;
567
568 Extra := New_Formal;
569 Next_Formal (Old_Formal);
570 exit when No (Old_Formal);
571
572 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
573 Next_Entity (New_Formal);
574 Next_Actual (Param);
575 end loop;
bfef8d0d
JM		 576
577 Set_Next_Entity (New_Formal, Empty);
70482933 578 Set_Last_Entity (Subp_Typ, Extra);
d0dd5209 579 end if;
70482933 580
d0dd5209
JM		 581 -- Now that the explicit formals have been duplicated, any extra
582 -- formals needed by the subprogram must be created.
70482933 583
d0dd5209
JM		 584 if Present (Extra) then
585 Set_Extra_Formal (Extra, Empty);
70482933 586 end if;
d0dd5209
JM		 587
588 Create_Extra_Formals (Subp_Typ);
70482933
RK		 589 end;
590
591 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
592 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
593
b0efe69e
JM		 594 -- If the controlling argument is a value of type Ada.Tag or an abstract
595 -- interface class-wide type then use it directly. Otherwise, the tag
596 -- must be extracted from the controlling object.
82c80734 597
758c442c 598 if Etype (Ctrl_Arg) = RTE (RE_Tag)
b0efe69e
JM		 599 or else (RTE_Available (RE_Interface_Tag)
600 and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
601 then
602 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
603
dee4682a
JM		 604 -- Extract the tag from an unchecked type conversion. Done to avoid
605 -- the expansion of additional code just to obtain the value of such
606 -- tag because the current management of interface type conversions
607 -- generates in some cases this unchecked type conversion with the
608 -- tag of the object (see Expand_Interface_Conversion).
609
610 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
611 and then
612 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
613 or else
614 (RTE_Available (RE_Interface_Tag)
615 and then
616 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
617 then
618 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
619
b0efe69e
JM		 620 -- Ada 2005 (AI-251): Abstract interface class-wide type
621
622 elsif Is_Interface (Etype (Ctrl_Arg))
623 and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
758c442c 624 then
82c80734
RD		 625 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
626
627 else
628 Controlling_Tag :=
629 Make_Selected_Component (Loc,
630 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
631 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
632 end if;
633
dee4682a 634 -- Handle dispatching calls to predefined primitives
70482933 635
bfef8d0d
JM		 636 if Is_Predefined_Dispatching_Operation (Subp)
637 or else Is_Predefined_Dispatching_Alias (Subp)
638 then
b0efe69e
JM		 639 New_Call_Name :=
640 Unchecked_Convert_To (Subp_Ptr_Typ,
dee4682a
JM		 641 Build_Get_Predefined_Prim_Op_Address (Loc,
642 Tag_Node => Controlling_Tag,
d0dd5209 643 Position => DT_Position (Subp)));
70482933 644
dee4682a 645 -- Handle dispatching calls to user-defined primitives
b0efe69e
JM		 646
647 else
648 New_Call_Name :=
649 Unchecked_Convert_To (Subp_Ptr_Typ,
dee4682a 650 Build_Get_Prim_Op_Address (Loc,
d0dd5209
JM		 651 Typ => Find_Dispatching_Type (Subp),
652 Tag_Node => Controlling_Tag,
653 Position => DT_Position (Subp)));
b0efe69e 654 end if;
70482933
RK		 655
656 if Nkind (Call_Node) = N_Function_Call then
70482933 657
d0dd5209
JM		 658 New_Call :=
659 Make_Function_Call (Loc,
660 Name => New_Call_Name,
661 Parameter_Associations => New_Params);
70482933 662
d0dd5209
JM		 663 -- If this is a dispatching "=", we must first compare the tags so
664 -- we generate: x.tag = y.tag and then x = y
70482933 665
d0dd5209
JM		 666 if Subp = Eq_Prim_Op then
667 Param := First_Actual (Call_Node);
758c442c 668 New_Call :=
d0dd5209
JM		 669 Make_And_Then (Loc,
670 Left_Opnd =>
671 Make_Op_Eq (Loc,
672 Left_Opnd =>
673 Make_Selected_Component (Loc,
674 Prefix => New_Value (Param),
675 Selector_Name =>
676 New_Reference_To (First_Tag_Component (Typ),
677 Loc)),
70482933 678
d0dd5209
JM		 679 Right_Opnd =>
680 Make_Selected_Component (Loc,
681 Prefix =>
682 Unchecked_Convert_To (Typ,
683 New_Value (Next_Actual (Param))),
684 Selector_Name =>
685 New_Reference_To (First_Tag_Component (Typ),
686 Loc))),
687 Right_Opnd => New_Call);
70482933
RK		 688 end if;
689
690 else
691 New_Call :=
692 Make_Procedure_Call_Statement (Loc,
693 Name => New_Call_Name,
694 Parameter_Associations => New_Params);
695 end if;
696
697 Rewrite (Call_Node, New_Call);
d0dd5209
JM		 698
699 -- Suppress all checks during the analysis of the expanded code
700 -- to avoid the generation of spureous warnings under ZFP run-time.
701
702 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
82c80734 703 end Expand_Dispatching_Call;
70482933 704
758c442c
GD		 705 ---------------------------------
706 -- Expand_Interface_Conversion --
707 ---------------------------------
708
4d744221
JM		 709 procedure Expand_Interface_Conversion
710 (N : Node_Id;
711 Is_Static : Boolean := True)
712 is
758c442c 713 Loc : constant Source_Ptr := Sloc (N);
bfef8d0d 714 Etyp : constant Entity_Id := Etype (N);
758c442c
GD		 715 Operand : constant Node_Id := Expression (N);
716 Operand_Typ : Entity_Id := Etype (Operand);
10b93b2e 717 Func : Node_Id;
bfef8d0d
JM		 718 Iface_Typ : Entity_Id := Etype (N);
719 Iface_Tag : Entity_Id;
758c442c
GD		 720
721 begin
dee4682a 722 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
758c442c 723
dee4682a
JM		 724 if Is_Concurrent_Type (Operand_Typ) then
725 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
758c442c
GD		 726 end if;
727
10b93b2e 728 -- Handle access types to interfaces
758c442c 729
10b93b2e
HK		 730 if Is_Access_Type (Iface_Typ) then
731 Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
758c442c
GD		 732 end if;
733
10b93b2e
HK		 734 -- Handle class-wide interface types. This conversion can appear
735 -- explicitly in the source code. Example: I'Class (Obj)
758c442c 736
10b93b2e 737 if Is_Class_Wide_Type (Iface_Typ) then
d0dd5209 738 Iface_Typ := Root_Type (Iface_Typ);
10b93b2e
HK		 739 end if;
740
bfef8d0d
JM		 741 pragma Assert (not Is_Static
742 or else (not Is_Class_Wide_Type (Iface_Typ)
743 and then Is_Interface (Iface_Typ)));
758c442c 744
d0dd5209
JM		 745 if VM_Target /= No_VM then
746
747 -- For VM, just do a conversion ???
748
749 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
750 Analyze (N);
751 return;
752 end if;
753
4d744221 754 if not Is_Static then
b0efe69e
JM		 755
756 -- Give error if configurable run time and Displace not available
757
758 if not RTE_Available (RE_Displace) then
759 Error_Msg_CRT ("abstract interface types", N);
760 return;
761 end if;
762
d0dd5209
JM		 763 -- Handle conversion of access-to-class-wide interface types. Target
764 -- can be an access to an object or an access to another class-wide
765 -- interface (see -1- and -2- in the following example):
bfef8d0d
JM		 766
767 -- type Iface1_Ref is access all Iface1'Class;
768 -- type Iface2_Ref is access all Iface1'Class;
769
770 -- Acc1 : Iface1_Ref := new ...
771 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
772 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
773
774 if Is_Access_Type (Operand_Typ) then
775 pragma Assert
d0dd5209 776 (Is_Interface (Directly_Designated_Type (Operand_Typ)));
bfef8d0d
JM		 777
778 Rewrite (N,
779 Unchecked_Convert_To (Etype (N),
780 Make_Function_Call (Loc,
781 Name => New_Reference_To (RTE (RE_Displace), Loc),
782 Parameter_Associations => New_List (
783
784 Unchecked_Convert_To (RTE (RE_Address),
785 Relocate_Node (Expression (N))),
786
787 New_Occurrence_Of
788 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
789 Loc)))));
790
791 Analyze (N);
792 return;
793 end if;
794
4d744221
JM		 795 Rewrite (N,
796 Make_Function_Call (Loc,
797 Name => New_Reference_To (RTE (RE_Displace), Loc),
798 Parameter_Associations => New_List (
799 Make_Attribute_Reference (Loc,
800 Prefix => Relocate_Node (Expression (N)),
801 Attribute_Name => Name_Address),
bfef8d0d 802
4d744221
JM		 803 New_Occurrence_Of
804 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
805 Loc))));
806
807 Analyze (N);
808
bfef8d0d
JM		 809 -- If the target is a class-wide interface we change the type of the
810 -- data returned by IW_Convert to indicate that this is a dispatching
811 -- call.
4d744221 812
b2e1beb3
ES		 813 declare
814 New_Itype : Entity_Id;
4d744221 815
b2e1beb3
ES		 816 begin
817 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
818 Set_Etype (New_Itype, New_Itype);
819 Init_Esize (New_Itype);
820 Init_Size_Align (New_Itype);
821 Set_Directly_Designated_Type (New_Itype, Etyp);
4d744221 822
b2e1beb3
ES		 823 Rewrite (N,
824 Make_Explicit_Dereference (Loc,
825 Prefix =>
826 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
827 Analyze (N);
828 Freeze_Itype (New_Itype, N);
829
830 return;
831 end;
4d744221
JM		 832 end if;
833
10b93b2e 834 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
758c442c
GD		 835 pragma Assert (Iface_Tag /= Empty);
836
10b93b2e
HK		 837 -- Keep separate access types to interfaces because one internal
838 -- function is used to handle the null value (see following comment)
839
840 if not Is_Access_Type (Etype (N)) then
841 Rewrite (N,
842 Unchecked_Convert_To (Etype (N),
843 Make_Selected_Component (Loc,
844 Prefix => Relocate_Node (Expression (N)),
845 Selector_Name =>
846 New_Occurrence_Of (Iface_Tag, Loc))));
847
848 else
849 -- Build internal function to handle the case in which the
850 -- actual is null. If the actual is null returns null because
851 -- no displacement is required; otherwise performs a type
852 -- conversion that will be expanded in the code that returns
853 -- the value of the displaced actual. That is:
854
bfef8d0d 855 -- function Func (O : Address) return Iface_Typ is
b2e1beb3
ES		 856 -- type Op_Typ is access all Operand_Typ;
857 -- Aux : Op_Typ := To_Op_Typ (O);
10b93b2e 858 -- begin
bfef8d0d 859 -- if O = Null_Address then
10b93b2e
HK		 860 -- return null;
861 -- else
b2e1beb3 862 -- return Iface_Typ!(Aux.Iface_Tag'Address);
10b93b2e
HK		 863 -- end if;
864 -- end Func;
865
bfef8d0d 866 declare
b2e1beb3
ES		 867 Decls : List_Id;
868 Desig_Typ : Entity_Id;
869 Fent : Entity_Id;
870 New_Typ_Decl : Node_Id;
871 New_Obj_Decl : Node_Id;
872 Stats : List_Id;
873
bfef8d0d
JM		 874 begin
875 Desig_Typ := Etype (Expression (N));
10b93b2e 876
bfef8d0d
JM		 877 if Is_Access_Type (Desig_Typ) then
878 Desig_Typ := Directly_Designated_Type (Desig_Typ);
879 end if;
10b93b2e 880
b2e1beb3
ES		 881 New_Typ_Decl :=
882 Make_Full_Type_Declaration (Loc,
883 Defining_Identifier =>
884 Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
885 Type_Definition =>
886 Make_Access_To_Object_Definition (Loc,
887 All_Present => True,
888 Null_Exclusion_Present => False,
889 Constant_Present => False,
890 Subtype_Indication =>
891 New_Reference_To (Desig_Typ, Loc)));
10b93b2e 892
b2e1beb3
ES		 893 New_Obj_Decl :=
894 Make_Object_Declaration (Loc,
895 Defining_Identifier =>
896 Make_Defining_Identifier (Loc,
897 New_Internal_Name ('S')),
898 Constant_Present => True,
899 Object_Definition =>
900 New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
901 Expression =>
902 Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
903 Make_Identifier (Loc, Name_uO)));
d0dd5209 904
b2e1beb3
ES		 905 Decls := New_List (
906 New_Typ_Decl,
907 New_Obj_Decl);
d0dd5209 908
d0dd5209 909 Stats := New_List (
b2e1beb3
ES		 910 Make_Simple_Return_Statement (Loc,
911 Unchecked_Convert_To (Etype (N),
912 Make_Attribute_Reference (Loc,
913 Prefix =>
914 Make_Selected_Component (Loc,
915 Prefix =>
916 New_Reference_To
917 (Defining_Identifier (New_Obj_Decl),
918 Loc),
919 Selector_Name =>
920 New_Occurrence_Of (Iface_Tag, Loc)),
921 Attribute_Name => Name_Address))));
d0dd5209 922
b2e1beb3
ES		 923 -- If the type is null-excluding, no need for the null branch.
924 -- Otherwise we need to check for it and return null.
925
926 if not Can_Never_Be_Null (Etype (N)) then
927 Stats := New_List (
928 Make_If_Statement (Loc,
929 Condition =>
930 Make_Op_Eq (Loc,
931 Left_Opnd => Make_Identifier (Loc, Name_uO),
932 Right_Opnd => New_Reference_To
933 (RTE (RE_Null_Address), Loc)),
934
935 Then_Statements => New_List (
936 Make_Simple_Return_Statement (Loc,
937 Make_Null (Loc))),
938 Else_Statements => Stats));
939 end if;
10b93b2e 940
b2e1beb3
ES		 941 Fent :=
942 Make_Defining_Identifier (Loc,
943 New_Internal_Name ('F'));
bfef8d0d 944
b2e1beb3
ES		 945 Func :=
946 Make_Subprogram_Body (Loc,
947 Specification =>
948 Make_Function_Specification (Loc,
949 Defining_Unit_Name => Fent,
10b93b2e 950
b2e1beb3
ES		 951 Parameter_Specifications => New_List (
952 Make_Parameter_Specification (Loc,
953 Defining_Identifier =>
954 Make_Defining_Identifier (Loc, Name_uO),
955 Parameter_Type =>
956 New_Reference_To (RTE (RE_Address), Loc))),
10b93b2e 957
b2e1beb3
ES		 958 Result_Definition =>
959 New_Reference_To (Etype (N), Loc)),
10b93b2e 960
b2e1beb3 961 Declarations => Decls,
10b93b2e 962
b2e1beb3
ES		 963 Handled_Statement_Sequence =>
964 Make_Handled_Sequence_Of_Statements (Loc, Stats));
10b93b2e 965
b2e1beb3
ES		 966 -- Place function body before the expression containing the
967 -- conversion. We suppress all checks because the body of the
968 -- internally generated function already takes care of the case
969 -- in which the actual is null; therefore there is no need to
970 -- double check that the pointer is not null when the program
971 -- executes the alternative that performs the type conversion).
bfef8d0d 972
b2e1beb3 973 Insert_Action (N, Func, Suppress => All_Checks);
bfef8d0d 974
b2e1beb3 975 if Is_Access_Type (Etype (Expression (N))) then
bfef8d0d 976
b2e1beb3 977 -- Generate: Operand_Typ!(Expression.all)'Address
bfef8d0d 978
b2e1beb3
ES		 979 Rewrite (N,
980 Make_Function_Call (Loc,
981 Name => New_Reference_To (Fent, Loc),
982 Parameter_Associations => New_List (
983 Make_Attribute_Reference (Loc,
984 Prefix => Unchecked_Convert_To (Operand_Typ,
985 Make_Explicit_Dereference (Loc,
986 Relocate_Node (Expression (N)))),
987 Attribute_Name => Name_Address))));
988
989 else
990 -- Generate: Operand_Typ!(Expression)'Address
991
992 Rewrite (N,
993 Make_Function_Call (Loc,
994 Name => New_Reference_To (Fent, Loc),
995 Parameter_Associations => New_List (
996 Make_Attribute_Reference (Loc,
997 Prefix => Unchecked_Convert_To (Operand_Typ,
998 Relocate_Node (Expression (N))),
999 Attribute_Name => Name_Address))));
1000 end if;
1001 end;
10b93b2e 1002 end if;
758c442c
GD		 1003
1004 Analyze (N);
1005 end Expand_Interface_Conversion;
1006
1007 ------------------------------
1008 -- Expand_Interface_Actuals --
1009 ------------------------------
1010
1011 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1012 Loc : constant Source_Ptr := Sloc (Call_Node);
1013 Actual : Node_Id;
10b93b2e 1014 Actual_Dup : Node_Id;
758c442c 1015 Actual_Typ : Entity_Id;
10b93b2e 1016 Anon : Entity_Id;
758c442c
GD		 1017 Conversion : Node_Id;
1018 Formal : Entity_Id;
1019 Formal_Typ : Entity_Id;
1020 Subp : Entity_Id;
1021 Nam : Name_Id;
10b93b2e
HK		 1022 Formal_DDT : Entity_Id;
1023 Actual_DDT : Entity_Id;
758c442c
GD		 1024
1025 begin
1026 -- This subprogram is called directly from the semantics, so we need a
1027 -- check to see whether expansion is active before proceeding.
1028
1029 if not Expander_Active then
1030 return;
1031 end if;
1032
1033 -- Call using access to subprogram with explicit dereference
1034
1035 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1036 Subp := Etype (Name (Call_Node));
1037
1038 -- Normal case
1039
1040 else
1041 Subp := Entity (Name (Call_Node));
1042 end if;
1043
d0dd5209
JM		 1044 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1045 -- displacement
1046
758c442c
GD		 1047 Formal := First_Formal (Subp);
1048 Actual := First_Actual (Call_Node);
758c442c 1049 while Present (Formal) loop
d0dd5209 1050 Formal_Typ := Etype (Formal);
10b93b2e
HK		 1051
1052 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1053 Formal_Typ := Full_View (Formal_Typ);
1054 end if;
1055
1056 if Is_Access_Type (Formal_Typ) then
1057 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1058 end if;
1059
758c442c
GD		 1060 Actual_Typ := Etype (Actual);
1061
10b93b2e
HK		 1062 if Is_Access_Type (Actual_Typ) then
1063 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1064 end if;
1065
d0dd5209
JM		 1066 if Is_Interface (Formal_Typ)
1067 and then Is_Class_Wide_Type (Formal_Typ)
1068 then
10b93b2e 1069 -- No need to displace the pointer if the type of the actual
d0dd5209 1070 -- coindices with the type of the formal.
758c442c 1071
d0dd5209 1072 if Actual_Typ = Formal_Typ then
10b93b2e
HK		 1073 null;
1074
d0dd5209
JM		 1075 -- No need to displace the pointer if the interface type is
1076 -- a parent of the type of the actual because in this case the
1077 -- interface primitives are located in the primary dispatch table.
758c442c 1078
dee4682a 1079 elsif Is_Parent (Formal_Typ, Actual_Typ) then
10b93b2e
HK		 1080 null;
1081
d0dd5209
JM		 1082 -- Implicit conversion to the class-wide formal type to force
1083 -- the displacement of the pointer.
1084
10b93b2e
HK		 1085 else
1086 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
d0dd5209 1087 Rewrite (Actual, Conversion);
10b93b2e
HK		 1088 Analyze_And_Resolve (Actual, Formal_Typ);
1089 end if;
758c442c 1090
d0dd5209 1091 -- Access to class-wide interface type
758c442c
GD		 1092
1093 elsif Is_Access_Type (Formal_Typ)
d0dd5209
JM		 1094 and then Is_Interface (Formal_DDT)
1095 and then Is_Class_Wide_Type (Formal_DDT)
758c442c 1096 and then Interface_Present_In_Ancestor
10b93b2e
HK		 1097 (Typ => Actual_DDT,
1098 Iface => Etype (Formal_DDT))
758c442c 1099 then
d0dd5209
JM		 1100 -- Handle attributes 'Access and 'Unchecked_Access
1101
758c442c
GD		 1102 if Nkind (Actual) = N_Attribute_Reference
1103 and then
1104 (Attribute_Name (Actual) = Name_Access
1105 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1106 then
1107 Nam := Attribute_Name (Actual);
1108
d0dd5209 1109 Conversion := Convert_To (Formal_DDT, Prefix (Actual));
758c442c 1110 Rewrite (Actual, Conversion);
d0dd5209 1111 Analyze_And_Resolve (Actual, Formal_DDT);
758c442c
GD		 1112
1113 Rewrite (Actual,
1114 Unchecked_Convert_To (Formal_Typ,
1115 Make_Attribute_Reference (Loc,
10b93b2e 1116 Prefix => Relocate_Node (Actual),
758c442c 1117 Attribute_Name => Nam)));
758c442c
GD		 1118 Analyze_And_Resolve (Actual, Formal_Typ);
1119
d0dd5209
JM		 1120 -- No need to displace the pointer if the type of the actual
1121 -- coincides with the type of the formal.
10b93b2e 1122
d0dd5209 1123 elsif Actual_DDT = Formal_DDT then
10b93b2e
HK		 1124 null;
1125
d0dd5209
JM		 1126 -- No need to displace the pointer if the interface type is
1127 -- a parent of the type of the actual because in this case the
1128 -- interface primitives are located in the primary dispatch table.
10b93b2e 1129
dee4682a 1130 elsif Is_Parent (Formal_DDT, Actual_DDT) then
10b93b2e
HK		 1131 null;
1132
758c442c 1133 else
10b93b2e
HK		 1134 Actual_Dup := Relocate_Node (Actual);
1135
1136 if From_With_Type (Actual_Typ) then
1137
1138 -- If the type of the actual parameter comes from a limited
1139 -- with-clause and the non-limited view is already available
1140 -- we replace the anonymous access type by a duplicate decla
1141 -- ration whose designated type is the non-limited view
1142
1143 if Ekind (Actual_DDT) = E_Incomplete_Type
1144 and then Present (Non_Limited_View (Actual_DDT))
1145 then
1146 Anon := New_Copy (Actual_Typ);
1147
1148 if Is_Itype (Anon) then
1149 Set_Scope (Anon, Current_Scope);
1150 end if;
1151
1152 Set_Directly_Designated_Type (Anon,
1153 Non_Limited_View (Actual_DDT));
1154 Set_Etype (Actual_Dup, Anon);
1155
1156 elsif Is_Class_Wide_Type (Actual_DDT)
1157 and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1158 and then Present (Non_Limited_View (Etype (Actual_DDT)))
1159 then
1160 Anon := New_Copy (Actual_Typ);
1161
1162 if Is_Itype (Anon) then
1163 Set_Scope (Anon, Current_Scope);
1164 end if;
1165
1166 Set_Directly_Designated_Type (Anon,
1167 New_Copy (Actual_DDT));
1168 Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1169 New_Copy (Class_Wide_Type (Actual_DDT)));
1170 Set_Etype (Directly_Designated_Type (Anon),
1171 Non_Limited_View (Etype (Actual_DDT)));
1172 Set_Etype (
1173 Class_Wide_Type (Directly_Designated_Type (Anon)),
1174 Non_Limited_View (Etype (Actual_DDT)));
1175 Set_Etype (Actual_Dup, Anon);
1176 end if;
1177 end if;
1178
1179 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1180 Rewrite (Actual, Conversion);
758c442c
GD		 1181 Analyze_And_Resolve (Actual, Formal_Typ);
1182 end if;
1183 end if;
1184
1185 Next_Actual (Actual);
1186 Next_Formal (Formal);
1187 end loop;
1188 end Expand_Interface_Actuals;
1189
1190 ----------------------------
1191 -- Expand_Interface_Thunk --
1192 ----------------------------
1193
d0dd5209 1194 procedure Expand_Interface_Thunk
b2e1beb3
ES		 1195 (Prim : Node_Id;
1196 Thunk_Id : out Entity_Id;
1197 Thunk_Code : out Node_Id)
758c442c 1198 is
b2e1beb3 1199 Loc : constant Source_Ptr := Sloc (Prim);
d0dd5209
JM		 1200 Actuals : constant List_Id := New_List;
1201 Decl : constant List_Id := New_List;
1202 Formals : constant List_Id := New_List;
1203
1204 Controlling_Typ : Entity_Id;
1205 Decl_1 : Node_Id;
1206 Decl_2 : Node_Id;
1207 Formal : Node_Id;
1208 Target : Entity_Id;
1209 Target_Formal : Entity_Id;
758c442c
GD		 1210
1211 begin
d0dd5209
JM		 1212 Thunk_Id := Empty;
1213 Thunk_Code := Empty;
1214
1215 -- Give message if configurable run-time and Offset_To_Top unavailable
1216
1217 if not RTE_Available (RE_Offset_To_Top) then
b2e1beb3 1218 Error_Msg_CRT ("abstract interface types", Prim);
d0dd5209
JM		 1219 return;
1220 end if;
1221
758c442c
GD		 1222 -- Traverse the list of alias to find the final target
1223
b2e1beb3 1224 Target := Prim;
758c442c
GD		 1225 while Present (Alias (Target)) loop
1226 Target := Alias (Target);
1227 end loop;
1228
d0dd5209
JM		 1229 -- In case of primitives that are functions without formals and
1230 -- a controlling result there is no need to build the thunk.
1231
1232 if not Present (First_Formal (Target)) then
1233 pragma Assert (Ekind (Target) = E_Function
1234 and then Has_Controlling_Result (Target));
1235 return;
1236 end if;
1237
758c442c
GD		 1238 -- Duplicate the formals
1239
10b93b2e 1240 Formal := First_Formal (Target);
758c442c 1241 while Present (Formal) loop
d0dd5209
JM		 1242 Append_To (Formals,
1243 Make_Parameter_Specification (Loc,
1244 Defining_Identifier =>
1245 Make_Defining_Identifier (Sloc (Formal),
1246 Chars => Chars (Formal)),
1247 In_Present => In_Present (Parent (Formal)),
1248 Out_Present => Out_Present (Parent (Formal)),
1249 Parameter_Type =>
1250 New_Reference_To (Etype (Formal), Loc),
1251 Expression => New_Copy_Tree (Expression (Parent (Formal)))));
10b93b2e 1252
758c442c
GD		 1253 Next_Formal (Formal);
1254 end loop;
1255
b2e1beb3 1256 Controlling_Typ := Find_Dispatching_Type (Target);
758c442c 1257
d0dd5209
JM		 1258 Target_Formal := First_Formal (Target);
1259 Formal := First (Formals);
1260 while Present (Formal) loop
1261 if Ekind (Target_Formal) = E_In_Parameter
1262 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1263 and then Directly_Designated_Type (Etype (Target_Formal))
1264 = Controlling_Typ
1265 then
1266 -- Generate:
758c442c 1267
b2e1beb3
ES		 1268 -- type T is access all <<type of the target formal>>
1269 -- S : Storage_Offset := Storage_Offset!(Formal)
1270 -- - Offset_To_Top (address!(Formal))
d0dd5209
JM		 1271
1272 Decl_2 :=
1273 Make_Full_Type_Declaration (Loc,
1274 Defining_Identifier =>
1275 Make_Defining_Identifier (Loc,
1276 New_Internal_Name ('T')),
1277 Type_Definition =>
1278 Make_Access_To_Object_Definition (Loc,
1279 All_Present => True,
1280 Null_Exclusion_Present => False,
1281 Constant_Present => False,
1282 Subtype_Indication =>
758c442c 1283 New_Reference_To
d0dd5209
JM		 1284 (Directly_Designated_Type
1285 (Etype (Target_Formal)), Loc)));
1286
1287 Decl_1 :=
1288 Make_Object_Declaration (Loc,
1289 Defining_Identifier =>
1290 Make_Defining_Identifier (Loc,
1291 New_Internal_Name ('S')),
1292 Constant_Present => True,
1293 Object_Definition =>
1294 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1295 Expression =>
1296 Make_Op_Subtract (Loc,
1297 Left_Opnd =>
1298 Unchecked_Convert_To
1299 (RTE (RE_Storage_Offset),
1300 New_Reference_To (Defining_Identifier (Formal), Loc)),
1301 Right_Opnd =>
1302 Make_Function_Call (Loc,
1303 Name =>
1304 New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1305 Parameter_Associations => New_List (
1306 Unchecked_Convert_To
1307 (RTE (RE_Address),
1308 New_Reference_To
1309 (Defining_Identifier (Formal), Loc))))));
1310
1311 Append_To (Decl, Decl_2);
1312 Append_To (Decl, Decl_1);
1313
b2e1beb3
ES		 1314 -- Reference the new actual. Generate:
1315 -- T!(S)
d0dd5209
JM		 1316
1317 Append_To (Actuals,
1318 Unchecked_Convert_To
1319 (Defining_Identifier (Decl_2),
1320 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1321
1322 elsif Etype (Target_Formal) = Controlling_Typ then
1323 -- Generate:
758c442c 1324
b2e1beb3
ES		 1325 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1326 -- - Offset_To_Top (Formal'Address)
1327 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
758c442c 1328
d0dd5209
JM		 1329 Decl_1 :=
1330 Make_Object_Declaration (Loc,
1331 Defining_Identifier =>
1332 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1333 Constant_Present => True,
1334 Object_Definition =>
1335 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1336 Expression =>
1337 Make_Op_Subtract (Loc,
1338 Left_Opnd =>
1339 Unchecked_Convert_To
1340 (RTE (RE_Storage_Offset),
1341 Make_Attribute_Reference (Loc,
1342 Prefix =>
1343 New_Reference_To
1344 (Defining_Identifier (Formal), Loc),
1345 Attribute_Name => Name_Address)),
1346 Right_Opnd =>
1347 Make_Function_Call (Loc,
1348 Name =>
1349 New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1350 Parameter_Associations => New_List (
1351 Make_Attribute_Reference (Loc,
1352 Prefix =>
1353 New_Reference_To
1354 (Defining_Identifier (Formal), Loc),
1355 Attribute_Name => Name_Address)))));
758c442c 1356
d0dd5209
JM		 1357 Decl_2 :=
1358 Make_Object_Declaration (Loc,
1359 Defining_Identifier =>
1360 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1361 Constant_Present => True,
1362 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1363 Expression =>
1364 Unchecked_Convert_To
1365 (RTE (RE_Addr_Ptr),
1366 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
758c442c 1367
d0dd5209
JM		 1368 Append_To (Decl, Decl_1);
1369 Append_To (Decl, Decl_2);
4d744221 1370
b2e1beb3
ES		 1371 -- Reference the new actual. Generate:
1372 -- Target_Formal (S2.all)
758c442c 1373
d0dd5209
JM		 1374 Append_To (Actuals,
1375 Unchecked_Convert_To
b2e1beb3 1376 (Etype (Target_Formal),
d0dd5209
JM		 1377 Make_Explicit_Dereference (Loc,
1378 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
758c442c 1379
d0dd5209 1380 -- No special management required for this actual
758c442c 1381
d0dd5209
JM		 1382 else
1383 Append_To (Actuals,
1384 New_Reference_To (Defining_Identifier (Formal), Loc));
1385 end if;
1386
1387 Next_Formal (Target_Formal);
758c442c
GD		 1388 Next (Formal);
1389 end loop;
1390
d0dd5209
JM		 1391 Thunk_Id :=
1392 Make_Defining_Identifier (Loc,
1393 Chars => New_Internal_Name ('T'));
1394
10b93b2e 1395 if Ekind (Target) = E_Procedure then
d0dd5209 1396 Thunk_Code :=
758c442c
GD		 1397 Make_Subprogram_Body (Loc,
1398 Specification =>
1399 Make_Procedure_Specification (Loc,
1400 Defining_Unit_Name => Thunk_Id,
1401 Parameter_Specifications => Formals),
1402 Declarations => Decl,
1403 Handled_Statement_Sequence =>
1404 Make_Handled_Sequence_Of_Statements (Loc,
1405 Statements => New_List (
1406 Make_Procedure_Call_Statement (Loc,
d0dd5209
JM		 1407 Name => New_Occurrence_Of (Target, Loc),
1408 Parameter_Associations => Actuals))));
758c442c 1409
10b93b2e 1410 else pragma Assert (Ekind (Target) = E_Function);
758c442c 1411
d0dd5209 1412 Thunk_Code :=
758c442c
GD		 1413 Make_Subprogram_Body (Loc,
1414 Specification =>
1415 Make_Function_Specification (Loc,
1416 Defining_Unit_Name => Thunk_Id,
1417 Parameter_Specifications => Formals,
10b93b2e
HK		 1418 Result_Definition =>
1419 New_Copy (Result_Definition (Parent (Target)))),
758c442c
GD		 1420 Declarations => Decl,
1421 Handled_Statement_Sequence =>
1422 Make_Handled_Sequence_Of_Statements (Loc,
1423 Statements => New_List (
b2e1beb3 1424 Make_Simple_Return_Statement (Loc,
758c442c
GD		 1425 Make_Function_Call (Loc,
1426 Name => New_Occurrence_Of (Target, Loc),
1427 Parameter_Associations => Actuals)))));
1428 end if;
758c442c
GD		 1429 end Expand_Interface_Thunk;
1430
bfef8d0d
JM		 1431 -------------------------------------
1432 -- Is_Predefined_Dispatching_Alias --
1433 -------------------------------------
1434
1435 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1436 is
1437 E : Entity_Id;
1438
1439 begin
1440 if not Is_Predefined_Dispatching_Operation (Prim)
1441 and then Present (Alias (Prim))
1442 then
1443 E := Prim;
1444 while Present (Alias (E)) loop
1445 E := Alias (E);
1446 end loop;
1447
1448 if Is_Predefined_Dispatching_Operation (E) then
1449 return True;
1450 end if;
1451 end if;
1452
1453 return False;
1454 end Is_Predefined_Dispatching_Alias;
1455
f4d379b8
HK		 1456 ----------------------------------------
1457 -- Make_Disp_Asynchronous_Select_Body --
1458 ----------------------------------------
70482933 1459
f4d379b8
HK		 1460 function Make_Disp_Asynchronous_Select_Body
1461 (Typ : Entity_Id) return Node_Id
1462 is
d0dd5209
JM		 1463 Com_Block : Entity_Id;
1464 Conc_Typ : Entity_Id := Empty;
1465 Decls : constant List_Id := New_List;
1466 DT_Ptr : Entity_Id;
1467 Loc : constant Source_Ptr := Sloc (Typ);
1468 Stmts : constant List_Id := New_List;
70482933
RK		 1469
1470 begin
b0efe69e
JM		 1471 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1472
4d744221
JM		 1473 -- Null body is generated for interface types
1474
f4d379b8
HK		 1475 if Is_Interface (Typ) then
1476 return
1477 Make_Subprogram_Body (Loc,
1478 Specification =>
1479 Make_Disp_Asynchronous_Select_Spec (Typ),
1480 Declarations =>
1481 New_List,
1482 Handled_Statement_Sequence =>
1483 Make_Handled_Sequence_Of_Statements (Loc,
1484 New_List (Make_Null_Statement (Loc))));
fbf5a39b
AC		 1485 end if;
1486
f4d379b8 1487 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
758c442c 1488
4d744221
JM		 1489 if Is_Concurrent_Record_Type (Typ) then
1490 Conc_Typ := Corresponding_Concurrent_Type (Typ);
758c442c 1491
f4d379b8 1492 -- Generate:
4d744221 1493 -- I : Integer := Get_Entry_Index (tag! (<type>VP), S);
758c442c 1494
f4d379b8
HK		 1495 -- where I will be used to capture the entry index of the primitive
1496 -- wrapper at position S.
758c442c 1497
f4d379b8
HK		 1498 Append_To (Decls,
1499 Make_Object_Declaration (Loc,
1500 Defining_Identifier =>
1501 Make_Defining_Identifier (Loc, Name_uI),
1502 Object_Definition =>
1503 New_Reference_To (Standard_Integer, Loc),
1504 Expression =>
d0dd5209
JM		 1505 Make_Function_Call (Loc,
1506 Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1507 Parameter_Associations => New_List (
1508 Unchecked_Convert_To (RTE (RE_Tag),
1509 New_Reference_To (DT_Ptr, Loc)),
1510 Make_Identifier (Loc, Name_uS)))));
758c442c 1511
f4d379b8 1512 if Ekind (Conc_Typ) = E_Protected_Type then
758c442c 1513
d0dd5209
JM		 1514 -- Generate:
1515 -- Com_Block : Communication_Block;
1516
1517 Com_Block :=
1518 Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1519
1520 Append_To (Decls,
1521 Make_Object_Declaration (Loc,
1522 Defining_Identifier =>
1523 Com_Block,
1524 Object_Definition =>
1525 New_Reference_To (RTE (RE_Communication_Block), Loc)));
1526
f4d379b8
HK		 1527 -- Generate:
1528 -- Protected_Entry_Call (
1529 -- T._object'access,
1530 -- protected_entry_index! (I),
1531 -- P,
1532 -- Asynchronous_Call,
d0dd5209 1533 -- Com_Block);
758c442c 1534
f4d379b8
HK		 1535 -- where T is the protected object, I is the entry index, P are
1536 -- the wrapped parameters and B is the name of the communication
1537 -- block.
758c442c 1538
f4d379b8
HK		 1539 Append_To (Stmts,
1540 Make_Procedure_Call_Statement (Loc,
1541 Name =>
1542 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1543 Parameter_Associations =>
1544 New_List (
758c442c 1545
f4d379b8
HK		 1546 Make_Attribute_Reference (Loc, -- T._object'access
1547 Attribute_Name =>
1548 Name_Unchecked_Access,
1549 Prefix =>
1550 Make_Selected_Component (Loc,
1551 Prefix =>
1552 Make_Identifier (Loc, Name_uT),
1553 Selector_Name =>
1554 Make_Identifier (Loc, Name_uObject))),
758c442c 1555
f4d379b8
HK		 1556 Make_Unchecked_Type_Conversion (Loc, -- entry index
1557 Subtype_Mark =>
1558 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1559 Expression =>
1560 Make_Identifier (Loc, Name_uI)),
10b93b2e 1561
f4d379b8
HK		 1562 Make_Identifier (Loc, Name_uP), -- parameter block
1563 New_Reference_To ( -- Asynchronous_Call
1564 RTE (RE_Asynchronous_Call), Loc),
d0dd5209
JM		 1565
1566 New_Reference_To (Com_Block, Loc)))); -- comm block
1567
1568 -- Generate:
1569 -- B := Dummy_Communication_Bloc (Com_Block);
1570
1571 Append_To (Stmts,
1572 Make_Assignment_Statement (Loc,
1573 Name =>
1574 Make_Identifier (Loc, Name_uB),
1575 Expression =>
1576 Make_Unchecked_Type_Conversion (Loc,
1577 Subtype_Mark =>
1578 New_Reference_To (
1579 RTE (RE_Dummy_Communication_Block), Loc),
1580 Expression =>
1581 New_Reference_To (Com_Block, Loc))));
1582
f4d379b8
HK		 1583 else
1584 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
10b93b2e 1585
f4d379b8
HK		 1586 -- Generate:
1587 -- Protected_Entry_Call (
1588 -- T._task_id,
1589 -- task_entry_index! (I),
1590 -- P,
1591 -- Conditional_Call,
1592 -- F);
70482933 1593
f4d379b8
HK		 1594 -- where T is the task object, I is the entry index, P are the
1595 -- wrapped parameters and F is the status flag.
70482933 1596
f4d379b8
HK		 1597 Append_To (Stmts,
1598 Make_Procedure_Call_Statement (Loc,
1599 Name =>
1600 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1601 Parameter_Associations =>
1602 New_List (
70482933 1603
f4d379b8
HK		 1604 Make_Selected_Component (Loc, -- T._task_id
1605 Prefix =>
1606 Make_Identifier (Loc, Name_uT),
1607 Selector_Name =>
1608 Make_Identifier (Loc, Name_uTask_Id)),
70482933 1609
f4d379b8
HK		 1610 Make_Unchecked_Type_Conversion (Loc, -- entry index
1611 Subtype_Mark =>
1612 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1613 Expression =>
1614 Make_Identifier (Loc, Name_uI)),
70482933 1615
f4d379b8
HK		 1616 Make_Identifier (Loc, Name_uP), -- parameter block
1617 New_Reference_To ( -- Asynchronous_Call
1618 RTE (RE_Asynchronous_Call), Loc),
1619 Make_Identifier (Loc, Name_uF)))); -- status flag
1620 end if;
f4d379b8 1621 end if;
70482933 1622
f4d379b8
HK		 1623 return
1624 Make_Subprogram_Body (Loc,
1625 Specification =>
1626 Make_Disp_Asynchronous_Select_Spec (Typ),
1627 Declarations =>
1628 Decls,
1629 Handled_Statement_Sequence =>
1630 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1631 end Make_Disp_Asynchronous_Select_Body;
70482933 1632
f4d379b8
HK		 1633 ----------------------------------------
1634 -- Make_Disp_Asynchronous_Select_Spec --
1635 ----------------------------------------
70482933 1636
f4d379b8
HK		 1637 function Make_Disp_Asynchronous_Select_Spec
1638 (Typ : Entity_Id) return Node_Id
1639 is
1640 Loc : constant Source_Ptr := Sloc (Typ);
1641 Def_Id : constant Node_Id :=
1642 Make_Defining_Identifier (Loc,
1643 Name_uDisp_Asynchronous_Select);
1644 Params : constant List_Id := New_List;
70482933 1645
f4d379b8 1646 begin
b0efe69e
JM		 1647 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1648
d0dd5209
JM		 1649 -- T : in out Typ; -- Object parameter
1650 -- S : Integer; -- Primitive operation slot
1651 -- P : Address; -- Wrapped parameters
1652 -- B : out Dummy_Communication_Block; -- Communication block dummy
1653 -- F : out Boolean; -- Status flag
70482933 1654
d0dd5209
JM		 1655 Append_List_To (Params, New_List (
1656
1657 Make_Parameter_Specification (Loc,
1658 Defining_Identifier =>
1659 Make_Defining_Identifier (Loc, Name_uT),
1660 Parameter_Type =>
1661 New_Reference_To (Typ, Loc),
1662 In_Present => True,
1663 Out_Present => True),
1664
1665 Make_Parameter_Specification (Loc,
1666 Defining_Identifier =>
1667 Make_Defining_Identifier (Loc, Name_uS),
1668 Parameter_Type =>
1669 New_Reference_To (Standard_Integer, Loc)),
1670
1671 Make_Parameter_Specification (Loc,
1672 Defining_Identifier =>
1673 Make_Defining_Identifier (Loc, Name_uP),
1674 Parameter_Type =>
1675 New_Reference_To (RTE (RE_Address), Loc)),
1676
1677 Make_Parameter_Specification (Loc,
1678 Defining_Identifier =>
1679 Make_Defining_Identifier (Loc, Name_uB),
1680 Parameter_Type =>
1681 New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
1682 Out_Present => True),
70482933 1683
d0dd5209
JM		 1684 Make_Parameter_Specification (Loc,
1685 Defining_Identifier =>
1686 Make_Defining_Identifier (Loc, Name_uF),
1687 Parameter_Type =>
1688 New_Reference_To (Standard_Boolean, Loc),
1689 Out_Present => True)));
82c80734 1690
f4d379b8 1691 return
d0dd5209
JM		 1692 Make_Procedure_Specification (Loc,
1693 Defining_Unit_Name => Def_Id,
1694 Parameter_Specifications => Params);
f4d379b8 1695 end Make_Disp_Asynchronous_Select_Spec;
70482933 1696
f4d379b8
HK		 1697 ---------------------------------------
1698 -- Make_Disp_Conditional_Select_Body --
1699 ---------------------------------------
70482933 1700
f4d379b8
HK		 1701 function Make_Disp_Conditional_Select_Body
1702 (Typ : Entity_Id) return Node_Id
1703 is
1704 Loc : constant Source_Ptr := Sloc (Typ);
1705 Blk_Nam : Entity_Id;
1706 Conc_Typ : Entity_Id := Empty;
1707 Decls : constant List_Id := New_List;
1708 DT_Ptr : Entity_Id;
1709 Stmts : constant List_Id := New_List;
70482933 1710
f4d379b8 1711 begin
b0efe69e
JM		 1712 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1713
4d744221
JM		 1714 -- Null body is generated for interface types
1715
f4d379b8
HK		 1716 if Is_Interface (Typ) then
1717 return
1718 Make_Subprogram_Body (Loc,
1719 Specification =>
1720 Make_Disp_Conditional_Select_Spec (Typ),
1721 Declarations =>
1722 No_List,
1723 Handled_Statement_Sequence =>
1724 Make_Handled_Sequence_Of_Statements (Loc,
1725 New_List (Make_Null_Statement (Loc))));
1726 end if;
70482933 1727
f4d379b8 1728 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
70482933 1729
4d744221
JM		 1730 if Is_Concurrent_Record_Type (Typ) then
1731 Conc_Typ := Corresponding_Concurrent_Type (Typ);
70482933 1732
f4d379b8
HK		 1733 -- Generate:
1734 -- I : Integer;
70482933 1735
f4d379b8
HK		 1736 -- where I will be used to capture the entry index of the primitive
1737 -- wrapper at position S.
70482933 1738
f4d379b8
HK		 1739 Append_To (Decls,
1740 Make_Object_Declaration (Loc,
1741 Defining_Identifier =>
1742 Make_Defining_Identifier (Loc, Name_uI),
1743 Object_Definition =>
1744 New_Reference_To (Standard_Integer, Loc)));
70482933 1745
4d744221
JM		 1746 -- Generate:
1747 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
70482933 1748
4d744221
JM		 1749 -- if C = POK_Procedure
1750 -- or else C = POK_Protected_Procedure
1751 -- or else C = POK_Task_Procedure;
1752 -- then
1753 -- F := True;
1754 -- return;
1755 -- end if;
758c442c 1756
d0dd5209 1757 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
758c442c 1758
f4d379b8
HK		 1759 -- Generate:
1760 -- Bnn : Communication_Block;
758c442c 1761
f4d379b8
HK		 1762 -- where Bnn is the name of the communication block used in
1763 -- the call to Protected_Entry_Call.
758c442c 1764
f4d379b8 1765 Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
758c442c 1766
f4d379b8
HK		 1767 Append_To (Decls,
1768 Make_Object_Declaration (Loc,
1769 Defining_Identifier =>
1770 Blk_Nam,
1771 Object_Definition =>
1772 New_Reference_To (RTE (RE_Communication_Block), Loc)));
758c442c 1773
f4d379b8 1774 -- Generate:
4d744221 1775 -- I := Get_Entry_Index (tag! (<type>VP), S);
758c442c 1776
f4d379b8 1777 -- I is the entry index and S is the dispatch table slot
758c442c 1778
f4d379b8
HK		 1779 Append_To (Stmts,
1780 Make_Assignment_Statement (Loc,
1781 Name =>
1782 Make_Identifier (Loc, Name_uI),
1783 Expression =>
d0dd5209
JM		 1784 Make_Function_Call (Loc,
1785 Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1786 Parameter_Associations => New_List (
1787 Unchecked_Convert_To (RTE (RE_Tag),
1788 New_Reference_To (DT_Ptr, Loc)),
1789 Make_Identifier (Loc, Name_uS)))));
70482933 1790
f4d379b8 1791 if Ekind (Conc_Typ) = E_Protected_Type then
70482933 1792
f4d379b8
HK		 1793 -- Generate:
1794 -- Protected_Entry_Call (
1795 -- T._object'access,
1796 -- protected_entry_index! (I),
1797 -- P,
1798 -- Conditional_Call,
1799 -- Bnn);
70482933 1800
f4d379b8
HK		 1801 -- where T is the protected object, I is the entry index, P are
1802 -- the wrapped parameters and Bnn is the name of the communication
1803 -- block.
3ca505dc 1804
f4d379b8
HK		 1805 Append_To (Stmts,
1806 Make_Procedure_Call_Statement (Loc,
1807 Name =>
1808 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1809 Parameter_Associations =>
1810 New_List (
3ca505dc 1811
f4d379b8
HK		 1812 Make_Attribute_Reference (Loc, -- T._object'access
1813 Attribute_Name =>
1814 Name_Unchecked_Access,
1815 Prefix =>
1816 Make_Selected_Component (Loc,
1817 Prefix =>
1818 Make_Identifier (Loc, Name_uT),
1819 Selector_Name =>
1820 Make_Identifier (Loc, Name_uObject))),
10b93b2e 1821
f4d379b8
HK		 1822 Make_Unchecked_Type_Conversion (Loc, -- entry index
1823 Subtype_Mark =>
1824 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1825 Expression =>
1826 Make_Identifier (Loc, Name_uI)),
10b93b2e 1827
f4d379b8
HK		 1828 Make_Identifier (Loc, Name_uP), -- parameter block
1829 New_Reference_To ( -- Conditional_Call
1830 RTE (RE_Conditional_Call), Loc),
1831 New_Reference_To ( -- Bnn
1832 Blk_Nam, Loc))));
10b93b2e 1833
f4d379b8
HK		 1834 -- Generate:
1835 -- F := not Cancelled (Bnn);
3ca505dc 1836
f4d379b8
HK		 1837 -- where F is the success flag. The status of Cancelled is negated
1838 -- in order to match the behaviour of the version for task types.
3ca505dc 1839
f4d379b8
HK		 1840 Append_To (Stmts,
1841 Make_Assignment_Statement (Loc,
1842 Name =>
1843 Make_Identifier (Loc, Name_uF),
1844 Expression =>
1845 Make_Op_Not (Loc,
1846 Right_Opnd =>
1847 Make_Function_Call (Loc,
1848 Name =>
1849 New_Reference_To (RTE (RE_Cancelled), Loc),
1850 Parameter_Associations =>
1851 New_List (
1852 New_Reference_To (Blk_Nam, Loc))))));
1853 else
1854 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
10b93b2e 1855
f4d379b8
HK		 1856 -- Generate:
1857 -- Protected_Entry_Call (
1858 -- T._task_id,
1859 -- task_entry_index! (I),
1860 -- P,
1861 -- Conditional_Call,
1862 -- F);
10b93b2e 1863
f4d379b8
HK		 1864 -- where T is the task object, I is the entry index, P are the
1865 -- wrapped parameters and F is the status flag.
3ca505dc 1866
f4d379b8
HK		 1867 Append_To (Stmts,
1868 Make_Procedure_Call_Statement (Loc,
1869 Name =>
1870 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1871 Parameter_Associations =>
1872 New_List (
1873
1874 Make_Selected_Component (Loc, -- T._task_id
1875 Prefix =>
1876 Make_Identifier (Loc, Name_uT),
1877 Selector_Name =>
1878 Make_Identifier (Loc, Name_uTask_Id)),
1879
1880 Make_Unchecked_Type_Conversion (Loc, -- entry index
1881 Subtype_Mark =>
1882 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1883 Expression =>
1884 Make_Identifier (Loc, Name_uI)),
1885
1886 Make_Identifier (Loc, Name_uP), -- parameter block
1887 New_Reference_To ( -- Conditional_Call
1888 RTE (RE_Conditional_Call), Loc),
1889 Make_Identifier (Loc, Name_uF)))); -- status flag
10b93b2e 1890 end if;
f4d379b8
HK		 1891 end if;
1892
1893 return
1894 Make_Subprogram_Body (Loc,
1895 Specification =>
1896 Make_Disp_Conditional_Select_Spec (Typ),
1897 Declarations =>
1898 Decls,
1899 Handled_Statement_Sequence =>
1900 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1901 end Make_Disp_Conditional_Select_Body;
1902
1903 ---------------------------------------
1904 -- Make_Disp_Conditional_Select_Spec --
1905 ---------------------------------------
1906
1907 function Make_Disp_Conditional_Select_Spec
1908 (Typ : Entity_Id) return Node_Id
1909 is
1910 Loc : constant Source_Ptr := Sloc (Typ);
1911 Def_Id : constant Node_Id :=
1912 Make_Defining_Identifier (Loc,
1913 Name_uDisp_Conditional_Select);
1914 Params : constant List_Id := New_List;
1915
1916 begin
b0efe69e
JM		 1917 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1918
d0dd5209
JM		 1919 -- T : in out Typ; -- Object parameter
1920 -- S : Integer; -- Primitive operation slot
1921 -- P : Address; -- Wrapped parameters
1922 -- C : out Prim_Op_Kind; -- Call kind
1923 -- F : out Boolean; -- Status flag
1924
1925 Append_List_To (Params, New_List (
1926
1927 Make_Parameter_Specification (Loc,
1928 Defining_Identifier =>
1929 Make_Defining_Identifier (Loc, Name_uT),
1930 Parameter_Type =>
1931 New_Reference_To (Typ, Loc),
1932 In_Present => True,
1933 Out_Present => True),
1934
1935 Make_Parameter_Specification (Loc,
1936 Defining_Identifier =>
1937 Make_Defining_Identifier (Loc, Name_uS),
1938 Parameter_Type =>
1939 New_Reference_To (Standard_Integer, Loc)),
1940
1941 Make_Parameter_Specification (Loc,
1942 Defining_Identifier =>
1943 Make_Defining_Identifier (Loc, Name_uP),
1944 Parameter_Type =>
1945 New_Reference_To (RTE (RE_Address), Loc)),
f4d379b8 1946
d0dd5209
JM		 1947 Make_Parameter_Specification (Loc,
1948 Defining_Identifier =>
1949 Make_Defining_Identifier (Loc, Name_uC),
1950 Parameter_Type =>
1951 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
1952 Out_Present => True),
f4d379b8 1953
d0dd5209
JM		 1954 Make_Parameter_Specification (Loc,
1955 Defining_Identifier =>
1956 Make_Defining_Identifier (Loc, Name_uF),
1957 Parameter_Type =>
1958 New_Reference_To (Standard_Boolean, Loc),
1959 Out_Present => True)));
f4d379b8
HK		 1960
1961 return
1962 Make_Procedure_Specification (Loc,
1963 Defining_Unit_Name => Def_Id,
1964 Parameter_Specifications => Params);
1965 end Make_Disp_Conditional_Select_Spec;
1966
1967 -------------------------------------
1968 -- Make_Disp_Get_Prim_Op_Kind_Body --
1969 -------------------------------------
1970
1971 function Make_Disp_Get_Prim_Op_Kind_Body
1972 (Typ : Entity_Id) return Node_Id
1973 is
1974 Loc : constant Source_Ptr := Sloc (Typ);
1975 DT_Ptr : Entity_Id;
1976
1977 begin
b0efe69e
JM		 1978 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1979
f4d379b8
HK		 1980 if Is_Interface (Typ) then
1981 return
1982 Make_Subprogram_Body (Loc,
1983 Specification =>
1984 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
1985 Declarations =>
1986 New_List,
1987 Handled_Statement_Sequence =>
1988 Make_Handled_Sequence_Of_Statements (Loc,
1989 New_List (Make_Null_Statement (Loc))));
3ca505dc
JM		 1990 end if;
1991
f4d379b8
HK		 1992 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1993
10b93b2e 1994 -- Generate:
f4d379b8 1995 -- C := get_prim_op_kind (tag! (<type>VP), S);
70482933 1996
f4d379b8
HK		 1997 -- where C is the out parameter capturing the call kind and S is the
1998 -- dispatch table slot number.
70482933 1999
f4d379b8
HK		 2000 return
2001 Make_Subprogram_Body (Loc,
2002 Specification =>
2003 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2004 Declarations =>
2005 New_List,
2006 Handled_Statement_Sequence =>
2007 Make_Handled_Sequence_Of_Statements (Loc,
2008 New_List (
2009 Make_Assignment_Statement (Loc,
2010 Name =>
2011 Make_Identifier (Loc, Name_uC),
2012 Expression =>
d0dd5209
JM		 2013 Make_Function_Call (Loc,
2014 Name =>
2015 New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2016 Parameter_Associations => New_List (
2017 Unchecked_Convert_To (RTE (RE_Tag),
2018 New_Reference_To (DT_Ptr, Loc)),
2019 Make_Identifier (Loc, Name_uS)))))));
f4d379b8 2020 end Make_Disp_Get_Prim_Op_Kind_Body;
3ca505dc 2021
f4d379b8
HK		 2022 -------------------------------------
2023 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2024 -------------------------------------
3ca505dc 2025
f4d379b8
HK		 2026 function Make_Disp_Get_Prim_Op_Kind_Spec
2027 (Typ : Entity_Id) return Node_Id
2028 is
2029 Loc : constant Source_Ptr := Sloc (Typ);
2030 Def_Id : constant Node_Id :=
2031 Make_Defining_Identifier (Loc,
2032 Name_uDisp_Get_Prim_Op_Kind);
2033 Params : constant List_Id := New_List;
3ca505dc 2034
f4d379b8 2035 begin
b0efe69e
JM		 2036 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2037
d0dd5209
JM		 2038 -- T : in out Typ; -- Object parameter
2039 -- S : Integer; -- Primitive operation slot
2040 -- C : out Prim_Op_Kind; -- Call kind
2041
2042 Append_List_To (Params, New_List (
2043
2044 Make_Parameter_Specification (Loc,
2045 Defining_Identifier =>
2046 Make_Defining_Identifier (Loc, Name_uT),
2047 Parameter_Type =>
2048 New_Reference_To (Typ, Loc),
2049 In_Present => True,
2050 Out_Present => True),
70482933 2051
d0dd5209
JM		 2052 Make_Parameter_Specification (Loc,
2053 Defining_Identifier =>
2054 Make_Defining_Identifier (Loc, Name_uS),
2055 Parameter_Type =>
2056 New_Reference_To (Standard_Integer, Loc)),
70482933 2057
d0dd5209
JM		 2058 Make_Parameter_Specification (Loc,
2059 Defining_Identifier =>
2060 Make_Defining_Identifier (Loc, Name_uC),
2061 Parameter_Type =>
2062 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2063 Out_Present => True)));
f4d379b8
HK		 2064
2065 return
2066 Make_Procedure_Specification (Loc,
2067 Defining_Unit_Name => Def_Id,
2068 Parameter_Specifications => Params);
2069 end Make_Disp_Get_Prim_Op_Kind_Spec;
2070
2071 --------------------------------
2072 -- Make_Disp_Get_Task_Id_Body --
2073 --------------------------------
2074
2075 function Make_Disp_Get_Task_Id_Body
2076 (Typ : Entity_Id) return Node_Id
2077 is
2078 Loc : constant Source_Ptr := Sloc (Typ);
2079 Ret : Node_Id;
2080
2081 begin
b0efe69e
JM		 2082 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2083
f4d379b8
HK		 2084 if Is_Concurrent_Record_Type (Typ)
2085 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2086 then
d0dd5209
JM		 2087 -- Generate:
2088 -- return To_Address (_T._task_id);
2089
f4d379b8 2090 Ret :=
b2e1beb3 2091 Make_Simple_Return_Statement (Loc,
f4d379b8 2092 Expression =>
d0dd5209
JM		 2093 Make_Unchecked_Type_Conversion (Loc,
2094 Subtype_Mark =>
2095 New_Reference_To (RTE (RE_Address), Loc),
2096 Expression =>
2097 Make_Selected_Component (Loc,
2098 Prefix =>
2099 Make_Identifier (Loc, Name_uT),
2100 Selector_Name =>
2101 Make_Identifier (Loc, Name_uTask_Id))));
f4d379b8
HK		 2102
2103 -- A null body is constructed for non-task types
2104
2105 else
d0dd5209
JM		 2106 -- Generate:
2107 -- return Null_Address;
2108
f4d379b8 2109 Ret :=
b2e1beb3 2110 Make_Simple_Return_Statement (Loc,
f4d379b8 2111 Expression =>
d0dd5209 2112 New_Reference_To (RTE (RE_Null_Address), Loc));
f4d379b8
HK		 2113 end if;
2114
2115 return
2116 Make_Subprogram_Body (Loc,
2117 Specification =>
2118 Make_Disp_Get_Task_Id_Spec (Typ),
2119 Declarations =>
2120 New_List,
2121 Handled_Statement_Sequence =>
2122 Make_Handled_Sequence_Of_Statements (Loc,
2123 New_List (Ret)));
2124 end Make_Disp_Get_Task_Id_Body;
2125
2126 --------------------------------
2127 -- Make_Disp_Get_Task_Id_Spec --
2128 --------------------------------
2129
2130 function Make_Disp_Get_Task_Id_Spec
2131 (Typ : Entity_Id) return Node_Id
2132 is
d0dd5209 2133 Loc : constant Source_Ptr := Sloc (Typ);
f4d379b8
HK		 2134
2135 begin
b0efe69e
JM		 2136 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2137
f4d379b8
HK		 2138 return
2139 Make_Function_Specification (Loc,
d0dd5209
JM		 2140 Defining_Unit_Name =>
2141 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
f4d379b8
HK		 2142 Parameter_Specifications => New_List (
2143 Make_Parameter_Specification (Loc,
2144 Defining_Identifier =>
2145 Make_Defining_Identifier (Loc, Name_uT),
2146 Parameter_Type =>
2147 New_Reference_To (Typ, Loc))),
2148 Result_Definition =>
d0dd5209 2149 New_Reference_To (RTE (RE_Address), Loc));
f4d379b8
HK		 2150 end Make_Disp_Get_Task_Id_Spec;
2151
2152 ---------------------------------
2153 -- Make_Disp_Timed_Select_Body --
2154 ---------------------------------
2155
2156 function Make_Disp_Timed_Select_Body
2157 (Typ : Entity_Id) return Node_Id
2158 is
2159 Loc : constant Source_Ptr := Sloc (Typ);
2160 Conc_Typ : Entity_Id := Empty;
2161 Decls : constant List_Id := New_List;
2162 DT_Ptr : Entity_Id;
2163 Stmts : constant List_Id := New_List;
2164
2165 begin
b0efe69e
JM		 2166 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2167
4d744221
JM		 2168 -- Null body is generated for interface types
2169
f4d379b8
HK		 2170 if Is_Interface (Typ) then
2171 return
2172 Make_Subprogram_Body (Loc,
2173 Specification =>
2174 Make_Disp_Timed_Select_Spec (Typ),
2175 Declarations =>
2176 New_List,
2177 Handled_Statement_Sequence =>
2178 Make_Handled_Sequence_Of_Statements (Loc,
2179 New_List (Make_Null_Statement (Loc))));
2180 end if;
2181
f4d379b8
HK		 2182 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2183
4d744221
JM		 2184 if Is_Concurrent_Record_Type (Typ) then
2185 Conc_Typ := Corresponding_Concurrent_Type (Typ);
f4d379b8
HK		 2186
2187 -- Generate:
2188 -- I : Integer;
2189
2190 -- where I will be used to capture the entry index of the primitive
2191 -- wrapper at position S.
2192
2193 Append_To (Decls,
2194 Make_Object_Declaration (Loc,
2195 Defining_Identifier =>
2196 Make_Defining_Identifier (Loc, Name_uI),
2197 Object_Definition =>
2198 New_Reference_To (Standard_Integer, Loc)));
f4d379b8 2199
4d744221
JM		 2200 -- Generate:
2201 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
f4d379b8 2202
4d744221
JM		 2203 -- if C = POK_Procedure
2204 -- or else C = POK_Protected_Procedure
2205 -- or else C = POK_Task_Procedure;
2206 -- then
2207 -- F := True;
2208 -- return;
2209 -- end if;
f4d379b8 2210
d0dd5209 2211 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
f4d379b8
HK		 2212
2213 -- Generate:
4d744221 2214 -- I := Get_Entry_Index (tag! (<type>VP), S);
f4d379b8
HK		 2215
2216 -- I is the entry index and S is the dispatch table slot
2217
2218 Append_To (Stmts,
2219 Make_Assignment_Statement (Loc,
2220 Name =>
2221 Make_Identifier (Loc, Name_uI),
2222 Expression =>
d0dd5209
JM		 2223 Make_Function_Call (Loc,
2224 Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2225 Parameter_Associations => New_List (
2226 Unchecked_Convert_To (RTE (RE_Tag),
2227 New_Reference_To (DT_Ptr, Loc)),
2228 Make_Identifier (Loc, Name_uS)))));
f4d379b8
HK		 2229
2230 if Ekind (Conc_Typ) = E_Protected_Type then
2231
2232 -- Generate:
2233 -- Timed_Protected_Entry_Call (
2234 -- T._object'access,
2235 -- protected_entry_index! (I),
2236 -- P,
2237 -- D,
2238 -- M,
2239 -- F);
2240
2241 -- where T is the protected object, I is the entry index, P are
2242 -- the wrapped parameters, D is the delay amount, M is the delay
2243 -- mode and F is the status flag.
2244
2245 Append_To (Stmts,
2246 Make_Procedure_Call_Statement (Loc,
2247 Name =>
2248 New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
2249 Parameter_Associations =>
2250 New_List (
2251
2252 Make_Attribute_Reference (Loc, -- T._object'access
2253 Attribute_Name =>
2254 Name_Unchecked_Access,
2255 Prefix =>
2256 Make_Selected_Component (Loc,
2257 Prefix =>
2258 Make_Identifier (Loc, Name_uT),
2259 Selector_Name =>
2260 Make_Identifier (Loc, Name_uObject))),
2261
2262 Make_Unchecked_Type_Conversion (Loc, -- entry index
2263 Subtype_Mark =>
2264 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
2265 Expression =>
2266 Make_Identifier (Loc, Name_uI)),
2267
2268 Make_Identifier (Loc, Name_uP), -- parameter block
2269 Make_Identifier (Loc, Name_uD), -- delay
2270 Make_Identifier (Loc, Name_uM), -- delay mode
2271 Make_Identifier (Loc, Name_uF)))); -- status flag
70482933 2272
70482933 2273 else
f4d379b8
HK		 2274 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2275
2276 -- Generate:
2277 -- Timed_Task_Entry_Call (
2278 -- T._task_id,
2279 -- task_entry_index! (I),
2280 -- P,
2281 -- D,
2282 -- M,
2283 -- F);
2284
2285 -- where T is the task object, I is the entry index, P are the
2286 -- wrapped parameters, D is the delay amount, M is the delay
2287 -- mode and F is the status flag.
2288
2289 Append_To (Stmts,
2290 Make_Procedure_Call_Statement (Loc,
2291 Name =>
2292 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2293 Parameter_Associations =>
2294 New_List (
2295
2296 Make_Selected_Component (Loc, -- T._task_id
2297 Prefix =>
2298 Make_Identifier (Loc, Name_uT),
2299 Selector_Name =>
2300 Make_Identifier (Loc, Name_uTask_Id)),
2301
2302 Make_Unchecked_Type_Conversion (Loc, -- entry index
2303 Subtype_Mark =>
2304 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2305 Expression =>
2306 Make_Identifier (Loc, Name_uI)),
2307
2308 Make_Identifier (Loc, Name_uP), -- parameter block
2309 Make_Identifier (Loc, Name_uD), -- delay
2310 Make_Identifier (Loc, Name_uM), -- delay mode
2311 Make_Identifier (Loc, Name_uF)))); -- status flag
70482933 2312 end if;
f4d379b8
HK		 2313 end if;
2314
2315 return
2316 Make_Subprogram_Body (Loc,
2317 Specification =>
2318 Make_Disp_Timed_Select_Spec (Typ),
2319 Declarations =>
2320 Decls,
2321 Handled_Statement_Sequence =>
2322 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2323 end Make_Disp_Timed_Select_Body;
2324
2325 ---------------------------------
2326 -- Make_Disp_Timed_Select_Spec --
2327 ---------------------------------
2328
2329 function Make_Disp_Timed_Select_Spec
2330 (Typ : Entity_Id) return Node_Id
2331 is
2332 Loc : constant Source_Ptr := Sloc (Typ);
2333 Def_Id : constant Node_Id :=
2334 Make_Defining_Identifier (Loc,
2335 Name_uDisp_Timed_Select);
2336 Params : constant List_Id := New_List;
70482933 2337
f4d379b8 2338 begin
b0efe69e
JM		 2339 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2340
d0dd5209
JM		 2341 -- T : in out Typ; -- Object parameter
2342 -- S : Integer; -- Primitive operation slot
2343 -- P : Address; -- Wrapped parameters
2344 -- D : Duration; -- Delay
2345 -- M : Integer; -- Delay Mode
2346 -- C : out Prim_Op_Kind; -- Call kind
2347 -- F : out Boolean; -- Status flag
f4d379b8 2348
d0dd5209
JM		 2349 Append_List_To (Params, New_List (
2350
2351 Make_Parameter_Specification (Loc,
2352 Defining_Identifier =>
2353 Make_Defining_Identifier (Loc, Name_uT),
2354 Parameter_Type =>
2355 New_Reference_To (Typ, Loc),
2356 In_Present => True,
2357 Out_Present => True),
2358
2359 Make_Parameter_Specification (Loc,
2360 Defining_Identifier =>
2361 Make_Defining_Identifier (Loc, Name_uS),
2362 Parameter_Type =>
2363 New_Reference_To (Standard_Integer, Loc)),
2364
2365 Make_Parameter_Specification (Loc,
2366 Defining_Identifier =>
2367 Make_Defining_Identifier (Loc, Name_uP),
2368 Parameter_Type =>
2369 New_Reference_To (RTE (RE_Address), Loc)),
f4d379b8 2370
f4d379b8
HK		 2371 Make_Parameter_Specification (Loc,
2372 Defining_Identifier =>
2373 Make_Defining_Identifier (Loc, Name_uD),
2374 Parameter_Type =>
d0dd5209 2375 New_Reference_To (Standard_Duration, Loc)),
f4d379b8 2376
f4d379b8
HK		 2377 Make_Parameter_Specification (Loc,
2378 Defining_Identifier =>
2379 Make_Defining_Identifier (Loc, Name_uM),
2380 Parameter_Type =>
d0dd5209 2381 New_Reference_To (Standard_Integer, Loc)),
70482933 2382
d0dd5209
JM		 2383 Make_Parameter_Specification (Loc,
2384 Defining_Identifier =>
2385 Make_Defining_Identifier (Loc, Name_uC),
2386 Parameter_Type =>
2387 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2388 Out_Present => True)));
70482933 2389
d0dd5209
JM		 2390 Append_To (Params,
2391 Make_Parameter_Specification (Loc,
2392 Defining_Identifier =>
2393 Make_Defining_Identifier (Loc, Name_uF),
2394 Parameter_Type =>
2395 New_Reference_To (Standard_Boolean, Loc),
2396 Out_Present => True));
70482933 2397
f4d379b8
HK		 2398 return
2399 Make_Procedure_Specification (Loc,
2400 Defining_Unit_Name => Def_Id,
2401 Parameter_Specifications => Params);
2402 end Make_Disp_Timed_Select_Spec;
70482933 2403
f4d379b8
HK		 2404 -------------
2405 -- Make_DT --
2406 -------------
70482933 2407
d0dd5209
JM		 2408 -- The frontend supports two models for expanding dispatch tables
2409 -- associated with library-level defined tagged types: statically
2410 -- and non-statically allocated dispatch tables. In the former case
2411 -- the object containing the dispatch table is constant and it is
2412 -- initialized by means of a positional aggregate. In the latter case,
2413 -- the object containing the dispatch table is a variable which is
2414 -- initialized by means of assignments.
2415
2416 -- In case of locally defined tagged types, the object containing the
2417 -- object containing the dispatch table is always a variable (instead
2418 -- of a constant). This is currently required to give support to late
2419 -- overriding of primitives. For example:
2420
2421 -- procedure Example is
2422 -- package Pkg is
2423 -- type T1 is tagged null record;
2424 -- procedure Prim (O : T1);
2425 -- end Pkg;
2426
2427 -- type T2 is new Pkg.T1 with null record;
2428 -- procedure Prim (X : T2) is -- late overriding
2429 -- begin
2430 -- ...
2431 -- ...
2432 -- end;
4d744221 2433
b2e1beb3
ES		 2434 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
2435 Loc : constant Source_Ptr := Sloc (Typ);
2436
2437 Has_DT : constant Boolean :=
2438 not Is_Interface (Typ)
2439 and then not Restriction_Active (No_Dispatching_Calls);
2440
2441 Build_Static_DT : constant Boolean :=
2442 Static_Dispatch_Tables
2443 and then Is_Library_Level_Tagged_Type (Typ);
2444
d0dd5209
JM		 2445 Max_Predef_Prims : constant Int :=
2446 UI_To_Int
2447 (Intval
2448 (Expression
b2e1beb3
ES		 2449 (Parent (RTE (RE_Max_Predef_Prims)))));
2450
2451 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
2452 -- Verify that all non-tagged types in the profile of a subprogram
2453 -- are frozen at the point the subprogram is frozen. This enforces
2454 -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
2455 -- subprogram is frozen, enough must be known about it to build the
2456 -- activation record for it, which requires at least that the size of
2457 -- all parameters be known. Controlling arguments are by-reference,
2458 -- and therefore the rule only applies to non-tagged types.
2459 -- Typical violation of the rule involves an object declaration that
2460 -- freezes a tagged type, when one of its primitive operations has a
2461 -- type in its profile whose full view has not been analyzed yet.
d0dd5209
JM		 2462
2463 procedure Make_Secondary_DT
b2e1beb3
ES		 2464 (Typ : Entity_Id;
2465 Iface : Entity_Id;
2466 AI_Tag : Entity_Id;
2467 Iface_DT_Ptr : Entity_Id;
2468 Result : List_Id);
d0dd5209
JM		 2469 -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
2470 -- Table of Typ associated with Iface (each abstract interface of Typ
2471 -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ
2472 -- and Suffix_Index are used to generate an unique external name which
2473 -- is added at the end of Acc_Disp_Tables; this external name will be
2474 -- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
fbf5a39b 2475
b2e1beb3
ES		 2476 ------------------------------
2477 -- Check_Premature_Freezing --
2478 ------------------------------
2479
2480 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
2481 begin
2482 if Present (N)
2483 and then Is_Private_Type (Typ)
2484 and then No (Full_View (Typ))
2485 and then not Is_Generic_Type (Typ)
2486 and then not Is_Tagged_Type (Typ)
2487 and then not Is_Frozen (Typ)
2488 then
2489 Error_Msg_Sloc := Sloc (Subp);
2490 Error_Msg_NE
2491 ("declaration must appear after completion of type &", N, Typ);
2492 Error_Msg_NE
2493 ("\which is an untagged type in the profile of"
2494 & " primitive operation & declared#",
2495 N, Subp);
2496 end if;
2497 end Check_Premature_Freezing;
2498
d0dd5209
JM		 2499 -----------------------
2500 -- Make_Secondary_DT --
2501 -----------------------
70482933 2502
d0dd5209
JM		 2503 procedure Make_Secondary_DT
2504 (Typ : Entity_Id;
2505 Iface : Entity_Id;
2506 AI_Tag : Entity_Id;
2507 Iface_DT_Ptr : Entity_Id;
2508 Result : List_Id)
2509 is
2510 Loc : constant Source_Ptr := Sloc (Typ);
2511 Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
d0dd5209
JM		 2512 Name_DT : constant Name_Id := New_Internal_Name ('T');
2513 Iface_DT : constant Entity_Id :=
2514 Make_Defining_Identifier (Loc, Name_DT);
2515 Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
2516 Predef_Prims : constant Entity_Id :=
2517 Make_Defining_Identifier (Loc,
2518 Name_Predef_Prims);
2519 DT_Constr_List : List_Id;
2520 DT_Aggr_List : List_Id;
2521 Empty_DT : Boolean := False;
2522 Nb_Predef_Prims : Nat := 0;
2523 Nb_Prim : Nat;
2524 New_Node : Node_Id;
2525 OSD : Entity_Id;
2526 OSD_Aggr_List : List_Id;
2527 Pos : Nat;
2528 Prim : Entity_Id;
2529 Prim_Elmt : Elmt_Id;
2530 Prim_Ops_Aggr_List : List_Id;
dee4682a 2531
d0dd5209 2532 begin
b2e1beb3
ES		 2533 -- Handle cases in which we do not generate statically allocated
2534 -- dispatch tables.
dee4682a 2535
b2e1beb3 2536 if not Build_Static_DT then
d0dd5209
JM		 2537 Set_Ekind (Predef_Prims, E_Variable);
2538 Set_Is_Statically_Allocated (Predef_Prims);
dee4682a 2539
d0dd5209
JM		 2540 Set_Ekind (Iface_DT, E_Variable);
2541 Set_Is_Statically_Allocated (Iface_DT);
dee4682a 2542
d0dd5209
JM		 2543 -- Statically allocated dispatch tables and related entities are
2544 -- constants.
dee4682a 2545
d0dd5209
JM		 2546 else
2547 Set_Ekind (Predef_Prims, E_Constant);
2548 Set_Is_Statically_Allocated (Predef_Prims);
2549 Set_Is_True_Constant (Predef_Prims);
dee4682a 2550
d0dd5209
JM		 2551 Set_Ekind (Iface_DT, E_Constant);
2552 Set_Is_Statically_Allocated (Iface_DT);
2553 Set_Is_True_Constant (Iface_DT);
dee4682a
JM		 2554 end if;
2555
d0dd5209
JM		 2556 -- Generate code to create the storage for the Dispatch_Table object.
2557 -- If the number of primitives of Typ is 0 we reserve a dummy single
2558 -- entry for its DT because at run-time the pointer to this dummy
2559 -- entry will be used as the tag.
b0efe69e 2560
d0dd5209 2561 Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
758c442c 2562
d0dd5209
JM		 2563 if Nb_Prim = 0 then
2564 Empty_DT := True;
2565 Nb_Prim := 1;
2566 end if;
f4d379b8 2567
d0dd5209 2568 -- Generate:
4d744221 2569
d0dd5209
JM		 2570 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
2571 -- (predef-prim-op-thunk-1'address,
2572 -- predef-prim-op-thunk-2'address,
2573 -- ...
2574 -- predef-prim-op-thunk-n'address);
2575 -- for Predef_Prims'Alignment use Address'Alignment
4d744221 2576
d0dd5209 2577 -- Stage 1: Calculate the number of predefined primitives
f4d379b8 2578
b2e1beb3 2579 if not Build_Static_DT then
d0dd5209
JM		 2580 Nb_Predef_Prims := Max_Predef_Prims;
2581 else
2582 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2583 while Present (Prim_Elmt) loop
2584 Prim := Node (Prim_Elmt);
758c442c 2585
d0dd5209
JM		 2586 if Is_Predefined_Dispatching_Operation (Prim)
2587 and then not Is_Abstract_Subprogram (Prim)
2588 then
2589 Pos := UI_To_Int (DT_Position (Prim));
758c442c 2590
d0dd5209
JM		 2591 if Pos > Nb_Predef_Prims then
2592 Nb_Predef_Prims := Pos;
2593 end if;
2594 end if;
758c442c 2595
d0dd5209
JM		 2596 Next_Elmt (Prim_Elmt);
2597 end loop;
2598 end if;
758c442c 2599
d0dd5209
JM		 2600 -- Stage 2: Create the thunks associated with the predefined
2601 -- primitives and save their entity to fill the aggregate.
70482933 2602
d0dd5209
JM		 2603 declare
2604 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
2605 Thunk_Id : Entity_Id;
2606 Thunk_Code : Node_Id;
758c442c 2607
d0dd5209
JM		 2608 begin
2609 Prim_Ops_Aggr_List := New_List;
2610 Prim_Table := (others => Empty);
758c442c 2611
d0dd5209
JM		 2612 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2613 while Present (Prim_Elmt) loop
2614 Prim := Node (Prim_Elmt);
758c442c 2615
d0dd5209
JM		 2616 if Is_Predefined_Dispatching_Operation (Prim)
2617 and then not Is_Abstract_Subprogram (Prim)
2618 and then not Present (Prim_Table
2619 (UI_To_Int (DT_Position (Prim))))
2620 then
2621 while Present (Alias (Prim)) loop
2622 Prim := Alias (Prim);
2623 end loop;
758c442c 2624
b2e1beb3 2625 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
758c442c 2626
d0dd5209
JM		 2627 if Present (Thunk_Id) then
2628 Append_To (Result, Thunk_Code);
2629 Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id;
2630 end if;
2631 end if;
758c442c 2632
d0dd5209
JM		 2633 Next_Elmt (Prim_Elmt);
2634 end loop;
758c442c 2635
d0dd5209
JM		 2636 for J in Prim_Table'Range loop
2637 if Present (Prim_Table (J)) then
2638 New_Node :=
2639 Make_Attribute_Reference (Loc,
2640 Prefix => New_Reference_To (Prim_Table (J), Loc),
2641 Attribute_Name => Name_Address);
2642 else
2643 New_Node :=
2644 New_Reference_To (RTE (RE_Null_Address), Loc);
2645 end if;
4d744221 2646
d0dd5209
JM		 2647 Append_To (Prim_Ops_Aggr_List, New_Node);
2648 end loop;
4d744221 2649
d0dd5209
JM		 2650 Append_To (Result,
2651 Make_Object_Declaration (Loc,
2652 Defining_Identifier => Predef_Prims,
b2e1beb3 2653 Constant_Present => Build_Static_DT,
d0dd5209
JM		 2654 Aliased_Present => True,
2655 Object_Definition =>
2656 New_Reference_To (RTE (RE_Address_Array), Loc),
2657 Expression => Make_Aggregate (Loc,
2658 Expressions => Prim_Ops_Aggr_List)));
758c442c 2659
d0dd5209
JM		 2660 Append_To (Result,
2661 Make_Attribute_Definition_Clause (Loc,
2662 Name => New_Reference_To (Predef_Prims, Loc),
2663 Chars => Name_Alignment,
2664 Expression =>
2665 Make_Attribute_Reference (Loc,
2666 Prefix =>
2667 New_Reference_To (RTE (RE_Integer_Address), Loc),
2668 Attribute_Name => Name_Alignment)));
2669 end;
758c442c 2670
d0dd5209 2671 -- Generate
f4d379b8 2672
d0dd5209
JM		 2673 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
2674 -- (OSD_Table => (1 => <value>,
2675 -- ...
2676 -- N => <value>));
f4d379b8 2677
d0dd5209
JM		 2678 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
2679 -- ([ Signature => <sig-value> ],
2680 -- Tag_Kind => <tag_kind-value>,
2681 -- Predef_Prims => Predef_Prims'Address,
2682 -- Offset_To_Top => 0,
2683 -- OSD => OSD'Address,
2684 -- Prims_Ptr => (prim-op-1'address,
2685 -- prim-op-2'address,
2686 -- ...
2687 -- prim-op-n'address));
f4d379b8 2688
d0dd5209 2689 -- Stage 3: Initialize the discriminant and the record components
758c442c 2690
d0dd5209
JM		 2691 DT_Constr_List := New_List;
2692 DT_Aggr_List := New_List;
dee4682a 2693
d0dd5209
JM		 2694 -- Nb_Prim. If the tagged type has no primitives we add a dummy
2695 -- slot whose address will be the tag of this type.
dee4682a 2696
d0dd5209
JM		 2697 if Nb_Prim = 0 then
2698 New_Node := Make_Integer_Literal (Loc, 1);
2699 else
2700 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
2701 end if;
dee4682a 2702
d0dd5209
JM		 2703 Append_To (DT_Constr_List, New_Node);
2704 Append_To (DT_Aggr_List, New_Copy (New_Node));
dee4682a 2705
d0dd5209 2706 -- Signature
dee4682a 2707
d0dd5209
JM		 2708 if RTE_Record_Component_Available (RE_Signature) then
2709 Append_To (DT_Aggr_List,
2710 New_Reference_To (RTE (RE_Secondary_DT), Loc));
2711 end if;
dee4682a 2712
d0dd5209 2713 -- Tag_Kind
dee4682a 2714
d0dd5209
JM		 2715 if RTE_Record_Component_Available (RE_Tag_Kind) then
2716 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
2717 end if;
758c442c 2718
d0dd5209 2719 -- Predef_Prims
758c442c 2720
d0dd5209
JM		 2721 Append_To (DT_Aggr_List,
2722 Make_Attribute_Reference (Loc,
2723 Prefix => New_Reference_To (Predef_Prims, Loc),
2724 Attribute_Name => Name_Address));
758c442c 2725
d0dd5209
JM		 2726 -- Note: The correct value of Offset_To_Top will be set by the init
2727 -- subprogram
758c442c 2728
d0dd5209 2729 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
758c442c 2730
d0dd5209
JM		 2731 -- Generate the Object Specific Data table required to dispatch calls
2732 -- through synchronized interfaces.
758c442c 2733
d0dd5209
JM		 2734 if Empty_DT
2735 or else Is_Abstract_Type (Typ)
2736 or else Is_Controlled (Typ)
2737 or else Restriction_Active (No_Dispatching_Calls)
2738 or else not Is_Limited_Type (Typ)
2739 or else not Has_Abstract_Interfaces (Typ)
2740 then
2741 -- No OSD table required
70482933 2742
d0dd5209
JM		 2743 Append_To (DT_Aggr_List,
2744 New_Reference_To (RTE (RE_Null_Address), Loc));
10b93b2e 2745
d0dd5209
JM		 2746 else
2747 OSD_Aggr_List := New_List;
10b93b2e 2748
d0dd5209
JM		 2749 declare
2750 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
2751 Prim : Entity_Id;
2752 Prim_Alias : Entity_Id;
2753 Prim_Elmt : Elmt_Id;
2754 E : Entity_Id;
2755 Count : Nat := 0;
2756 Pos : Nat;
10b93b2e 2757
d0dd5209
JM		 2758 begin
2759 Prim_Table := (others => Empty);
2760 Prim_Alias := Empty;
10b93b2e 2761
d0dd5209
JM		 2762 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2763 while Present (Prim_Elmt) loop
2764 Prim := Node (Prim_Elmt);
10b93b2e 2765
d0dd5209
JM		 2766 if Present (Abstract_Interface_Alias (Prim))
2767 and then Find_Dispatching_Type
2768 (Abstract_Interface_Alias (Prim)) = Iface
2769 then
2770 Prim_Alias := Abstract_Interface_Alias (Prim);
10b93b2e 2771
d0dd5209
JM		 2772 E := Prim;
2773 while Present (Alias (E)) loop
2774 E := Alias (E);
2775 end loop;
b0efe69e 2776
d0dd5209 2777 Pos := UI_To_Int (DT_Position (Prim_Alias));
b0efe69e 2778
d0dd5209
JM		 2779 if Present (Prim_Table (Pos)) then
2780 pragma Assert (Prim_Table (Pos) = E);
2781 null;
b0efe69e 2782
d0dd5209
JM		 2783 else
2784 Prim_Table (Pos) := E;
2785
2786 Append_To (OSD_Aggr_List,
2787 Make_Component_Association (Loc,
2788 Choices => New_List (
2789 Make_Integer_Literal (Loc,
2790 DT_Position (Prim_Alias))),
2791 Expression =>
2792 Make_Integer_Literal (Loc,
2793 DT_Position (Alias (Prim)))));
2794
2795 Count := Count + 1;
2796 end if;
2797 end if;
2798
2799 Next_Elmt (Prim_Elmt);
2800 end loop;
2801 pragma Assert (Count = Nb_Prim);
2802 end;
2803
2804 OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
2805
2806 Append_To (Result,
2807 Make_Object_Declaration (Loc,
2808 Defining_Identifier => OSD,
2809 Object_Definition =>
2810 Make_Subtype_Indication (Loc,
2811 Subtype_Mark =>
2812 New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
2813 Constraint =>
2814 Make_Index_Or_Discriminant_Constraint (Loc,
2815 Constraints => New_List (
2816 Make_Integer_Literal (Loc, Nb_Prim)))),
2817 Expression => Make_Aggregate (Loc,
2818 Component_Associations => New_List (
2819 Make_Component_Association (Loc,
2820 Choices => New_List (
2821 New_Occurrence_Of
2822 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
2823 Expression =>
2824 Make_Integer_Literal (Loc, Nb_Prim)),
2825
2826 Make_Component_Association (Loc,
2827 Choices => New_List (
2828 New_Occurrence_Of
2829 (RTE_Record_Component (RE_OSD_Table), Loc)),
2830 Expression => Make_Aggregate (Loc,
2831 Component_Associations => OSD_Aggr_List))))));
2832
b2e1beb3
ES		 2833 Append_To (Result,
2834 Make_Attribute_Definition_Clause (Loc,
2835 Name => New_Reference_To (OSD, Loc),
2836 Chars => Name_Alignment,
2837 Expression =>
2838 Make_Attribute_Reference (Loc,
2839 Prefix =>
2840 New_Reference_To (RTE (RE_Integer_Address), Loc),
2841 Attribute_Name => Name_Alignment)));
2842
d0dd5209
JM		 2843 -- In secondary dispatch tables the Typeinfo component contains
2844 -- the address of the Object Specific Data (see a-tags.ads)
2845
2846 Append_To (DT_Aggr_List,
2847 Make_Attribute_Reference (Loc,
2848 Prefix => New_Reference_To (OSD, Loc),
2849 Attribute_Name => Name_Address));
2850 end if;
2851
2852 -- Initialize the table of primitive operations
2853
2854 Prim_Ops_Aggr_List := New_List;
2855
2856 if Empty_DT then
2857 Append_To (Prim_Ops_Aggr_List,
2858 New_Reference_To (RTE (RE_Null_Address), Loc));
2859
2860 elsif Is_Abstract_Type (Typ)
b2e1beb3 2861 or else not Build_Static_DT
d0dd5209
JM		 2862 then
2863 for J in 1 .. Nb_Prim loop
2864 Append_To (Prim_Ops_Aggr_List,
2865 New_Reference_To (RTE (RE_Null_Address), Loc));
2866 end loop;
2867
2868 else
2869 declare
2870 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
2871 Pos : Nat;
2872 Thunk_Code : Node_Id;
2873 Thunk_Id : Entity_Id;
2874
2875 begin
2876 Prim_Table := (others => Empty);
2877
2878 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2879 while Present (Prim_Elmt) loop
2880 Prim := Node (Prim_Elmt);
2881
2882 if not Is_Predefined_Dispatching_Operation (Prim)
2883 and then Present (Abstract_Interface_Alias (Prim))
2884 and then not Is_Abstract_Subprogram (Alias (Prim))
2885 and then not Is_Imported (Alias (Prim))
2886 and then Find_Dispatching_Type
2887 (Abstract_Interface_Alias (Prim)) = Iface
2888
2889 -- Generate the code of the thunk only if the abstract
2890 -- interface type is not an immediate ancestor of
2891 -- Tagged_Type; otherwise the DT associated with the
2892 -- interface is the primary DT.
2893
2894 and then not Is_Parent (Iface, Typ)
2895 then
b2e1beb3 2896 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
d0dd5209
JM		 2897
2898 if Present (Thunk_Id) then
2899 Pos :=
2900 UI_To_Int
2901 (DT_Position (Abstract_Interface_Alias (Prim)));
2902
2903 Prim_Table (Pos) := Thunk_Id;
2904 Append_To (Result, Thunk_Code);
2905 end if;
2906 end if;
2907
2908 Next_Elmt (Prim_Elmt);
2909 end loop;
2910
2911 for J in Prim_Table'Range loop
2912 if Present (Prim_Table (J)) then
2913 New_Node :=
2914 Make_Attribute_Reference (Loc,
2915 Prefix => New_Reference_To (Prim_Table (J), Loc),
2916 Attribute_Name => Name_Address);
2917 else
2918 New_Node :=
2919 New_Reference_To (RTE (RE_Null_Address), Loc);
2920 end if;
2921
2922 Append_To (Prim_Ops_Aggr_List, New_Node);
2923 end loop;
2924 end;
2925 end if;
2926
2927 Append_To (DT_Aggr_List,
2928 Make_Aggregate (Loc,
2929 Expressions => Prim_Ops_Aggr_List));
2930
2931 Append_To (Result,
2932 Make_Object_Declaration (Loc,
2933 Defining_Identifier => Iface_DT,
2934 Aliased_Present => True,
2935 Object_Definition =>
2936 Make_Subtype_Indication (Loc,
2937 Subtype_Mark => New_Reference_To
2938 (RTE (RE_Dispatch_Table_Wrapper), Loc),
2939 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
2940 Constraints => DT_Constr_List)),
2941
2942 Expression => Make_Aggregate (Loc,
2943 Expressions => DT_Aggr_List)));
2944
b2e1beb3
ES		 2945 Append_To (Result,
2946 Make_Attribute_Definition_Clause (Loc,
2947 Name => New_Reference_To (Iface_DT, Loc),
2948 Chars => Name_Alignment,
2949 Expression =>
2950 Make_Attribute_Reference (Loc,
2951 Prefix =>
2952 New_Reference_To (RTE (RE_Integer_Address), Loc),
2953 Attribute_Name => Name_Alignment)));
2954
d0dd5209
JM		 2955 -- Generate code to create the pointer to the dispatch table
2956
2957 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
2958
2959 Append_To (Result,
2960 Make_Object_Declaration (Loc,
2961 Defining_Identifier => Iface_DT_Ptr,
2962 Constant_Present => True,
2963 Object_Definition =>
2964 New_Reference_To (RTE (RE_Interface_Tag), Loc),
2965 Expression =>
2966 Unchecked_Convert_To (Generalized_Tag,
2967 Make_Attribute_Reference (Loc,
2968 Prefix =>
2969 Make_Selected_Component (Loc,
2970 Prefix => New_Reference_To (Iface_DT, Loc),
2971 Selector_Name =>
2972 New_Occurrence_Of
2973 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
2974 Attribute_Name => Name_Address))));
2975
2976 end Make_Secondary_DT;
2977
2978 -- Local variables
2979
d0dd5209
JM		 2980 Elab_Code : constant List_Id := New_List;
2981 Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
b2e1beb3
ES		 2982 Result : constant List_Id := New_List;
2983 Tname : constant Name_Id := Chars (Typ);
d0dd5209
JM		 2984 AI : Elmt_Id;
2985 AI_Tag_Comp : Elmt_Id;
2986 AI_Ptr_Elmt : Elmt_Id;
2987 DT_Constr_List : List_Id;
2988 DT_Aggr_List : List_Id;
2989 DT_Ptr : Entity_Id;
d0dd5209
JM		 2990 ITable : Node_Id;
2991 I_Depth : Nat := 0;
2992 Iface_Table_Node : Node_Id;
2993 Name_ITable : Name_Id;
2994 Name_No_Reg : Name_Id;
2995 Nb_Predef_Prims : Nat := 0;
2996 Nb_Prim : Nat := 0;
2997 New_Node : Node_Id;
2998 No_Reg : Node_Id;
2999 Null_Parent_Tag : Boolean := False;
3000 Num_Ifaces : Nat := 0;
3001 Old_Tag1 : Node_Id;
3002 Old_Tag2 : Node_Id;
3003 Prim : Entity_Id;
3004 Prim_Elmt : Elmt_Id;
3005 Prim_Ops_Aggr_List : List_Id;
d0dd5209
JM		 3006 Suffix_Index : Int;
3007 Typ_Comps : Elist_Id;
3008 Typ_Ifaces : Elist_Id;
3009 TSD_Aggr_List : List_Id;
3010 TSD_Tags_List : List_Id;
b2e1beb3
ES		 3011
3012 -- The following name entries are used by Make_DT to generate a number
3013 -- of entities related to a tagged type. These entities may be generated
3014 -- in a scope other than that of the tagged type declaration, and if
3015 -- the entities for two tagged types with the same name happen to be
3016 -- generated in the same scope, we have to take care to use different
3017 -- names. This is achieved by means of a unique serial number appended
3018 -- to each generated entity name.
3019
3020 Name_DT : constant Name_Id :=
3021 New_External_Name (Tname, 'T', Suffix_Index => -1);
3022 Name_Exname : constant Name_Id :=
3023 New_External_Name (Tname, 'E', Suffix_Index => -1);
3024 Name_Predef_Prims : constant Name_Id :=
3025 New_External_Name (Tname, 'R', Suffix_Index => -1);
3026 Name_SSD : constant Name_Id :=
3027 New_External_Name (Tname, 'S', Suffix_Index => -1);
3028 Name_TSD : constant Name_Id :=
3029 New_External_Name (Tname, 'B', Suffix_Index => -1);
3030
3031 -- Entities built with above names
3032
3033 DT : constant Entity_Id :=
3034 Make_Defining_Identifier (Loc, Name_DT);
3035 Exname : constant Entity_Id :=
3036 Make_Defining_Identifier (Loc, Name_Exname);
3037 Predef_Prims : constant Entity_Id :=
3038 Make_Defining_Identifier (Loc, Name_Predef_Prims);
3039 SSD : constant Entity_Id :=
3040 Make_Defining_Identifier (Loc, Name_SSD);
3041 TSD : constant Entity_Id :=
3042 Make_Defining_Identifier (Loc, Name_TSD);
d0dd5209
JM		 3043
3044 -- Start of processing for Make_DT
3045
3046 begin
b2e1beb3 3047 pragma Assert (Is_Frozen (Typ));
d0dd5209 3048
b2e1beb3 3049 -- Handle cases in which there is no need to build the dispatch table
d0dd5209 3050
b2e1beb3
ES		 3051 if Has_Dispatch_Table (Typ)
3052 or else No (Access_Disp_Table (Typ))
3053 or else Is_CPP_Class (Typ)
3054 then
d0dd5209 3055 return Result;
d0dd5209 3056
b2e1beb3
ES		 3057 elsif No_Run_Time_Mode then
3058 Error_Msg_CRT ("tagged types", Typ);
3059 return Result;
d0dd5209 3060
b2e1beb3 3061 elsif not RTE_Available (RE_Tag) then
d0dd5209
JM		 3062 Append_To (Result,
3063 Make_Object_Declaration (Loc,
b2e1beb3
ES		 3064 Defining_Identifier => Node (First_Elmt
3065 (Access_Disp_Table (Typ))),
d0dd5209
JM		 3066 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
3067 Constant_Present => True,
3068 Expression =>
3069 Unchecked_Convert_To (Generalized_Tag,
3070 New_Reference_To (RTE (RE_Null_Address), Loc))));
3071
3072 Analyze_List (Result, Suppress => All_Checks);
3073 Error_Msg_CRT ("tagged types", Typ);
3074 return Result;
3075 end if;
3076
b2e1beb3
ES		 3077 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
3078 -- correct. Valid values are 10 under configurable runtime or 15
3079 -- with full runtime.
3080
3081 if RTE_Available (RE_Interface_Data) then
3082 if Max_Predef_Prims /= 15 then
3083 Error_Msg_N ("run-time library configuration error", Typ);
3084 return Result;
3085 end if;
d0dd5209 3086 else
b2e1beb3
ES		 3087 if Max_Predef_Prims /= 10 then
3088 Error_Msg_N ("run-time library configuration error", Typ);
3089 Error_Msg_CRT ("tagged types", Typ);
3090 return Result;
3091 end if;
d0dd5209
JM		 3092 end if;
3093
b2e1beb3
ES		 3094 -- Ensure that all the primitives are frozen. This is only required when
3095 -- building static dispatch tables --- the primitives must be frozen to
3096 -- be referenced (otherwise we have problems with the backend). It is
3097 -- not a requirement with nonstatic dispatch tables because in this case
3098 -- we generate now an empty dispatch table; the extra code required to
3099 -- register the primitive in the slot will be generated later --- when
3100 -- each primitive is frozen (see Freeze_Subprogram).
d0dd5209 3101
b2e1beb3
ES		 3102 if Build_Static_DT
3103 and then not Is_CPP_Class (Typ)
3104 then
3105 declare
3106 Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
3107 Prim_Elmt : Elmt_Id;
3108 Frnodes : List_Id;
d0dd5209 3109
b2e1beb3
ES		 3110 begin
3111 Freezing_Library_Level_Tagged_Type := True;
3112 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3113 while Present (Prim_Elmt) loop
3114 Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
d0dd5209 3115
b2e1beb3
ES		 3116 declare
3117 Subp : constant Entity_Id := Node (Prim_Elmt);
3118 F : Entity_Id;
d0dd5209 3119
b2e1beb3
ES		 3120 begin
3121 F := First_Formal (Subp);
3122 while Present (F) loop
3123 Check_Premature_Freezing (Subp, Etype (F));
3124 Next_Formal (F);
3125 end loop;
3126
3127 Check_Premature_Freezing (Subp, Etype (Subp));
3128 end;
3129
3130 if Present (Frnodes) then
3131 Append_List_To (Result, Frnodes);
3132 end if;
3133
3134 Next_Elmt (Prim_Elmt);
3135 end loop;
3136 Freezing_Library_Level_Tagged_Type := Save;
3137 end;
3138 end if;
d0dd5209 3139
b2e1beb3
ES		 3140 -- In case of locally defined tagged type we declare the object
3141 -- contanining the dispatch table by means of a variable. Its
3142 -- initialization is done later by means of an assignment. This is
3143 -- required to generate its External_Tag.
3144
3145 if not Build_Static_DT then
3146 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
3147 Set_Ekind (DT, E_Variable);
3148
3149 -- Export the declaration of the tag previously generated and imported
3150 -- by Make_Tags.
3151
3152 else
3153 DT_Ptr :=
3154 Make_Defining_Identifier (Loc,
3155 Chars => New_External_Name (Tname, 'C', Suffix_Index => -1));
3156 Set_Ekind (DT_Ptr, E_Constant);
3157 Set_Is_Statically_Allocated (DT_Ptr);
3158 Set_Is_True_Constant (DT_Ptr);
3159
3160 Set_Is_Exported (DT_Ptr);
3161 Get_External_Name (Node (First_Elmt (Access_Disp_Table (Typ))), True);
3162 Set_Interface_Name (DT_Ptr,
3163 Make_String_Literal (Loc,
3164 Strval => String_From_Name_Buffer));
3165
3166 -- Set tag as internal to ensure proper Sprint output of its implicit
3167 -- exportation.
3168
3169 Set_Is_Internal (DT_Ptr);
3170
3171 Set_Ekind (DT, E_Constant);
3172 Set_Is_True_Constant (DT);
3173
3174 -- The tag is made public to ensure its availability to the linker
3175 -- (to handle the forward reference). This is required to handle
3176 -- tagged types defined in library level package bodies.
3177
3178 Set_Is_Public (DT_Ptr);
3179 end if;
3180
3181 Set_Is_Statically_Allocated (DT);
3182
3183 -- Ada 2005 (AI-251): Build the secondary dispatch tables
3184
3185 if Has_Abstract_Interfaces (Typ) then
3186 Collect_Interface_Components (Typ, Typ_Comps);
3187
3188 Suffix_Index := 0;
3189 AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
3190
3191 AI_Tag_Comp := First_Elmt (Typ_Comps);
3192 while Present (AI_Tag_Comp) loop
3193 Make_Secondary_DT
3194 (Typ => Typ,
3195 Iface => Base_Type
3196 (Related_Interface (Node (AI_Tag_Comp))),
3197 AI_Tag => Node (AI_Tag_Comp),
3198 Iface_DT_Ptr => Node (AI_Ptr_Elmt),
3199 Result => Result);
d0dd5209 3200
b2e1beb3
ES		 3201 Suffix_Index := Suffix_Index + 1;
3202 Next_Elmt (AI_Ptr_Elmt);
3203 Next_Elmt (AI_Tag_Comp);
3204 end loop;
3205 end if;
d0dd5209
JM		 3206
3207 -- Calculate the number of primitives of the dispatch table and the
3208 -- size of the Type_Specific_Data record.
3209
b2e1beb3 3210 if Has_DT then
d0dd5209
JM		 3211 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
3212 end if;
3213
d0dd5209
JM		 3214 Set_Ekind (SSD, E_Constant);
3215 Set_Is_Statically_Allocated (SSD);
3216 Set_Is_True_Constant (SSD);
3217
3218 Set_Ekind (TSD, E_Constant);
3219 Set_Is_Statically_Allocated (TSD);
3220 Set_Is_True_Constant (TSD);
3221
3222 Set_Ekind (Exname, E_Constant);
3223 Set_Is_Statically_Allocated (Exname);
3224 Set_Is_True_Constant (Exname);
3225
3226 -- Generate code to define the boolean that controls registration, in
3227 -- order to avoid multiple registrations for tagged types defined in
3228 -- multiple-called scopes.
3229
3230 if not Is_Interface (Typ) then
b2e1beb3 3231 Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1);
d0dd5209
JM		 3232 No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg);
3233
3234 Set_Ekind (No_Reg, E_Variable);
3235 Set_Is_Statically_Allocated (No_Reg);
3236
3237 Append_To (Result,
3238 Make_Object_Declaration (Loc,
3239 Defining_Identifier => No_Reg,
3240 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
3241 Expression => New_Reference_To (Standard_True, Loc)));
3242 end if;
3243
3244 -- In case of locally defined tagged type we declare the object
3245 -- contanining the dispatch table by means of a variable. Its
3246 -- initialization is done later by means of an assignment. This is
3247 -- required to generate its External_Tag.
3248
b2e1beb3 3249 if not Build_Static_DT then
d0dd5209
JM		 3250
3251 -- Generate:
3252 -- DT : No_Dispatch_Table_Wrapper;
b2e1beb3 3253 -- for DT'Alignment use Address'Alignment;
d0dd5209
JM		 3254 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
3255
b2e1beb3 3256 if not Has_DT then
d0dd5209
JM		 3257 Append_To (Result,
3258 Make_Object_Declaration (Loc,
3259 Defining_Identifier => DT,
3260 Aliased_Present => True,
3261 Constant_Present => False,
3262 Object_Definition =>
3263 New_Reference_To
3264 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
3265
b2e1beb3
ES		 3266 Append_To (Result,
3267 Make_Attribute_Definition_Clause (Loc,
3268 Name => New_Reference_To (DT, Loc),
3269 Chars => Name_Alignment,
3270 Expression =>
3271 Make_Attribute_Reference (Loc,
3272 Prefix =>
3273 New_Reference_To (RTE (RE_Integer_Address), Loc),
3274 Attribute_Name => Name_Alignment)));
3275
d0dd5209
JM		 3276 Append_To (Result,
3277 Make_Object_Declaration (Loc,
3278 Defining_Identifier => DT_Ptr,
3279 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
3280 Constant_Present => True,
3281 Expression =>
3282 Unchecked_Convert_To (Generalized_Tag,
3283 Make_Attribute_Reference (Loc,
3284 Prefix =>
3285 Make_Selected_Component (Loc,
3286 Prefix => New_Reference_To (DT, Loc),
3287 Selector_Name =>
3288 New_Occurrence_Of
3289 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
3290 Attribute_Name => Name_Address))));
3291
3292 -- Generate:
3293 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
3294 -- for DT'Alignment use Address'Alignment;
3295 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
3296
3297 else
3298 -- If the tagged type has no primitives we add a dummy slot
3299 -- whose address will be the tag of this type.
3300
3301 if Nb_Prim = 0 then
3302 DT_Constr_List :=
3303 New_List (Make_Integer_Literal (Loc, 1));
3304 else
3305 DT_Constr_List :=
3306 New_List (Make_Integer_Literal (Loc, Nb_Prim));
3307 end if;
3308
3309 Append_To (Result,
3310 Make_Object_Declaration (Loc,
3311 Defining_Identifier => DT,
3312 Aliased_Present => True,
3313 Constant_Present => False,
3314 Object_Definition =>
3315 Make_Subtype_Indication (Loc,
3316 Subtype_Mark =>
3317 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
3318 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3319 Constraints => DT_Constr_List))));
3320
3321 Append_To (Result,
3322 Make_Attribute_Definition_Clause (Loc,
3323 Name => New_Reference_To (DT, Loc),
3324 Chars => Name_Alignment,
3325 Expression =>
3326 Make_Attribute_Reference (Loc,
3327 Prefix =>
3328 New_Reference_To (RTE (RE_Integer_Address), Loc),
3329 Attribute_Name => Name_Alignment)));
3330
3331 Append_To (Result,
3332 Make_Object_Declaration (Loc,
3333 Defining_Identifier => DT_Ptr,
3334 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
3335 Constant_Present => True,
3336 Expression =>
3337 Unchecked_Convert_To (Generalized_Tag,
3338 Make_Attribute_Reference (Loc,
3339 Prefix =>
3340 Make_Selected_Component (Loc,
3341 Prefix => New_Reference_To (DT, Loc),
3342 Selector_Name =>
3343 New_Occurrence_Of
3344 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
3345 Attribute_Name => Name_Address))));
3346 end if;
3347 end if;
3348
3349 -- Generate: Exname : constant String := full_qualified_name (typ);
dee4682a
JM		 3350 -- The type itself may be an anonymous parent type, so use the first
3351 -- subtype to have a user-recognizable name.
10b93b2e 3352
dee4682a
JM		 3353 Append_To (Result,
3354 Make_Object_Declaration (Loc,
3355 Defining_Identifier => Exname,
3356 Constant_Present => True,
3357 Object_Definition => New_Reference_To (Standard_String, Loc),
3358 Expression =>
3359 Make_String_Literal (Loc,
3360 Full_Qualified_Name (First_Subtype (Typ)))));
10b93b2e 3361
d0dd5209
JM		 3362 -- Generate code to create the storage for the type specific data object
3363 -- with enough space to store the tags of the ancestors plus the tags
3364 -- of all the implemented interfaces (as described in a-tags.adb).
3365
3366 -- TSD : Type_Specific_Data (I_Depth) :=
3367 -- (Idepth => I_Depth,
3368 -- Access_Level => Type_Access_Level (Typ),
3369 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
3370 -- External_Tag => Cstring_Ptr!(Exname'Address))
3371 -- HT_Link => null,
3372 -- Transportable => <<boolean-value>>,
3373 -- RC_Offset => <<integer-value>>,
3374 -- [ Interfaces_Table => <<access-value>> ]
3375 -- [ SSD => SSD_Table'Address ]
3376 -- Tags_Table => (0 => null,
3377 -- 1 => Parent'Tag
3378 -- ...);
3379 -- for TSD'Alignment use Address'Alignment
3380
3381 TSD_Aggr_List := New_List;
3382
3383 -- Idepth: Count ancestors to compute the inheritance depth. For private
3384 -- extensions, always go to the full view in order to compute the real
3385 -- inheritance depth.
3386
3387 declare
3388 Current_Typ : Entity_Id;
3389 Parent_Typ : Entity_Id;
3390
3391 begin
3392 I_Depth := 0;
3393 Current_Typ := Typ;
3394 loop
3395 Parent_Typ := Etype (Current_Typ);
3396
3397 if Is_Private_Type (Parent_Typ) then
3398 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3399 end if;
3400
3401 exit when Parent_Typ = Current_Typ;
3402
3403 I_Depth := I_Depth + 1;
3404 Current_Typ := Parent_Typ;
3405 end loop;
3406 end;
3407
3408 Append_To (TSD_Aggr_List,
b2e1beb3 3409 Make_Integer_Literal (Loc, I_Depth));
d0dd5209
JM		 3410
3411 -- Access_Level
3412
3413 Append_To (TSD_Aggr_List,
b2e1beb3 3414 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
d0dd5209
JM		 3415
3416 -- Expanded_Name
3417
3418 Append_To (TSD_Aggr_List,
b2e1beb3
ES		 3419 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3420 Make_Attribute_Reference (Loc,
3421 Prefix => New_Reference_To (Exname, Loc),
3422 Attribute_Name => Name_Address)));
d0dd5209
JM		 3423
3424 -- External_Tag of a local tagged type
3425
b2e1beb3 3426 -- <typ>A : constant String :=
d0dd5209
JM		 3427 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
3428
3429 -- The reason we generate this strange name is that we do not want to
3430 -- enter local tagged types in the global hash table used to compute
3431 -- the Internal_Tag attribute for two reasons:
3432
3433 -- 1. It is hard to avoid a tasking race condition for entering the
3434 -- entry into the hash table.
3435
3436 -- 2. It would cause a storage leak, unless we rig up considerable
3437 -- mechanism to remove the entry from the hash table on exit.
3438
3439 -- So what we do is to generate the above external tag name, where the
3440 -- hex address is the address of the local dispatch table (i.e. exactly
3441 -- the value we want if Internal_Tag is computed from this string).
3442
3443 -- Of course this value will only be valid if the tagged type is still
3444 -- in scope, but it clearly must be erroneous to compute the internal
3445 -- tag of a tagged type that is out of scope!
3446
b2e1beb3
ES		 3447 -- We don't do this processing if an explicit external tag has been
3448 -- specified. That's an odd case for which we have already issued a
3449 -- warning, where we will not be able to compute the internal tag.
3450
3451 if not Is_Library_Level_Entity (Typ)
3452 and then not Has_External_Tag_Rep_Clause (Typ)
3453 then
d0dd5209 3454 declare
d0dd5209 3455 Exname : constant Entity_Id :=
b2e1beb3
ES		 3456 Make_Defining_Identifier (Loc,
3457 New_External_Name (Tname, 'A'));
3458
d0dd5209
JM		 3459 Full_Name : constant String_Id :=
3460 Full_Qualified_Name (First_Subtype (Typ));
3461 Str1_Id : String_Id;
3462 Str2_Id : String_Id;
d0dd5209
JM		 3463
3464 begin
3465 -- Generate:
b2e1beb3 3466 -- Str1 = "Internal tag at 16#";
d0dd5209
JM		 3467
3468 Start_String;
3469 Store_String_Chars ("Internal tag at 16#");
3470 Str1_Id := End_String;
3471
3472 -- Generate:
b2e1beb3 3473 -- Str2 = "#: <type-full-name>";
d0dd5209
JM		 3474
3475 Start_String;
3476 Store_String_Chars ("#: ");
d0dd5209 3477 Store_String_Chars (Full_Name);
b2e1beb3 3478 Str2_Id := End_String;
d0dd5209
JM		 3479
3480 -- Generate:
3481 -- Exname : constant String :=
b2e1beb3 3482 -- Str1 & Address_Image (Tag) & Str2;
d0dd5209
JM		 3483
3484 if RTE_Available (RE_Address_Image) then
3485 Append_To (Result,
3486 Make_Object_Declaration (Loc,
3487 Defining_Identifier => Exname,
3488 Constant_Present => True,
3489 Object_Definition => New_Reference_To
3490 (Standard_String, Loc),
3491 Expression =>
3492 Make_Op_Concat (Loc,
3493 Left_Opnd =>
3494 Make_String_Literal (Loc, Str1_Id),
3495 Right_Opnd =>
3496 Make_Op_Concat (Loc,
3497 Left_Opnd =>
3498 Make_Function_Call (Loc,
3499 Name =>
3500 New_Reference_To
3501 (RTE (RE_Address_Image), Loc),
3502 Parameter_Associations => New_List (
3503 Unchecked_Convert_To (RTE (RE_Address),
3504 New_Reference_To (DT_Ptr, Loc)))),
3505 Right_Opnd =>
b2e1beb3
ES		 3506 Make_String_Literal (Loc, Str2_Id)))));
3507
d0dd5209
JM		 3508 else
3509 Append_To (Result,
3510 Make_Object_Declaration (Loc,
3511 Defining_Identifier => Exname,
3512 Constant_Present => True,
3513 Object_Definition => New_Reference_To
3514 (Standard_String, Loc),
3515 Expression =>
3516 Make_Op_Concat (Loc,
3517 Left_Opnd =>
3518 Make_String_Literal (Loc, Str1_Id),
3519 Right_Opnd =>
b2e1beb3 3520 Make_String_Literal (Loc, Str2_Id))));
d0dd5209
JM		 3521 end if;
3522
3523 New_Node :=
3524 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3525 Make_Attribute_Reference (Loc,
3526 Prefix => New_Reference_To (Exname, Loc),
3527 Attribute_Name => Name_Address));
3528 end;
3529
3530 -- External tag of a library-level tagged type: Check for a definition
3531 -- of External_Tag. The clause is considered only if it applies to this
3532 -- specific tagged type, as opposed to one of its ancestors.
3533
3534 else
3535 declare
3536 Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ,
3537 Attribute_External_Tag);
3538 Old_Val : String_Id;
3539 New_Val : String_Id;
3540 E : Entity_Id;
3541
3542 begin
3543 if not Present (Def)
3544 or else Entity (Name (Def)) /= Typ
3545 then
3546 New_Node :=
3547 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3548 Make_Attribute_Reference (Loc,
3549 Prefix => New_Reference_To (Exname, Loc),
3550 Attribute_Name => Name_Address));
3551 else
3552 Old_Val := Strval (Expr_Value_S (Expression (Def)));
3553
b2e1beb3 3554 -- For the rep clause "for <typ>'external_tag use y" generate:
d0dd5209 3555
b2e1beb3
ES		 3556 -- <typ>A : constant string := y;
3557 --
3558 -- <typ>A'Address is used to set the External_Tag component
3559 -- of the TSD
d0dd5209
JM		 3560
3561 -- Create a new nul terminated string if it is not already
3562
3563 if String_Length (Old_Val) > 0
3564 and then
3565 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
3566 then
3567 New_Val := Old_Val;
3568 else
3569 Start_String (Old_Val);
3570 Store_String_Char (Get_Char_Code (ASCII.NUL));
3571 New_Val := End_String;
3572 end if;
3573
3574 E := Make_Defining_Identifier (Loc,
3575 New_External_Name (Chars (Typ), 'A'));
3576
3577 Append_To (Result,
3578 Make_Object_Declaration (Loc,
3579 Defining_Identifier => E,
3580 Constant_Present => True,
3581 Object_Definition =>
3582 New_Reference_To (Standard_String, Loc),
3583 Expression =>
3584 Make_String_Literal (Loc, New_Val)));
3585
3586 New_Node :=
3587 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3588 Make_Attribute_Reference (Loc,
3589 Prefix => New_Reference_To (E, Loc),
3590 Attribute_Name => Name_Address));
3591 end if;
3592 end;
3593 end if;
3594
b2e1beb3 3595 Append_To (TSD_Aggr_List, New_Node);
d0dd5209
JM		 3596
3597 -- HT_Link
3598
3599 Append_To (TSD_Aggr_List,
b2e1beb3
ES		 3600 Unchecked_Convert_To (RTE (RE_Tag),
3601 New_Reference_To (RTE (RE_Null_Address), Loc)));
d0dd5209
JM		 3602
3603 -- Transportable: Set for types that can be used in remote calls
3604 -- with respect to E.4(18) legality rules.
3605
b2e1beb3
ES		 3606 declare
3607 Transportable : Entity_Id;
d0dd5209 3608
b2e1beb3
ES		 3609 begin
3610 Transportable :=
3611 Boolean_Literals
3612 (Is_Pure (Typ)
3613 or else Is_Shared_Passive (Typ)
3614 or else
3615 ((Is_Remote_Types (Typ)
3616 or else Is_Remote_Call_Interface (Typ))
3617 and then Original_View_In_Visible_Part (Typ))
3618 or else not Comes_From_Source (Typ));
3619
3620 Append_To (TSD_Aggr_List,
3621 New_Occurrence_Of (Transportable, Loc));
3622 end;
d0dd5209
JM		 3623
3624 -- RC_Offset: These are the valid values and their meaning:
3625
dee4682a
JM		 3626 -- >0: For simple types with controlled components is
3627 -- type._record_controller'position
d0dd5209 3628
dee4682a 3629 -- 0: For types with no controlled components
d0dd5209 3630
dee4682a
JM		 3631 -- -1: For complex types with controlled components where the position
3632 -- of the record controller is not statically computable but there
3633 -- are controlled components at this level. The _Controller field
3634 -- is available right after the _parent.
d0dd5209 3635
dee4682a
JM		 3636 -- -2: There are no controlled components at this level. We need to
3637 -- get the position from the parent.
4d744221 3638
b2e1beb3
ES		 3639 declare
3640 RC_Offset_Node : Node_Id;
dee4682a 3641
b2e1beb3
ES		 3642 begin
3643 if not Has_Controlled_Component (Typ) then
3644 RC_Offset_Node := Make_Integer_Literal (Loc, 0);
3645
3646 elsif Etype (Typ) /= Typ
3647 and then Has_Discriminants (Etype (Typ))
3648 then
3649 if Has_New_Controlled_Component (Typ) then
3650 RC_Offset_Node := Make_Integer_Literal (Loc, -1);
3651 else
3652 RC_Offset_Node := Make_Integer_Literal (Loc, -2);
3653 end if;
dee4682a 3654 else
b2e1beb3
ES		 3655 RC_Offset_Node :=
3656 Make_Attribute_Reference (Loc,
3657 Prefix =>
3658 Make_Selected_Component (Loc,
3659 Prefix => New_Reference_To (Typ, Loc),
3660 Selector_Name =>
3661 New_Reference_To (Controller_Component (Typ), Loc)),
3662 Attribute_Name => Name_Position);
3663
3664 -- This is not proper Ada code to use the attribute 'Position
3665 -- on something else than an object but this is supported by
3666 -- the back end (see comment on the Bit_Component attribute in
3667 -- sem_attr). So we avoid semantic checking here.
3668
3669 -- Is this documented in sinfo.ads??? it should be!
3670
3671 Set_Analyzed (RC_Offset_Node);
3672 Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
3673 Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
3674 Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
3675 RTE (RE_Record_Controller));
3676 Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
b0efe69e 3677 end if;
4d744221 3678
b2e1beb3
ES		 3679 Append_To (TSD_Aggr_List, RC_Offset_Node);
3680 end;
d0dd5209
JM		 3681
3682 -- Interfaces_Table (required for AI-405)
3683
3684 if RTE_Record_Component_Available (RE_Interfaces_Table) then
3685
3686 -- Count the number of interface types implemented by Typ
3687
3688 Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
3689
3690 AI := First_Elmt (Typ_Ifaces);
3691 while Present (AI) loop
3692 Num_Ifaces := Num_Ifaces + 1;
3693 Next_Elmt (AI);
3694 end loop;
4d744221 3695
dee4682a 3696 if Num_Ifaces = 0 then
d0dd5209 3697 Iface_Table_Node := Make_Null (Loc);
4d744221 3698
d0dd5209 3699 -- Generate the Interface_Table object
dee4682a
JM		 3700
3701 else
d0dd5209 3702 declare
b2e1beb3 3703 TSD_Ifaces_List : constant List_Id := New_List;
d0dd5209
JM		 3704
3705 begin
3706 AI := First_Elmt (Typ_Ifaces);
3707 while Present (AI) loop
b2e1beb3
ES		 3708 Append_To (TSD_Ifaces_List,
3709 Make_Aggregate (Loc,
3710 Expressions => New_List (
3711
3712 -- Iface_Tag
3713
d0dd5209
JM		 3714 Unchecked_Convert_To (Generalized_Tag,
3715 New_Reference_To
3716 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
b2e1beb3 3717 Loc)),
d0dd5209 3718
b2e1beb3 3719 -- Static_Offset_To_Top
d0dd5209 3720
b2e1beb3 3721 New_Reference_To (Standard_True, Loc),
d0dd5209 3722
b2e1beb3
ES		 3723 -- Offset_To_Top_Value
3724
3725 Make_Integer_Literal (Loc, 0),
3726
3727 -- Offset_To_Top_Func
3728
3729 Make_Null (Loc))));
d0dd5209 3730
d0dd5209
JM		 3731 Next_Elmt (AI);
3732 end loop;
d0dd5209 3733
b2e1beb3
ES		 3734 Name_ITable := New_External_Name (Tname, 'I');
3735 ITable := Make_Defining_Identifier (Loc, Name_ITable);
3736 Set_Is_Statically_Allocated (ITable);
d0dd5209 3737
b2e1beb3
ES		 3738 -- The table of interfaces is not constant; its slots are
3739 -- filled at run-time by the IP routine using attribute
3740 -- 'Position to know the location of the tag components
3741 -- (and this attribute cannot be safely used before the
3742 -- object is initialized).
d0dd5209 3743
b2e1beb3
ES		 3744 Append_To (Result,
3745 Make_Object_Declaration (Loc,
3746 Defining_Identifier => ITable,
3747 Aliased_Present => True,
3748 Constant_Present => False,
3749 Object_Definition =>
3750 Make_Subtype_Indication (Loc,
3751 Subtype_Mark =>
3752 New_Reference_To (RTE (RE_Interface_Data), Loc),
3753 Constraint => Make_Index_Or_Discriminant_Constraint
3754 (Loc,
3755 Constraints => New_List (
3756 Make_Integer_Literal (Loc, Num_Ifaces)))),
d0dd5209 3757
b2e1beb3
ES		 3758 Expression => Make_Aggregate (Loc,
3759 Expressions => New_List (
3760 Make_Integer_Literal (Loc, Num_Ifaces),
3761 Make_Aggregate (Loc,
3762 Expressions => TSD_Ifaces_List)))));
d0dd5209 3763
b2e1beb3
ES		 3764 Append_To (Result,
3765 Make_Attribute_Definition_Clause (Loc,
3766 Name => New_Reference_To (ITable, Loc),
3767 Chars => Name_Alignment,
3768 Expression =>
3769 Make_Attribute_Reference (Loc,
3770 Prefix =>
3771 New_Reference_To (RTE (RE_Integer_Address), Loc),
3772 Attribute_Name => Name_Alignment)));
d0dd5209 3773
b2e1beb3
ES		 3774 Iface_Table_Node :=
3775 Make_Attribute_Reference (Loc,
3776 Prefix => New_Reference_To (ITable, Loc),
3777 Attribute_Name => Name_Unchecked_Access);
3778 end;
d0dd5209
JM		 3779 end if;
3780
b2e1beb3 3781 Append_To (TSD_Aggr_List, Iface_Table_Node);
d0dd5209
JM		 3782 end if;
3783
3784 -- Generate the Select Specific Data table for synchronized types that
3785 -- implement synchronized interfaces. The size of the table is
3786 -- constrained by the number of non-predefined primitive operations.
3787
3788 if RTE_Record_Component_Available (RE_SSD) then
3789 if Ada_Version >= Ada_05
b2e1beb3 3790 and then Has_DT
d0dd5209
JM		 3791 and then Is_Concurrent_Record_Type (Typ)
3792 and then Has_Abstract_Interfaces (Typ)
3793 and then Nb_Prim > 0
3794 and then not Is_Abstract_Type (Typ)
3795 and then not Is_Controlled (Typ)
3796 and then not Restriction_Active (No_Dispatching_Calls)
3797 then
dee4682a
JM		 3798 Append_To (Result,
3799 Make_Object_Declaration (Loc,
d0dd5209 3800 Defining_Identifier => SSD,
dee4682a
JM		 3801 Aliased_Present => True,
3802 Object_Definition =>
3803 Make_Subtype_Indication (Loc,
d0dd5209
JM		 3804 Subtype_Mark => New_Reference_To (
3805 RTE (RE_Select_Specific_Data), Loc),
3806 Constraint =>
3807 Make_Index_Or_Discriminant_Constraint (Loc,
3808 Constraints => New_List (
3809 Make_Integer_Literal (Loc, Nb_Prim))))));
3810
b2e1beb3
ES		 3811 Append_To (Result,
3812 Make_Attribute_Definition_Clause (Loc,
3813 Name => New_Reference_To (SSD, Loc),
3814 Chars => Name_Alignment,
3815 Expression =>
3816 Make_Attribute_Reference (Loc,
3817 Prefix =>
3818 New_Reference_To (RTE (RE_Integer_Address), Loc),
3819 Attribute_Name => Name_Alignment)));
3820
d0dd5209
JM		 3821 -- This table is initialized by Make_Select_Specific_Data_Table,
3822 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
3823
3824 Append_To (TSD_Aggr_List,
b2e1beb3
ES		 3825 Make_Attribute_Reference (Loc,
3826 Prefix => New_Reference_To (SSD, Loc),
3827 Attribute_Name => Name_Unchecked_Access));
d0dd5209 3828 else
b2e1beb3 3829 Append_To (TSD_Aggr_List, Make_Null (Loc));
dee4682a 3830 end if;
4d744221
JM		 3831 end if;
3832
d0dd5209
JM		 3833 -- Initialize the table of ancestor tags. In case of interface types
3834 -- this table is not needed.
10b93b2e 3835
b2e1beb3
ES		 3836 declare
3837 Current_Typ : Entity_Id;
3838 Parent_Typ : Entity_Id;
3839 Pos : Nat;
4d744221 3840
b2e1beb3
ES		 3841 begin
3842 TSD_Tags_List := New_List;
dee4682a 3843
b2e1beb3
ES		 3844 -- If we are not statically allocating the dispatch table then we
3845 -- must fill position 0 with null because we still have not
3846 -- generated the tag of Typ.
dee4682a 3847
b2e1beb3
ES		 3848 if not Build_Static_DT
3849 or else Is_Interface (Typ)
3850 then
d0dd5209 3851 Append_To (TSD_Tags_List,
b2e1beb3
ES		 3852 Unchecked_Convert_To (RTE (RE_Tag),
3853 New_Reference_To (RTE (RE_Null_Address), Loc)));
dee4682a 3854
b2e1beb3
ES		 3855 -- Otherwise we can safely import the tag. The name must be unique
3856 -- over the compilation unit, to avoid conflicts when types of the
3857 -- same name appear in different nested packages. We don't need to
3858 -- use an external name because this name is only locally used.
dee4682a 3859
b2e1beb3
ES		 3860 else
3861 declare
3862 Imported_DT_Ptr : constant Entity_Id :=
3863 Make_Defining_Identifier (Loc,
3864 Chars => New_Internal_Name ('D'));
d0dd5209 3865
b2e1beb3
ES		 3866 begin
3867 Set_Is_Imported (Imported_DT_Ptr);
3868 Set_Is_Statically_Allocated (Imported_DT_Ptr);
3869 Set_Is_True_Constant (Imported_DT_Ptr);
3870 Get_External_Name
3871 (Node (First_Elmt (Access_Disp_Table (Typ))), True);
3872 Set_Interface_Name (Imported_DT_Ptr,
3873 Make_String_Literal (Loc, String_From_Name_Buffer));
dee4682a 3874
b2e1beb3
ES		 3875 -- Set tag as internal to ensure proper Sprint output of its
3876 -- implicit importation.
dee4682a 3877
b2e1beb3 3878 Set_Is_Internal (Imported_DT_Ptr);
dee4682a 3879
b2e1beb3
ES		 3880 Append_To (Result,
3881 Make_Object_Declaration (Loc,
3882 Defining_Identifier => Imported_DT_Ptr,
3883 Constant_Present => True,
3884 Object_Definition => New_Reference_To (RTE (RE_Tag),
3885 Loc)));
dee4682a 3886
b2e1beb3
ES		 3887 Append_To (TSD_Tags_List,
3888 New_Reference_To (Imported_DT_Ptr, Loc));
3889 end;
3890 end if;
dee4682a 3891
b2e1beb3 3892 -- Fill the rest of the table with the tags of the ancestors
d0dd5209 3893
b2e1beb3
ES		 3894 Pos := 1;
3895 Current_Typ := Typ;
d0dd5209 3896
b2e1beb3
ES		 3897 loop
3898 Parent_Typ := Etype (Current_Typ);
dee4682a 3899
b2e1beb3
ES		 3900 if Is_Private_Type (Parent_Typ) then
3901 Parent_Typ := Full_View (Base_Type (Parent_Typ));
3902 end if;
3903
3904 exit when Parent_Typ = Current_Typ;
3905
3906 if Is_CPP_Class (Parent_Typ)
3907 or else Is_Interface (Typ)
3908 then
3909 -- The tags defined in the C++ side will be inherited when
3910 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
3911
3912 Append_To (TSD_Tags_List,
3913 Unchecked_Convert_To (RTE (RE_Tag),
3914 New_Reference_To (RTE (RE_Null_Address), Loc)));
3915 else
3916 Append_To (TSD_Tags_List,
3917 New_Reference_To
3918 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
3919 Loc));
3920 end if;
3921
3922 Pos := Pos + 1;
3923 Current_Typ := Parent_Typ;
3924 end loop;
3925
3926 pragma Assert (Pos = I_Depth + 1);
3927 end;
3928
3929 Append_To (TSD_Aggr_List,
3930 Make_Aggregate (Loc,
3931 Expressions => TSD_Tags_List));
dee4682a 3932
d0dd5209 3933 -- Build the TSD object
dee4682a
JM		 3934
3935 Append_To (Result,
3936 Make_Object_Declaration (Loc,
3937 Defining_Identifier => TSD,
3938 Aliased_Present => True,
b2e1beb3 3939 Constant_Present => Build_Static_DT,
dee4682a
JM		 3940 Object_Definition =>
3941 Make_Subtype_Indication (Loc,
3942 Subtype_Mark => New_Reference_To (
3943 RTE (RE_Type_Specific_Data), Loc),
3944 Constraint =>
3945 Make_Index_Or_Discriminant_Constraint (Loc,
3946 Constraints => New_List (
3947 Make_Integer_Literal (Loc, I_Depth)))),
d0dd5209 3948
dee4682a 3949 Expression => Make_Aggregate (Loc,
b2e1beb3 3950 Expressions => TSD_Aggr_List)));
dee4682a
JM		 3951
3952 Append_To (Result,
3953 Make_Attribute_Definition_Clause (Loc,
3954 Name => New_Reference_To (TSD, Loc),
3955 Chars => Name_Alignment,
3956 Expression =>
3957 Make_Attribute_Reference (Loc,
3958 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
3959 Attribute_Name => Name_Alignment)));
3960
d0dd5209
JM		 3961 -- Generate the dummy Dispatch_Table object associated with tagged
3962 -- types that have no dispatch table.
dee4682a 3963
d0dd5209
JM		 3964 -- DT : No_Dispatch_Table :=
3965 -- (NDT_TSD => TSD'Address;
3966 -- NDT_Prims_Ptr => 0);
b2e1beb3 3967 -- for DT'Alignment use Address'Alignment
dee4682a 3968
b2e1beb3 3969 if not Has_DT then
d0dd5209
JM		 3970 DT_Constr_List := New_List;
3971 DT_Aggr_List := New_List;
dee4682a 3972
d0dd5209 3973 -- Typeinfo
4d744221 3974
d0dd5209
JM		 3975 New_Node :=
3976 Make_Attribute_Reference (Loc,
3977 Prefix => New_Reference_To (TSD, Loc),
3978 Attribute_Name => Name_Address);
3979
3980 Append_To (DT_Constr_List, New_Node);
3981 Append_To (DT_Aggr_List, New_Copy (New_Node));
3982 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
3983
3984 -- In case of locally defined tagged types we have already declared
3985 -- and uninitialized object for the dispatch table, which is now
3986 -- initialized by means of an assignment.
3987
b2e1beb3 3988 if not Build_Static_DT then
d0dd5209
JM		 3989 Append_To (Result,
3990 Make_Assignment_Statement (Loc,
3991 Name => New_Reference_To (DT, Loc),
3992 Expression => Make_Aggregate (Loc,
3993 Expressions => DT_Aggr_List)));
3994
3995 -- In case of library level tagged types we declare now the constant
3996 -- object containing the dispatch table.
3997
3998 else
3999 Append_To (Result,
4000 Make_Object_Declaration (Loc,
4001 Defining_Identifier => DT,
4002 Aliased_Present => True,
b2e1beb3 4003 Constant_Present => True,
d0dd5209
JM		 4004 Object_Definition =>
4005 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
4006 Expression => Make_Aggregate (Loc,
4007 Expressions => DT_Aggr_List)));
4008
b2e1beb3
ES		 4009 Append_To (Result,
4010 Make_Attribute_Definition_Clause (Loc,
4011 Name => New_Reference_To (DT, Loc),
4012 Chars => Name_Alignment,
4013 Expression =>
4014 Make_Attribute_Reference (Loc,
4015 Prefix =>
4016 New_Reference_To (RTE (RE_Integer_Address), Loc),
4017 Attribute_Name => Name_Alignment)));
4018
d0dd5209
JM		 4019 Append_To (Result,
4020 Make_Object_Declaration (Loc,
4021 Defining_Identifier => DT_Ptr,
4022 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4023 Constant_Present => True,
4024 Expression =>
4025 Unchecked_Convert_To (Generalized_Tag,
4026 Make_Attribute_Reference (Loc,
4027 Prefix =>
4028 Make_Selected_Component (Loc,
4029 Prefix => New_Reference_To (DT, Loc),
4030 Selector_Name =>
4031 New_Occurrence_Of
4032 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4033 Attribute_Name => Name_Address))));
4034 end if;
4035
4036 -- Common case: Typ has a dispatch table
4037
4038 -- Generate:
4039
4040 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4041 -- (predef-prim-op-1'address,
4042 -- predef-prim-op-2'address,
4043 -- ...
4044 -- predef-prim-op-n'address);
4045 -- for Predef_Prims'Alignment use Address'Alignment
4046
4047 -- DT : Dispatch_Table (Nb_Prims) :=
4048 -- (Signature => <sig-value>,
4049 -- Tag_Kind => <tag_kind-value>,
4050 -- Predef_Prims => Predef_Prims'First'Address,
4051 -- Offset_To_Top => 0,
4052 -- TSD => TSD'Address;
4053 -- Prims_Ptr => (prim-op-1'address,
4054 -- prim-op-2'address,
4055 -- ...
4056 -- prim-op-n'address));
b2e1beb3 4057 -- for DT'Alignment use Address'Alignment
d0dd5209
JM		 4058
4059 else
4060 declare
4061 Pos : Nat;
4062
4063 begin
b2e1beb3 4064 if not Build_Static_DT then
d0dd5209
JM		 4065 Nb_Predef_Prims := Max_Predef_Prims;
4066
4067 else
4068 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4069 while Present (Prim_Elmt) loop
4070 Prim := Node (Prim_Elmt);
4071
4072 if Is_Predefined_Dispatching_Operation (Prim)
4073 and then not Is_Abstract_Subprogram (Prim)
4074 then
4075 Pos := UI_To_Int (DT_Position (Prim));
4076
4077 if Pos > Nb_Predef_Prims then
4078 Nb_Predef_Prims := Pos;
4079 end if;
4080 end if;
4081
4082 Next_Elmt (Prim_Elmt);
4083 end loop;
4084 end if;
4085
4086 declare
4087 Prim_Table : array
4088 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4089 E : Entity_Id;
4090
4091 begin
4092 Prim_Ops_Aggr_List := New_List;
4093
4094 Prim_Table := (others => Empty);
b2e1beb3 4095
d0dd5209
JM		 4096 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4097 while Present (Prim_Elmt) loop
4098 Prim := Node (Prim_Elmt);
4099
b2e1beb3 4100 if Build_Static_DT
d0dd5209
JM		 4101 and then Is_Predefined_Dispatching_Operation (Prim)
4102 and then not Is_Abstract_Subprogram (Prim)
4103 and then not Present (Prim_Table
4104 (UI_To_Int (DT_Position (Prim))))
4105 then
4106 E := Prim;
4107 while Present (Alias (E)) loop
4108 E := Alias (E);
4109 end loop;
4110
4111 pragma Assert (not Is_Abstract_Subprogram (E));
4112 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
4113 end if;
4114
4115 Next_Elmt (Prim_Elmt);
4116 end loop;
4117
4118 for J in Prim_Table'Range loop
4119 if Present (Prim_Table (J)) then
4120 New_Node :=
4121 Make_Attribute_Reference (Loc,
4122 Prefix => New_Reference_To (Prim_Table (J), Loc),
4123 Attribute_Name => Name_Address);
4124 else
4125 New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
4126 end if;
4127
4128 Append_To (Prim_Ops_Aggr_List, New_Node);
4129 end loop;
dee4682a 4130
b0efe69e
JM		 4131 Append_To (Result,
4132 Make_Object_Declaration (Loc,
d0dd5209 4133 Defining_Identifier => Predef_Prims,
b0efe69e 4134 Aliased_Present => True,
b2e1beb3 4135 Constant_Present => Build_Static_DT,
b0efe69e 4136 Object_Definition =>
d0dd5209
JM		 4137 New_Reference_To (RTE (RE_Address_Array), Loc),
4138 Expression => Make_Aggregate (Loc,
4139 Expressions => Prim_Ops_Aggr_List)));
4140
4141 Append_To (Result,
4142 Make_Attribute_Definition_Clause (Loc,
4143 Name => New_Reference_To (Predef_Prims, Loc),
4144 Chars => Name_Alignment,
4145 Expression =>
4146 Make_Attribute_Reference (Loc,
4147 Prefix =>
4148 New_Reference_To (RTE (RE_Integer_Address), Loc),
4149 Attribute_Name => Name_Alignment)));
4150 end;
4151 end;
4152
4153 -- Stage 1: Initialize the discriminant and the record components
4154
4155 DT_Constr_List := New_List;
4156 DT_Aggr_List := New_List;
4157
4158 -- Num_Prims. If the tagged type has no primitives we add a dummy
4159 -- slot whose address will be the tag of this type.
4160
4161 if Nb_Prim = 0 then
4162 New_Node := Make_Integer_Literal (Loc, 1);
4163 else
4164 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
4165 end if;
4166
4167 Append_To (DT_Constr_List, New_Node);
4168 Append_To (DT_Aggr_List, New_Copy (New_Node));
4169
4170 -- Signature
4171
4172 if RTE_Record_Component_Available (RE_Signature) then
4173 Append_To (DT_Aggr_List,
4174 New_Reference_To (RTE (RE_Primary_DT), Loc));
4175 end if;
4176
4177 -- Tag_Kind
4178
4179 if RTE_Record_Component_Available (RE_Tag_Kind) then
4180 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4181 end if;
4182
4183 -- Predef_Prims
4184
4185 Append_To (DT_Aggr_List,
4186 Make_Attribute_Reference (Loc,
4187 Prefix => New_Reference_To (Predef_Prims, Loc),
4188 Attribute_Name => Name_Address));
4189
4190 -- Offset_To_Top
4191
4192 if RTE_Record_Component_Available (RE_Offset_To_Top) then
4193 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4194 end if;
4195
4196 -- Typeinfo
4197
4198 Append_To (DT_Aggr_List,
4199 Make_Attribute_Reference (Loc,
4200 Prefix => New_Reference_To (TSD, Loc),
4201 Attribute_Name => Name_Address));
4202
4203 -- Stage 2: Initialize the table of primitive operations
4204
4205 Prim_Ops_Aggr_List := New_List;
4206
4207 if Nb_Prim = 0 then
4208 Append_To (Prim_Ops_Aggr_List,
4209 New_Reference_To (RTE (RE_Null_Address), Loc));
4210
b2e1beb3 4211 elsif not Build_Static_DT then
d0dd5209
JM		 4212 for J in 1 .. Nb_Prim loop
4213 Append_To (Prim_Ops_Aggr_List,
4214 New_Reference_To (RTE (RE_Null_Address), Loc));
4215 end loop;
4216
4217 else
4218 declare
4219 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4220 E : Entity_Id;
4221 Prim : Entity_Id;
4222 Prim_Elmt : Elmt_Id;
4223
4224 begin
4225 Prim_Table := (others => Empty);
4226 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4227 while Present (Prim_Elmt) loop
4228 Prim := Node (Prim_Elmt);
4229
4230 if Is_Imported (Prim)
4231 or else Present (Abstract_Interface_Alias (Prim))
4232 or else Is_Predefined_Dispatching_Operation (Prim)
4233 then
4234 null;
4235
4236 else
4237 -- Traverse the list of aliased entities to handle
4238 -- renamings of predefined primitives.
4239
4240 E := Prim;
4241 while Present (Alias (E)) loop
4242 E := Alias (E);
4243 end loop;
4244
4245 if not Is_Predefined_Dispatching_Operation (E)
4246 and then not Is_Abstract_Subprogram (E)
4247 and then not Present (Abstract_Interface_Alias (E))
4248 then
4249 pragma Assert
4250 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
4251
4252 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
d0dd5209
JM		 4253 end if;
4254 end if;
4255
4256 Next_Elmt (Prim_Elmt);
4257 end loop;
4258
4259 for J in Prim_Table'Range loop
4260 if Present (Prim_Table (J)) then
4261 New_Node :=
4262 Make_Attribute_Reference (Loc,
4263 Prefix => New_Reference_To (Prim_Table (J), Loc),
4264 Attribute_Name => Name_Address);
4265 else
4266 New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
4267 end if;
4268
4269 Append_To (Prim_Ops_Aggr_List, New_Node);
4270 end loop;
4271 end;
4272 end if;
4273
4274 Append_To (DT_Aggr_List,
4275 Make_Aggregate (Loc,
4276 Expressions => Prim_Ops_Aggr_List));
4277
4278 -- In case of locally defined tagged types we have already declared
4279 -- and uninitialized object for the dispatch table, which is now
4280 -- initialized by means of an assignment.
4281
b2e1beb3 4282 if not Build_Static_DT then
d0dd5209
JM		 4283 Append_To (Result,
4284 Make_Assignment_Statement (Loc,
4285 Name => New_Reference_To (DT, Loc),
4286 Expression => Make_Aggregate (Loc,
4287 Expressions => DT_Aggr_List)));
4288
4289 -- In case of library level tagged types we declare now the constant
4290 -- object containing the dispatch table.
4291
4292 else
4293 Append_To (Result,
4294 Make_Object_Declaration (Loc,
4295 Defining_Identifier => DT,
4296 Aliased_Present => True,
b2e1beb3 4297 Constant_Present => True,
d0dd5209
JM		 4298 Object_Definition =>
4299 Make_Subtype_Indication (Loc,
4300 Subtype_Mark => New_Reference_To
4301 (RTE (RE_Dispatch_Table_Wrapper), Loc),
4302 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4303 Constraints => DT_Constr_List)),
4304 Expression => Make_Aggregate (Loc,
4305 Expressions => DT_Aggr_List)));
4306
4307 Append_To (Result,
4308 Make_Attribute_Definition_Clause (Loc,
4309 Name => New_Reference_To (DT, Loc),
4310 Chars => Name_Alignment,
4311 Expression =>
4312 Make_Attribute_Reference (Loc,
4313 Prefix =>
4314 New_Reference_To (RTE (RE_Integer_Address), Loc),
4315 Attribute_Name => Name_Alignment)));
4316
4317 Append_To (Result,
4318 Make_Object_Declaration (Loc,
4319 Defining_Identifier => DT_Ptr,
4320 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4321 Constant_Present => True,
4322 Expression =>
4323 Unchecked_Convert_To (Generalized_Tag,
4324 Make_Attribute_Reference (Loc,
4325 Prefix =>
4326 Make_Selected_Component (Loc,
4327 Prefix => New_Reference_To (DT, Loc),
4328 Selector_Name =>
4329 New_Occurrence_Of
4330 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4331 Attribute_Name => Name_Address))));
4d744221 4332 end if;
f4d379b8 4333 end if;
10b93b2e 4334
d0dd5209
JM		 4335 -- Initialize the table of ancestor tags
4336
b2e1beb3
ES		 4337 if not Build_Static_DT
4338 and then not Is_Interface (Typ)
d0dd5209
JM		 4339 and then not Is_CPP_Class (Typ)
4340 then
4341 Append_To (Result,
4342 Make_Assignment_Statement (Loc,
4343 Name =>
4344 Make_Indexed_Component (Loc,
4345 Prefix =>
4346 Make_Selected_Component (Loc,
4347 Prefix =>
4348 New_Reference_To (TSD, Loc),
4349 Selector_Name =>
4350 New_Reference_To
4351 (RTE_Record_Component (RE_Tags_Table), Loc)),
4352 Expressions =>
4353 New_List (Make_Integer_Literal (Loc, 0))),
4354
4355 Expression =>
4356 New_Reference_To
4357 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
4358 end if;
4359
b2e1beb3 4360 if Build_Static_DT then
d0dd5209
JM		 4361 null;
4362
bfef8d0d
JM		 4363 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
4364 -- in the init proc, and we don't need to fill them in here.
10b93b2e 4365
d0dd5209 4366 elsif Is_CPP_Class (Etype (Typ)) then
bfef8d0d 4367 null;
10b93b2e 4368
bfef8d0d 4369 -- Otherwise we fill in the dispatch tables here
10b93b2e 4370
bfef8d0d
JM		 4371 else
4372 if Typ = Etype (Typ)
4373 or else Is_CPP_Class (Etype (Typ))
4374 or else Is_Interface (Typ)
4375 then
dee4682a
JM		 4376 Null_Parent_Tag := True;
4377
bfef8d0d
JM		 4378 Old_Tag1 :=
4379 Unchecked_Convert_To (Generalized_Tag,
4380 Make_Integer_Literal (Loc, 0));
4381 Old_Tag2 :=
4382 Unchecked_Convert_To (Generalized_Tag,
4383 Make_Integer_Literal (Loc, 0));
10b93b2e 4384
bfef8d0d
JM		 4385 else
4386 Old_Tag1 :=
4387 New_Reference_To
4388 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
4389 Old_Tag2 :=
4390 New_Reference_To
4391 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
4392 end if;
10b93b2e 4393
bfef8d0d
JM		 4394 if Typ /= Etype (Typ)
4395 and then not Is_Interface (Typ)
4396 and then not Restriction_Active (No_Dispatching_Calls)
b0efe69e 4397 then
dee4682a 4398 -- Inherit the dispatch table
10b93b2e 4399
bfef8d0d 4400 if not Is_Interface (Etype (Typ)) then
d0dd5209
JM		 4401 if not Null_Parent_Tag then
4402 declare
4403 Nb_Prims : constant Int :=
4404 UI_To_Int (DT_Entry_Count
4405 (First_Tag_Component (Etype (Typ))));
4406 begin
4407 Append_To (Elab_Code,
4408 Build_Inherit_Predefined_Prims (Loc,
4409 Old_Tag_Node => Old_Tag1,
4410 New_Tag_Node =>
4411 New_Reference_To (DT_Ptr, Loc)));
dee4682a 4412
d0dd5209 4413 if Nb_Prims /= 0 then
dee4682a 4414 Append_To (Elab_Code,
d0dd5209 4415 Build_Inherit_Prims (Loc,
b2e1beb3 4416 Typ => Typ,
d0dd5209
JM		 4417 Old_Tag_Node => Old_Tag2,
4418 New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
4419 Num_Prims => Nb_Prims));
4420 end if;
4421 end;
bfef8d0d
JM		 4422 end if;
4423 end if;
10b93b2e 4424
bfef8d0d 4425 -- Inherit the secondary dispatch tables of the ancestor
10b93b2e 4426
d0dd5209 4427 if not Is_CPP_Class (Etype (Typ)) then
bfef8d0d
JM		 4428 declare
4429 Sec_DT_Ancestor : Elmt_Id :=
4430 Next_Elmt
4431 (First_Elmt
4432 (Access_Disp_Table (Etype (Typ))));
4433 Sec_DT_Typ : Elmt_Id :=
4434 Next_Elmt
4435 (First_Elmt
4436 (Access_Disp_Table (Typ)));
4437
4438 procedure Copy_Secondary_DTs (Typ : Entity_Id);
4439 -- Local procedure required to climb through the ancestors
4440 -- and copy the contents of all their secondary dispatch
4441 -- tables.
4442
4443 ------------------------
4444 -- Copy_Secondary_DTs --
4445 ------------------------
4446
4447 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
4448 E : Entity_Id;
4449 Iface : Elmt_Id;
4450
4451 begin
4452 -- Climb to the ancestor (if any) handling private types
4453
4454 if Present (Full_View (Etype (Typ))) then
4455 if Full_View (Etype (Typ)) /= Typ then
4456 Copy_Secondary_DTs (Full_View (Etype (Typ)));
4457 end if;
10b93b2e 4458
bfef8d0d
JM		 4459 elsif Etype (Typ) /= Typ then
4460 Copy_Secondary_DTs (Etype (Typ));
4461 end if;
10b93b2e 4462
bfef8d0d
JM		 4463 if Present (Abstract_Interfaces (Typ))
4464 and then not Is_Empty_Elmt_List
4465 (Abstract_Interfaces (Typ))
4466 then
4467 Iface := First_Elmt (Abstract_Interfaces (Typ));
4468 E := First_Entity (Typ);
4469 while Present (E)
4470 and then Present (Node (Sec_DT_Ancestor))
d0dd5209 4471 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
bfef8d0d
JM		 4472 loop
4473 if Is_Tag (E) and then Chars (E) /= Name_uTag then
4474 if not Is_Interface (Etype (Typ)) then
dee4682a
JM		 4475
4476 -- Inherit the dispatch table
4477
4478 declare
4479 Num_Prims : constant Int :=
4480 UI_To_Int (DT_Entry_Count (E));
4481 begin
4482 Append_To (Elab_Code,
4483 Build_Inherit_Predefined_Prims (Loc,
4484 Old_Tag_Node =>
4485 Unchecked_Convert_To (RTE (RE_Tag),
4486 New_Reference_To
4487 (Node (Sec_DT_Ancestor), Loc)),
4488 New_Tag_Node =>
4489 Unchecked_Convert_To (RTE (RE_Tag),
4490 New_Reference_To
4491 (Node (Sec_DT_Typ), Loc))));
4492
4493 if Num_Prims /= 0 then
4494 Append_To (Elab_Code,
4495 Build_Inherit_Prims (Loc,
b2e1beb3 4496 Typ => Node (Iface),
dee4682a
JM		 4497 Old_Tag_Node =>
4498 Unchecked_Convert_To
4499 (RTE (RE_Tag),
4500 New_Reference_To
4501 (Node (Sec_DT_Ancestor),
4502 Loc)),
4503 New_Tag_Node =>
4504 Unchecked_Convert_To
4505 (RTE (RE_Tag),
4506 New_Reference_To
4507 (Node (Sec_DT_Typ), Loc)),
b2e1beb3 4508 Num_Prims => Num_Prims));
dee4682a
JM		 4509 end if;
4510 end;
bfef8d0d
JM		 4511 end if;
4512
4513 Next_Elmt (Sec_DT_Ancestor);
4514 Next_Elmt (Sec_DT_Typ);
4515 Next_Elmt (Iface);
4516 end if;
10b93b2e 4517
bfef8d0d
JM		 4518 Next_Entity (E);
4519 end loop;
4520 end if;
4521 end Copy_Secondary_DTs;
10b93b2e 4522
bfef8d0d 4523 begin
d0dd5209
JM		 4524 if Present (Node (Sec_DT_Ancestor))
4525 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
4526 then
bfef8d0d 4527 -- Handle private types
f4d379b8 4528
bfef8d0d
JM		 4529 if Present (Full_View (Typ)) then
4530 Copy_Secondary_DTs (Full_View (Typ));
4531 else
4532 Copy_Secondary_DTs (Typ);
4533 end if;
f4d379b8 4534 end if;
bfef8d0d
JM		 4535 end;
4536 end if;
f4d379b8 4537 end if;
dee4682a 4538 end if;
10b93b2e 4539
dee4682a
JM		 4540 -- Generate code to register the Tag in the External_Tag hash table for
4541 -- the pure Ada type only.
10b93b2e 4542
dee4682a 4543 -- Register_Tag (Dt_Ptr);
10b93b2e 4544
d0dd5209
JM		 4545 -- Skip this action in the following cases:
4546 -- 1) if Register_Tag is not available.
4547 -- 2) in No_Run_Time mode.
4548 -- 3) if Typ is an abstract interface type (the secondary tags will
4549 -- be registered later in types implementing this interface type).
4550 -- 4) if Typ is not defined at the library level (this is required
4551 -- to avoid adding concurrency control to the hash table used
4552 -- by the run-time to register the tags).
10b93b2e 4553
f4d379b8
HK		 4554 -- Generate:
4555 -- if No_Reg then
d0dd5209
JM		 4556 -- [ Elab_Code ]
4557 -- [ Register_Tag (Dt_Ptr); ]
f4d379b8
HK		 4558 -- No_Reg := False;
4559 -- end if;
4560
d0dd5209
JM		 4561 if not Is_Interface (Typ) then
4562 if not No_Run_Time_Mode
b2e1beb3 4563 and then Is_Library_Level_Entity (Typ)
d0dd5209
JM		 4564 and then RTE_Available (RE_Register_Tag)
4565 then
4566 Append_To (Elab_Code,
4567 Make_Procedure_Call_Statement (Loc,
4568 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
4569 Parameter_Associations =>
4570 New_List (New_Reference_To (DT_Ptr, Loc))));
4571 end if;
bfef8d0d 4572
d0dd5209
JM		 4573 Append_To (Elab_Code,
4574 Make_Assignment_Statement (Loc,
4575 Name => New_Reference_To (No_Reg, Loc),
4576 Expression => New_Reference_To (Standard_False, Loc)));
4d744221 4577
d0dd5209
JM		 4578 Append_To (Result,
4579 Make_Implicit_If_Statement (Typ,
4580 Condition => New_Reference_To (No_Reg, Loc),
4581 Then_Statements => Elab_Code));
10b93b2e
HK		 4582 end if;
4583
b2e1beb3
ES		 4584 -- Populate the two auxiliary tables used for dispatching
4585 -- asynchronous, conditional and timed selects for synchronized
4586 -- types that implement a limited interface.
4587
4588 if Ada_Version >= Ada_05
4589 and then Is_Concurrent_Record_Type (Typ)
4590 and then Has_Abstract_Interfaces (Typ)
4591 then
4592 Append_List_To (Result,
4593 Make_Select_Specific_Data_Table (Typ));
4594 end if;
4595
d0dd5209 4596 Analyze_List (Result, Suppress => All_Checks);
b2e1beb3
ES		 4597 Set_Has_Dispatch_Table (Typ);
4598
f4d379b8
HK		 4599 return Result;
4600 end Make_DT;
10b93b2e 4601
f4d379b8
HK		 4602 -------------------------------------
4603 -- Make_Select_Specific_Data_Table --
4604 -------------------------------------
10b93b2e 4605
f4d379b8
HK		 4606 function Make_Select_Specific_Data_Table
4607 (Typ : Entity_Id) return List_Id
4608 is
4609 Assignments : constant List_Id := New_List;
4610 Loc : constant Source_Ptr := Sloc (Typ);
10b93b2e 4611
b0efe69e
JM		 4612 Conc_Typ : Entity_Id;
4613 Decls : List_Id;
4614 DT_Ptr : Entity_Id;
4615 Prim : Entity_Id;
4616 Prim_Als : Entity_Id;
4617 Prim_Elmt : Elmt_Id;
4618 Prim_Pos : Uint;
dee4682a 4619 Nb_Prim : Nat := 0;
10b93b2e 4620
f4d379b8 4621 type Examined_Array is array (Int range <>) of Boolean;
10b93b2e 4622
f4d379b8
HK		 4623 function Find_Entry_Index (E : Entity_Id) return Uint;
4624 -- Given an entry, find its index in the visible declarations of the
4625 -- corresponding concurrent type of Typ.
10b93b2e 4626
f4d379b8
HK		 4627 ----------------------
4628 -- Find_Entry_Index --
4629 ----------------------
10b93b2e 4630
f4d379b8
HK		 4631 function Find_Entry_Index (E : Entity_Id) return Uint is
4632 Index : Uint := Uint_1;
4633 Subp_Decl : Entity_Id;
10b93b2e 4634
f4d379b8
HK		 4635 begin
4636 if Present (Decls)
4637 and then not Is_Empty_List (Decls)
4638 then
4639 Subp_Decl := First (Decls);
4640 while Present (Subp_Decl) loop
4641 if Nkind (Subp_Decl) = N_Entry_Declaration then
4642 if Defining_Identifier (Subp_Decl) = E then
4643 return Index;
4644 end if;
10b93b2e 4645
f4d379b8
HK		 4646 Index := Index + 1;
4647 end if;
10b93b2e 4648
f4d379b8
HK		 4649 Next (Subp_Decl);
4650 end loop;
4651 end if;
10b93b2e 4652
f4d379b8
HK		 4653 return Uint_0;
4654 end Find_Entry_Index;
4655
4656 -- Start of processing for Make_Select_Specific_Data_Table
4657
4658 begin
b0efe69e
JM		 4659 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
4660
f4d379b8 4661 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
10b93b2e 4662
f4d379b8
HK		 4663 if Present (Corresponding_Concurrent_Type (Typ)) then
4664 Conc_Typ := Corresponding_Concurrent_Type (Typ);
4665
b2e1beb3
ES		 4666 if Present (Full_View (Conc_Typ)) then
4667 Conc_Typ := Full_View (Conc_Typ);
4668 end if;
4669
f4d379b8
HK		 4670 if Ekind (Conc_Typ) = E_Protected_Type then
4671 Decls := Visible_Declarations (Protected_Definition (
4672 Parent (Conc_Typ)));
10b93b2e
HK		 4673 else
4674 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
f4d379b8
HK		 4675 Decls := Visible_Declarations (Task_Definition (
4676 Parent (Conc_Typ)));
4677 end if;
4678 end if;
10b93b2e 4679
f4d379b8 4680 -- Count the non-predefined primitive operations
10b93b2e 4681
f4d379b8
HK		 4682 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4683 while Present (Prim_Elmt) loop
bfef8d0d
JM		 4684 Prim := Node (Prim_Elmt);
4685
4686 if not (Is_Predefined_Dispatching_Operation (Prim)
4687 or else Is_Predefined_Dispatching_Alias (Prim))
4688 then
f4d379b8
HK		 4689 Nb_Prim := Nb_Prim + 1;
4690 end if;
10b93b2e 4691
f4d379b8
HK		 4692 Next_Elmt (Prim_Elmt);
4693 end loop;
10b93b2e 4694
f4d379b8 4695 declare
b0efe69e 4696 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
10b93b2e 4697
f4d379b8
HK		 4698 begin
4699 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4700 while Present (Prim_Elmt) loop
4701 Prim := Node (Prim_Elmt);
10b93b2e 4702
bfef8d0d 4703 -- Look for primitive overriding an abstract interface subprogram
10b93b2e 4704
bfef8d0d
JM		 4705 if Present (Abstract_Interface_Alias (Prim))
4706 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
4707 then
4708 Prim_Pos := DT_Position (Alias (Prim));
4709 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
4710 Examined (UI_To_Int (Prim_Pos)) := True;
10b93b2e 4711
bfef8d0d
JM		 4712 -- Set the primitive operation kind regardless of subprogram
4713 -- type. Generate:
4714 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
10b93b2e 4715
bfef8d0d 4716 Append_To (Assignments,
d0dd5209
JM		 4717 Make_Procedure_Call_Statement (Loc,
4718 Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
4719 Parameter_Associations => New_List (
4720 New_Reference_To (DT_Ptr, Loc),
4721 Make_Integer_Literal (Loc, Prim_Pos),
4722 Prim_Op_Kind (Alias (Prim), Typ))));
b0efe69e 4723
bfef8d0d 4724 -- Retrieve the root of the alias chain
b0efe69e 4725
bfef8d0d
JM		 4726 Prim_Als := Prim;
4727 while Present (Alias (Prim_Als)) loop
4728 Prim_Als := Alias (Prim_Als);
4729 end loop;
b0efe69e 4730
bfef8d0d 4731 -- In the case of an entry wrapper, set the entry index
b0efe69e 4732
bfef8d0d
JM		 4733 if Ekind (Prim) = E_Procedure
4734 and then Is_Primitive_Wrapper (Prim_Als)
4735 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
4736 then
4737 -- Generate:
4738 -- Ada.Tags.Set_Entry_Index
4739 -- (DT_Ptr, <position>, <index>);
b0efe69e 4740
bfef8d0d 4741 Append_To (Assignments,
d0dd5209
JM		 4742 Make_Procedure_Call_Statement (Loc,
4743 Name =>
4744 New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
4745 Parameter_Associations => New_List (
4746 New_Reference_To (DT_Ptr, Loc),
4747 Make_Integer_Literal (Loc, Prim_Pos),
4748 Make_Integer_Literal (Loc,
4749 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
f4d379b8
HK		 4750 end if;
4751 end if;
4752
f4d379b8
HK		 4753 Next_Elmt (Prim_Elmt);
4754 end loop;
4755 end;
4756
4757 return Assignments;
4758 end Make_Select_Specific_Data_Table;
10b93b2e 4759
b2e1beb3
ES		 4760 ---------------
4761 -- Make_Tags --
4762 ---------------
4763
4764 function Make_Tags (Typ : Entity_Id) return List_Id is
4765 Loc : constant Source_Ptr := Sloc (Typ);
4766 Build_Static_DT : constant Boolean :=
4767 Static_Dispatch_Tables
4768 and then Is_Library_Level_Tagged_Type (Typ);
4769 Tname : constant Name_Id := Chars (Typ);
4770 Result : constant List_Id := New_List;
4771 AI_Tag_Comp : Elmt_Id;
4772 DT_Ptr : Node_Id;
4773 Iface_DT_Ptr : Node_Id;
4774 Suffix_Index : Int;
4775 Typ_Name : Name_Id;
4776 Typ_Comps : Elist_Id;
4777
4778 begin
4779 -- 1) Generate the primary and secondary tag entities
4780
4781 -- Collect the components associated with secondary dispatch tables
4782
4783 if Has_Abstract_Interfaces (Typ) then
4784 Collect_Interface_Components (Typ, Typ_Comps);
4785 end if;
4786
4787 -- 1) Generate the primary tag entity
4788
4789 DT_Ptr := Make_Defining_Identifier (Loc,
4790 New_External_Name (Tname, 'P'));
4791 Set_Etype (DT_Ptr, RTE (RE_Tag));
4792 Set_Ekind (DT_Ptr, E_Variable);
4793
4794 -- Import the forward declaration of the tag (Make_DT will take care of
4795 -- its exportation)
4796
4797 if Build_Static_DT then
4798 Set_Is_Imported (DT_Ptr);
4799 Set_Is_True_Constant (DT_Ptr);
4800 Set_Scope (DT_Ptr, Current_Scope);
4801 Get_External_Name (DT_Ptr, True);
4802 Set_Interface_Name (DT_Ptr,
4803 Make_String_Literal (Loc,
4804 Strval => String_From_Name_Buffer));
4805
4806 -- Set tag entity as internal to ensure proper Sprint output of its
4807 -- implicit importation.
4808
4809 Set_Is_Internal (DT_Ptr);
4810
4811 Append_To (Result,
4812 Make_Object_Declaration (Loc,
4813 Defining_Identifier => DT_Ptr,
4814 Constant_Present => True,
4815 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
4816 end if;
4817
4818 pragma Assert (No (Access_Disp_Table (Typ)));
4819 Set_Access_Disp_Table (Typ, New_Elmt_List);
4820 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
4821
4822 -- 2) Generate the secondary tag entities
4823
4824 if Has_Abstract_Interfaces (Typ) then
4825 Suffix_Index := 0;
4826
4827 -- For each interface type we build an unique external name
4828 -- associated with its corresponding secondary dispatch table.
4829 -- This external name will be used to declare an object that
4830 -- references this secondary dispatch table, value that will be
4831 -- used for the elaboration of Typ's objects and also for the
4832 -- elaboration of objects of derivations of Typ that do not
4833 -- override the primitive operation of this interface type.
4834
4835 AI_Tag_Comp := First_Elmt (Typ_Comps);
4836 while Present (AI_Tag_Comp) loop
4837 Get_Secondary_DT_External_Name
4838 (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index);
4839
4840 Typ_Name := Name_Find;
4841 Iface_DT_Ptr :=
4842 Make_Defining_Identifier (Loc,
4843 Chars => New_External_Name (Typ_Name, 'P'));
4844 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
4845 Set_Ekind (Iface_DT_Ptr, E_Constant);
4846 Set_Is_Statically_Allocated (Iface_DT_Ptr);
4847 Set_Is_True_Constant (Iface_DT_Ptr);
4848 Set_Related_Interface
4849 (Iface_DT_Ptr, Related_Interface (Node (AI_Tag_Comp)));
4850 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
4851
4852 Next_Elmt (AI_Tag_Comp);
4853 end loop;
4854 end if;
4855
4856 -- 3) At the end of Access_Disp_Table we add the entity of an access
4857 -- type declaration. It is used by Build_Get_Prim_Op_Address to
4858 -- expand dispatching calls through the primary dispatch table.
4859
4860 -- Generate:
4861 -- type Typ_DT is array (1 .. Nb_Prims) of Address;
4862 -- type Typ_DT_Acc is access Typ_DT;
4863
4864 declare
4865 Name_DT_Prims : constant Name_Id :=
4866 New_External_Name (Tname, 'G');
4867 Name_DT_Prims_Acc : constant Name_Id :=
4868 New_External_Name (Tname, 'H');
4869 DT_Prims : constant Entity_Id :=
4870 Make_Defining_Identifier (Loc, Name_DT_Prims);
4871 DT_Prims_Acc : constant Entity_Id :=
4872 Make_Defining_Identifier (Loc,
4873 Name_DT_Prims_Acc);
4874 begin
4875 Append_To (Result,
4876 Make_Full_Type_Declaration (Loc,
4877 Defining_Identifier => DT_Prims,
4878 Type_Definition =>
4879 Make_Constrained_Array_Definition (Loc,
4880 Discrete_Subtype_Definitions => New_List (
4881 Make_Range (Loc,
4882 Low_Bound => Make_Integer_Literal (Loc, 1),
4883 High_Bound => Make_Integer_Literal (Loc,
4884 DT_Entry_Count
4885 (First_Tag_Component (Typ))))),
4886 Component_Definition =>
4887 Make_Component_Definition (Loc,
4888 Subtype_Indication =>
4889 New_Reference_To (RTE (RE_Address), Loc)))));
4890
4891 Append_To (Result,
4892 Make_Full_Type_Declaration (Loc,
4893 Defining_Identifier => DT_Prims_Acc,
4894 Type_Definition =>
4895 Make_Access_To_Object_Definition (Loc,
4896 Subtype_Indication =>
4897 New_Occurrence_Of (DT_Prims, Loc))));
4898
4899 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
4900
4901 -- Analyze the resulting list and suppress the generation of the
4902 -- Init_Proc associated with the above array declaration because
4903 -- we never use such type in object declarations; this type is only
4904 -- used to simplify the expansion associated with dispatching calls.
4905
4906 Analyze_List (Result);
4907 Set_Suppress_Init_Proc (Base_Type (DT_Prims));
4908 end;
4909
4910 return Result;
4911 end Make_Tags;
4912
70482933
RK		 4913 -----------------------------------
4914 -- Original_View_In_Visible_Part --
4915 -----------------------------------
4916
4917 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
4918 Scop : constant Entity_Id := Scope (Typ);
4919
4920 begin
4921 -- The scope must be a package
4922
4923 if Ekind (Scop) /= E_Package
4924 and then Ekind (Scop) /= E_Generic_Package
4925 then
4926 return False;
4927 end if;
4928
4929 -- A type with a private declaration has a private view declared in
4930 -- the visible part.
4931
4932 if Has_Private_Declaration (Typ) then
4933 return True;
4934 end if;
4935
4936 return List_Containing (Parent (Typ)) =
4937 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
4938 end Original_View_In_Visible_Part;
4939
10b93b2e
HK		 4940 ------------------
4941 -- Prim_Op_Kind --
4942 ------------------
4943
4944 function Prim_Op_Kind
4945 (Prim : Entity_Id;
4946 Typ : Entity_Id) return Node_Id
4947 is
4948 Full_Typ : Entity_Id := Typ;
4949 Loc : constant Source_Ptr := Sloc (Prim);
b0efe69e 4950 Prim_Op : Entity_Id;
10b93b2e
HK		 4951
4952 begin
4953 -- Retrieve the original primitive operation
4954
b0efe69e 4955 Prim_Op := Prim;
10b93b2e
HK		 4956 while Present (Alias (Prim_Op)) loop
4957 Prim_Op := Alias (Prim_Op);
4958 end loop;
4959
4960 if Ekind (Typ) = E_Record_Type
4961 and then Present (Corresponding_Concurrent_Type (Typ))
4962 then
4963 Full_Typ := Corresponding_Concurrent_Type (Typ);
4964 end if;
4965
4966 if Ekind (Prim_Op) = E_Function then
4967
4968 -- Protected function
4969
4970 if Ekind (Full_Typ) = E_Protected_Type then
4971 return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
4972
f4d379b8
HK		 4973 -- Task function
4974
4975 elsif Ekind (Full_Typ) = E_Task_Type then
4976 return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
4977
10b93b2e
HK		 4978 -- Regular function
4979
4980 else
4981 return New_Reference_To (RTE (RE_POK_Function), Loc);
4982 end if;
4983
4984 else
4985 pragma Assert (Ekind (Prim_Op) = E_Procedure);
4986
4987 if Ekind (Full_Typ) = E_Protected_Type then
4988
4989 -- Protected entry
4990
4991 if Is_Primitive_Wrapper (Prim_Op)
4992 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
4993 then
4994 return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
4995
4996 -- Protected procedure
4997
4998 else
4999 return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
5000 end if;
5001
5002 elsif Ekind (Full_Typ) = E_Task_Type then
5003
5004 -- Task entry
5005
5006 if Is_Primitive_Wrapper (Prim_Op)
5007 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
5008 then
5009 return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
5010
5011 -- Task "procedure". These are the internally Expander-generated
5012 -- procedures (task body for instance).
5013
5014 else
5015 return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
5016 end if;
5017
5018 -- Regular procedure
5019
5020 else
5021 return New_Reference_To (RTE (RE_POK_Procedure), Loc);
5022 end if;
5023 end if;
5024 end Prim_Op_Kind;
5025
d0dd5209
JM		 5026 ------------------------
5027 -- Register_Primitive --
5028 ------------------------
5029
5030 procedure Register_Primitive
5031 (Loc : Source_Ptr;
5032 Prim : Entity_Id;
5033 Ins_Nod : Node_Id)
5034 is
5035 DT_Ptr : Entity_Id;
5036 Iface_Prim : Entity_Id;
5037 Iface_Typ : Entity_Id;
5038 Iface_DT_Ptr : Entity_Id;
5039 Pos : Uint;
5040 Tag : Entity_Id;
5041 Thunk_Id : Entity_Id;
5042 Thunk_Code : Node_Id;
5043 Typ : Entity_Id;
5044
5045 begin
5046 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
5047
5048 if not RTE_Available (RE_Tag) then
5049 return;
5050 end if;
5051
5052 if not Present (Abstract_Interface_Alias (Prim)) then
5053 Typ := Scope (DTC_Entity (Prim));
5054 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
5055 Pos := DT_Position (Prim);
5056 Tag := First_Tag_Component (Typ);
5057
5058 if Is_Predefined_Dispatching_Operation (Prim)
5059 or else Is_Predefined_Dispatching_Alias (Prim)
5060 then
5061 Insert_After (Ins_Nod,
5062 Build_Set_Predefined_Prim_Op_Address (Loc,
5063 Tag_Node => New_Reference_To (DT_Ptr, Loc),
5064 Position => Pos,
5065 Address_Node => Make_Attribute_Reference (Loc,
5066 Prefix => New_Reference_To (Prim, Loc),
5067 Attribute_Name => Name_Address)));
5068
5069 else
5070 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
5071
5072 Insert_After (Ins_Nod,
5073 Build_Set_Prim_Op_Address (Loc,
5074 Typ => Typ,
5075 Tag_Node => New_Reference_To (DT_Ptr, Loc),
5076 Position => Pos,
5077 Address_Node => Make_Attribute_Reference (Loc,
5078 Prefix => New_Reference_To (Prim, Loc),
5079 Attribute_Name => Name_Address)));
5080 end if;
5081
5082 -- Ada 2005 (AI-251): Primitive associated with an interface type
5083 -- Generate the code of the thunk only if the interface type is not an
5084 -- immediate ancestor of Typ; otherwise the dispatch table associated
5085 -- with the interface is the primary dispatch table and we have nothing
5086 -- else to do here.
5087
5088 else
5089 Typ := Find_Dispatching_Type (Alias (Prim));
5090 Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
5091
5092 pragma Assert (Is_Interface (Iface_Typ));
5093
b2e1beb3 5094 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
d0dd5209
JM		 5095
5096 if not Is_Parent (Iface_Typ, Typ)
5097 and then Present (Thunk_Code)
5098 then
b2e1beb3
ES		 5099 -- Comment needed on why checks are suppressed. This is not just
5100 -- efficiency, but fundamental functionality (see 1.295 RH, which
5101 -- still does not answer this question) ???
5102
d0dd5209
JM		 5103 Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
5104
5105 -- Generate the code necessary to fill the appropriate entry of
5106 -- the secondary dispatch table of Prim's controlling type with
5107 -- Thunk_Id's address.
5108
5109 Iface_DT_Ptr := Find_Interface_ADT (Typ, Iface_Typ);
5110 Iface_Prim := Abstract_Interface_Alias (Prim);
5111 Pos := DT_Position (Iface_Prim);
5112 Tag := First_Tag_Component (Iface_Typ);
5113
5114 if Is_Predefined_Dispatching_Operation (Prim)
5115 or else Is_Predefined_Dispatching_Alias (Prim)
5116 then
5117 Insert_Action (Ins_Nod,
5118 Build_Set_Predefined_Prim_Op_Address (Loc,
5119 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
5120 Position => Pos,
5121 Address_Node =>
5122 Make_Attribute_Reference (Loc,
5123 Prefix => New_Reference_To (Thunk_Id, Loc),
5124 Attribute_Name => Name_Address)));
5125 else
5126 pragma Assert (Pos /= Uint_0
5127 and then Pos <= DT_Entry_Count (Tag));
5128
5129 Insert_Action (Ins_Nod,
5130 Build_Set_Prim_Op_Address (Loc,
5131 Typ => Iface_Typ,
5132 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
5133 Position => Pos,
5134 Address_Node => Make_Attribute_Reference (Loc,
5135 Prefix =>
5136 New_Reference_To (Thunk_Id, Loc),
5137 Attribute_Name => Name_Address)));
5138 end if;
5139 end if;
5140 end if;
5141 end Register_Primitive;
5142
70482933
RK		 5143 -------------------------
5144 -- Set_All_DT_Position --
5145 -------------------------
5146
5147 procedure Set_All_DT_Position (Typ : Entity_Id) is
70482933 5148
758c442c
GD		 5149 procedure Validate_Position (Prim : Entity_Id);
5150 -- Check that the position assignated to Prim is completely safe
5151 -- (it has not been assigned to a previously defined primitive
5152 -- operation of Typ)
5153
5154 -----------------------
5155 -- Validate_Position --
5156 -----------------------
5157
5158 procedure Validate_Position (Prim : Entity_Id) is
bfef8d0d
JM		 5159 Op_Elmt : Elmt_Id;
5160 Op : Entity_Id;
10b93b2e 5161
758c442c 5162 begin
bfef8d0d
JM		 5163 -- Aliased primitives are safe
5164
5165 if Present (Alias (Prim)) then
5166 return;
5167 end if;
5168
5169 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
5170 while Present (Op_Elmt) loop
5171 Op := Node (Op_Elmt);
5172
5173 -- No need to check against itself
5174
5175 if Op = Prim then
5176 null;
5177
758c442c
GD		 5178 -- Primitive operations covering abstract interfaces are
5179 -- allocated later
5180
bfef8d0d 5181 elsif Present (Abstract_Interface_Alias (Op)) then
758c442c
GD		 5182 null;
5183
b0efe69e
JM		 5184 -- Predefined dispatching operations are completely safe. They
5185 -- are allocated at fixed positions in a separate table.
758c442c 5186
bfef8d0d
JM		 5187 elsif Is_Predefined_Dispatching_Operation (Op)
5188 or else Is_Predefined_Dispatching_Alias (Op)
5189 then
758c442c 5190 null;
70482933 5191
758c442c
GD		 5192 -- Aliased subprograms are safe
5193
bfef8d0d 5194 elsif Present (Alias (Op)) then
758c442c
GD		 5195 null;
5196
bfef8d0d
JM		 5197 elsif DT_Position (Op) = DT_Position (Prim)
5198 and then not Is_Predefined_Dispatching_Operation (Op)
5199 and then not Is_Predefined_Dispatching_Operation (Prim)
5200 and then not Is_Predefined_Dispatching_Alias (Op)
5201 and then not Is_Predefined_Dispatching_Alias (Prim)
5202 then
10b93b2e
HK		 5203
5204 -- Handle aliased subprograms
5205
5206 declare
5207 Op_1 : Entity_Id;
5208 Op_2 : Entity_Id;
5209
5210 begin
bfef8d0d 5211 Op_1 := Op;
10b93b2e
HK		 5212 loop
5213 if Present (Overridden_Operation (Op_1)) then
5214 Op_1 := Overridden_Operation (Op_1);
5215 elsif Present (Alias (Op_1)) then
5216 Op_1 := Alias (Op_1);
5217 else
5218 exit;
5219 end if;
5220 end loop;
5221
5222 Op_2 := Prim;
5223 loop
5224 if Present (Overridden_Operation (Op_2)) then
5225 Op_2 := Overridden_Operation (Op_2);
5226 elsif Present (Alias (Op_2)) then
5227 Op_2 := Alias (Op_2);
5228 else
5229 exit;
5230 end if;
5231 end loop;
5232
5233 if Op_1 /= Op_2 then
5234 raise Program_Error;
5235 end if;
5236 end;
758c442c
GD		 5237 end if;
5238
bfef8d0d 5239 Next_Elmt (Op_Elmt);
758c442c
GD		 5240 end loop;
5241 end Validate_Position;
5242
bfef8d0d
JM		 5243 -- Local variables
5244
5245 Parent_Typ : constant Entity_Id := Etype (Typ);
bfef8d0d
JM		 5246 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
5247 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
5248
5249 Adjusted : Boolean := False;
5250 Finalized : Boolean := False;
5251
dee4682a
JM		 5252 Count_Prim : Nat;
5253 DT_Length : Nat;
5254 Nb_Prim : Nat;
bfef8d0d
JM		 5255 Prim : Entity_Id;
5256 Prim_Elmt : Elmt_Id;
5257
758c442c
GD		 5258 -- Start of processing for Set_All_DT_Position
5259
5260 begin
dee4682a
JM		 5261 -- Set the DT_Position for each primitive operation. Perform some
5262 -- sanity checks to avoid to build completely inconsistant dispatch
5263 -- tables.
70482933 5264
dee4682a
JM		 5265 -- First stage: Set the DTC entity of all the primitive operations
5266 -- This is required to properly read the DT_Position attribute in
5267 -- the latter stages.
70482933 5268
dee4682a
JM		 5269 Prim_Elmt := First_Prim;
5270 Count_Prim := 0;
5271 while Present (Prim_Elmt) loop
5272 Prim := Node (Prim_Elmt);
70482933 5273
dee4682a 5274 -- Predefined primitives have a separate dispatch table
70482933 5275
dee4682a
JM		 5276 if not (Is_Predefined_Dispatching_Operation (Prim)
5277 or else Is_Predefined_Dispatching_Alias (Prim))
5278 then
5279 Count_Prim := Count_Prim + 1;
5280 end if;
70482933 5281
d0dd5209 5282 Set_DTC_Entity_Value (Typ, Prim);
70482933 5283
dee4682a
JM		 5284 -- Clear any previous value of the DT_Position attribute. In this
5285 -- way we ensure that the final position of all the primitives is
5286 -- stablished by the following stages of this algorithm.
70482933 5287
dee4682a 5288 Set_DT_Position (Prim, No_Uint);
70482933 5289
dee4682a
JM		 5290 Next_Elmt (Prim_Elmt);
5291 end loop;
70482933 5292
dee4682a
JM		 5293 declare
5294 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
5295 := (others => False);
5296 E : Entity_Id;
70482933 5297
d0dd5209
JM		 5298 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
5299 -- Called if Typ is declared in a nested package or a public child
5300 -- package to handle inherited primitives that were inherited by Typ
5301 -- in the visible part, but whose declaration was deferred because
5302 -- the parent operation was private and not visible at that point.
5303
dee4682a
JM		 5304 procedure Set_Fixed_Prim (Pos : Nat);
5305 -- Sets to true an element of the Fixed_Prim table to indicate
5306 -- that this entry of the dispatch table of Typ is occupied.
70482933 5307
d0dd5209
JM		 5308 ------------------------------------------
5309 -- Handle_Inherited_Private_Subprograms --
5310 ------------------------------------------
5311
5312 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
5313 Op_List : Elist_Id;
5314 Op_Elmt : Elmt_Id;
5315 Op_Elmt_2 : Elmt_Id;
5316 Prim_Op : Entity_Id;
5317 Parent_Subp : Entity_Id;
5318
5319 begin
5320 Op_List := Primitive_Operations (Typ);
5321
5322 Op_Elmt := First_Elmt (Op_List);
5323 while Present (Op_Elmt) loop
5324 Prim_Op := Node (Op_Elmt);
5325
5326 -- Search primitives that are implicit operations with an
5327 -- internal name whose parent operation has a normal name.
5328
5329 if Present (Alias (Prim_Op))
5330 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
5331 and then not Comes_From_Source (Prim_Op)
5332 and then Is_Internal_Name (Chars (Prim_Op))
5333 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
5334 then
5335 Parent_Subp := Alias (Prim_Op);
5336
5337 -- Check if the type has an explicit overriding for this
5338 -- primitive.
5339
5340 Op_Elmt_2 := Next_Elmt (Op_Elmt);
5341 while Present (Op_Elmt_2) loop
5342 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
5343 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
5344 then
5345 Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
5346 Set_DT_Position (Node (Op_Elmt_2),
5347 DT_Position (Parent_Subp));
5348 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
5349
5350 goto Next_Primitive;
5351 end if;
5352
5353 Next_Elmt (Op_Elmt_2);
5354 end loop;
5355 end if;
5356
5357 <<Next_Primitive>>
5358 Next_Elmt (Op_Elmt);
5359 end loop;
5360 end Handle_Inherited_Private_Subprograms;
5361
dee4682a
JM		 5362 --------------------
5363 -- Set_Fixed_Prim --
5364 --------------------
70482933 5365
dee4682a 5366 procedure Set_Fixed_Prim (Pos : Nat) is
70482933 5367 begin
dee4682a
JM		 5368 pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
5369 Fixed_Prim (Pos) := True;
5370 exception
5371 when Constraint_Error =>
5372 raise Program_Error;
5373 end Set_Fixed_Prim;
70482933 5374
dee4682a 5375 begin
d0dd5209
JM		 5376 -- In case of nested packages and public child package it may be
5377 -- necessary a special management on inherited subprograms so that
5378 -- the dispatch table is properly filled.
5379
5380 if Ekind (Scope (Scope (Typ))) = E_Package
5381 and then Scope (Scope (Typ)) /= Standard_Standard
5382 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
5383 or else
5384 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
5385 and then Is_Generic_Type (Typ)))
5386 and then In_Open_Scopes (Scope (Etype (Typ)))
5387 and then Typ = Base_Type (Typ)
5388 then
5389 Handle_Inherited_Private_Subprograms (Typ);
5390 end if;
5391
dee4682a 5392 -- Second stage: Register fixed entries
70482933 5393
dee4682a
JM		 5394 Nb_Prim := 0;
5395 Prim_Elmt := First_Prim;
5396 while Present (Prim_Elmt) loop
5397 Prim := Node (Prim_Elmt);
70482933 5398
dee4682a
JM		 5399 -- Predefined primitives have a separate table and all its
5400 -- entries are at predefined fixed positions.
70482933 5401
dee4682a
JM		 5402 if Is_Predefined_Dispatching_Operation (Prim) then
5403 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
70482933 5404
dee4682a
JM		 5405 elsif Is_Predefined_Dispatching_Alias (Prim) then
5406 E := Alias (Prim);
5407 while Present (Alias (E)) loop
5408 E := Alias (E);
5409 end loop;
10b93b2e 5410
dee4682a 5411 Set_DT_Position (Prim, Default_Prim_Op_Position (E));
10b93b2e 5412
dee4682a 5413 -- Overriding primitives of ancestor abstract interfaces
70482933 5414
dee4682a
JM		 5415 elsif Present (Abstract_Interface_Alias (Prim))
5416 and then Is_Parent
5417 (Find_Dispatching_Type
5418 (Abstract_Interface_Alias (Prim)),
5419 Typ)
5420 then
5421 pragma Assert (DT_Position (Prim) = No_Uint
5422 and then Present (DTC_Entity
5423 (Abstract_Interface_Alias (Prim))));
70482933 5424
dee4682a
JM		 5425 E := Abstract_Interface_Alias (Prim);
5426 Set_DT_Position (Prim, DT_Position (E));
758c442c 5427
dee4682a
JM		 5428 pragma Assert
5429 (DT_Position (Alias (Prim)) = No_Uint
5430 or else DT_Position (Alias (Prim)) = DT_Position (E));
5431 Set_DT_Position (Alias (Prim), DT_Position (E));
5432 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
bfef8d0d 5433
dee4682a 5434 -- Overriding primitives must use the same entry as the
d0dd5209 5435 -- overriden primitive.
bfef8d0d 5436
dee4682a
JM		 5437 elsif not Present (Abstract_Interface_Alias (Prim))
5438 and then Present (Alias (Prim))
b2e1beb3 5439 and then Chars (Prim) = Chars (Alias (Prim))
dee4682a
JM		 5440 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
5441 and then Is_Parent
5442 (Find_Dispatching_Type (Alias (Prim)), Typ)
5443 and then Present (DTC_Entity (Alias (Prim)))
bfef8d0d 5444 then
dee4682a
JM		 5445 E := Alias (Prim);
5446 Set_DT_Position (Prim, DT_Position (E));
758c442c 5447
dee4682a
JM		 5448 if not Is_Predefined_Dispatching_Alias (E) then
5449 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
5450 end if;
fbf5a39b 5451 end if;
70482933 5452
758c442c
GD		 5453 Next_Elmt (Prim_Elmt);
5454 end loop;
5455
dee4682a
JM		 5456 -- Third stage: Fix the position of all the new primitives
5457 -- Entries associated with primitives covering interfaces
5458 -- are handled in a latter round.
758c442c 5459
dee4682a
JM		 5460 Prim_Elmt := First_Prim;
5461 while Present (Prim_Elmt) loop
5462 Prim := Node (Prim_Elmt);
758c442c 5463
dee4682a 5464 -- Skip primitives previously set entries
758c442c 5465
dee4682a
JM		 5466 if DT_Position (Prim) /= No_Uint then
5467 null;
758c442c 5468
dee4682a 5469 -- Primitives covering interface primitives are handled later
758c442c 5470
dee4682a
JM		 5471 elsif Present (Abstract_Interface_Alias (Prim)) then
5472 null;
758c442c 5473
dee4682a
JM		 5474 else
5475 -- Take the next available position in the DT
758c442c 5476
dee4682a
JM		 5477 loop
5478 Nb_Prim := Nb_Prim + 1;
5479 pragma Assert (Nb_Prim <= Count_Prim);
5480 exit when not Fixed_Prim (Nb_Prim);
5481 end loop;
758c442c 5482
dee4682a
JM		 5483 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
5484 Set_Fixed_Prim (Nb_Prim);
5485 end if;
758c442c 5486
dee4682a
JM		 5487 Next_Elmt (Prim_Elmt);
5488 end loop;
5489 end;
758c442c 5490
dee4682a
JM		 5491 -- Fourth stage: Complete the decoration of primitives covering
5492 -- interfaces (that is, propagate the DT_Position attribute
5493 -- from the aliased primitive)
758c442c 5494
dee4682a
JM		 5495 Prim_Elmt := First_Prim;
5496 while Present (Prim_Elmt) loop
5497 Prim := Node (Prim_Elmt);
758c442c 5498
dee4682a
JM		 5499 if DT_Position (Prim) = No_Uint
5500 and then Present (Abstract_Interface_Alias (Prim))
5501 then
5502 pragma Assert (Present (Alias (Prim))
5503 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
758c442c 5504
dee4682a 5505 -- Check if this entry will be placed in the primary DT
758c442c 5506
dee4682a
JM		 5507 if Is_Parent (Find_Dispatching_Type
5508 (Abstract_Interface_Alias (Prim)),
5509 Typ)
70482933 5510 then
dee4682a
JM		 5511 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
5512 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
758c442c 5513
dee4682a 5514 -- Otherwise it will be placed in the secondary DT
758c442c 5515
dee4682a
JM		 5516 else
5517 pragma Assert
5518 (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
5519 Set_DT_Position (Prim,
5520 DT_Position (Abstract_Interface_Alias (Prim)));
758c442c 5521 end if;
dee4682a 5522 end if;
758c442c 5523
dee4682a
JM		 5524 Next_Elmt (Prim_Elmt);
5525 end loop;
10b93b2e 5526
dee4682a
JM		 5527 -- Generate listing showing the contents of the dispatch tables.
5528 -- This action is done before some further static checks because
5529 -- in case of critical errors caused by a wrong dispatch table
5530 -- we need to see the contents of such table.
10b93b2e 5531
dee4682a
JM		 5532 if Debug_Flag_ZZ then
5533 Write_DT (Typ);
5534 end if;
758c442c 5535
dee4682a
JM		 5536 -- Final stage: Ensure that the table is correct plus some further
5537 -- verifications concerning the primitives.
758c442c 5538
dee4682a
JM		 5539 Prim_Elmt := First_Prim;
5540 DT_Length := 0;
5541 while Present (Prim_Elmt) loop
5542 Prim := Node (Prim_Elmt);
758c442c 5543
dee4682a
JM		 5544 -- At this point all the primitives MUST have a position
5545 -- in the dispatch table
758c442c 5546
dee4682a
JM		 5547 if DT_Position (Prim) = No_Uint then
5548 raise Program_Error;
5549 end if;
758c442c 5550
dee4682a 5551 -- Calculate real size of the dispatch table
758c442c 5552
dee4682a
JM		 5553 if not (Is_Predefined_Dispatching_Operation (Prim)
5554 or else Is_Predefined_Dispatching_Alias (Prim))
5555 and then UI_To_Int (DT_Position (Prim)) > DT_Length
5556 then
5557 DT_Length := UI_To_Int (DT_Position (Prim));
5558 end if;
758c442c 5559
dee4682a
JM		 5560 -- Ensure that the asignated position to non-predefined
5561 -- dispatching operations in the dispatch table is correct.
758c442c 5562
dee4682a
JM		 5563 if not (Is_Predefined_Dispatching_Operation (Prim)
5564 or else Is_Predefined_Dispatching_Alias (Prim))
5565 then
5566 Validate_Position (Prim);
5567 end if;
70482933 5568
dee4682a
JM		 5569 if Chars (Prim) = Name_Finalize then
5570 Finalized := True;
5571 end if;
70482933 5572
dee4682a
JM		 5573 if Chars (Prim) = Name_Adjust then
5574 Adjusted := True;
5575 end if;
bfef8d0d 5576
dee4682a
JM		 5577 -- An abstract operation cannot be declared in the private part
5578 -- for a visible abstract type, because it could never be over-
5579 -- ridden. For explicit declarations this is checked at the
5580 -- point of declaration, but for inherited operations it must
5581 -- be done when building the dispatch table.
5582
5583 -- Ada 2005 (AI-251): Hidden entities associated with abstract
5584 -- interface primitives are not taken into account because the
5585 -- check is done with the aliased primitive.
5586
5587 if Is_Abstract_Type (Typ)
5588 and then Is_Abstract_Subprogram (Prim)
5589 and then Present (Alias (Prim))
5590 and then not Present (Abstract_Interface_Alias (Prim))
5591 and then Is_Derived_Type (Typ)
5592 and then In_Private_Part (Current_Scope)
5593 and then
5594 List_Containing (Parent (Prim)) =
5595 Private_Declarations
5596 (Specification (Unit_Declaration_Node (Current_Scope)))
5597 and then Original_View_In_Visible_Part (Typ)
5598 then
5599 -- We exclude Input and Output stream operations because
5600 -- Limited_Controlled inherits useless Input and Output
5601 -- stream operations from Root_Controlled, which can
5602 -- never be overridden.
70482933 5603
dee4682a
JM		 5604 if not Is_TSS (Prim, TSS_Stream_Input)
5605 and then
5606 not Is_TSS (Prim, TSS_Stream_Output)
70482933 5607 then
dee4682a
JM		 5608 Error_Msg_NE
5609 ("abstract inherited private operation&" &
b2e1beb3 5610 " must be overridden (RM 3.9.3(10))",
dee4682a 5611 Parent (Typ), Prim);
70482933 5612 end if;
dee4682a 5613 end if;
758c442c 5614
dee4682a
JM		 5615 Next_Elmt (Prim_Elmt);
5616 end loop;
70482933 5617
dee4682a 5618 -- Additional check
758c442c 5619
dee4682a
JM		 5620 if Is_Controlled (Typ) then
5621 if not Finalized then
5622 Error_Msg_N
5623 ("controlled type has no explicit Finalize method?", Typ);
70482933 5624
dee4682a
JM		 5625 elsif not Adjusted then
5626 Error_Msg_N
5627 ("controlled type has no explicit Adjust method?", Typ);
70482933 5628 end if;
dee4682a 5629 end if;
70482933 5630
dee4682a 5631 -- Set the final size of the Dispatch Table
758c442c 5632
dee4682a 5633 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
70482933 5634
d0dd5209
JM		 5635 -- The derived type must have at least as many components as its parent
5636 -- (for root types, the Etype points back to itself and the test cannot
5637 -- fail)
758c442c 5638
d0dd5209
JM		 5639 if DT_Entry_Count (The_Tag) <
5640 DT_Entry_Count (First_Tag_Component (Parent_Typ))
5641 then
5642 raise Program_Error;
758c442c 5643 end if;
70482933
RK		 5644 end Set_All_DT_Position;
5645
5646 -----------------------------
5647 -- Set_Default_Constructor --
5648 -----------------------------
5649
5650 procedure Set_Default_Constructor (Typ : Entity_Id) is
5651 Loc : Source_Ptr;
5652 Init : Entity_Id;
5653 Param : Entity_Id;
70482933
RK		 5654 E : Entity_Id;
5655
5656 begin
5657 -- Look for the default constructor entity. For now only the
5658 -- default constructor has the flag Is_Constructor.
5659
5660 E := Next_Entity (Typ);
5661 while Present (E)
5662 and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
5663 loop
5664 Next_Entity (E);
5665 end loop;
5666
5667 -- Create the init procedure
5668
5669 if Present (E) then
5670 Loc := Sloc (E);
fbf5a39b 5671 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
70482933 5672 Param := Make_Defining_Identifier (Loc, Name_X);
fbf5a39b
AC		 5673
5674 Discard_Node (
70482933
RK		 5675 Make_Subprogram_Declaration (Loc,
5676 Make_Procedure_Specification (Loc,
5677 Defining_Unit_Name => Init,
5678 Parameter_Specifications => New_List (
5679 Make_Parameter_Specification (Loc,
5680 Defining_Identifier => Param,
fbf5a39b 5681 Parameter_Type => New_Reference_To (Typ, Loc))))));
70482933
RK		 5682
5683 Set_Init_Proc (Typ, Init);
fbf5a39b 5684 Set_Is_Imported (Init);
70482933 5685 Set_Interface_Name (Init, Interface_Name (E));
fbf5a39b
AC		 5686 Set_Convention (Init, Convention_C);
5687 Set_Is_Public (Init);
70482933
RK		 5688 Set_Has_Completion (Init);
5689
fbf5a39b 5690 -- If there are no constructors, mark the type as abstract since we
70482933
RK		 5691 -- won't be able to declare objects of that type.
5692
5693 else
dee4682a 5694 Set_Is_Abstract_Type (Typ);
70482933
RK		 5695 end if;
5696 end Set_Default_Constructor;
5697
d0dd5209
JM		 5698 --------------------------
5699 -- Set_DTC_Entity_Value --
5700 --------------------------
5701
5702 procedure Set_DTC_Entity_Value
5703 (Tagged_Type : Entity_Id;
5704 Prim : Entity_Id)
5705 is
5706 begin
5707 if Present (Abstract_Interface_Alias (Prim))
5708 and then Is_Interface
5709 (Find_Dispatching_Type
5710 (Abstract_Interface_Alias (Prim)))
5711 then
5712 Set_DTC_Entity (Prim,
5713 Find_Interface_Tag
5714 (T => Tagged_Type,
5715 Iface => Find_Dispatching_Type
5716 (Abstract_Interface_Alias (Prim))));
5717 else
5718 Set_DTC_Entity (Prim,
5719 First_Tag_Component (Tagged_Type));
5720 end if;
5721 end Set_DTC_Entity_Value;
5722
4d744221
JM		 5723 -----------------
5724 -- Tagged_Kind --
5725 -----------------
5726
5727 function Tagged_Kind (T : Entity_Id) return Node_Id is
5728 Conc_Typ : Entity_Id;
5729 Loc : constant Source_Ptr := Sloc (T);
5730
5731 begin
b0efe69e
JM		 5732 pragma Assert
5733 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
4d744221
JM		 5734
5735 -- Abstract kinds
5736
dee4682a 5737 if Is_Abstract_Type (T) then
4d744221
JM		 5738 if Is_Limited_Record (T) then
5739 return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
5740 else
5741 return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
5742 end if;
5743
5744 -- Concurrent kinds
5745
5746 elsif Is_Concurrent_Record_Type (T) then
5747 Conc_Typ := Corresponding_Concurrent_Type (T);
5748
b2e1beb3
ES		 5749 if Present (Full_View (Conc_Typ)) then
5750 Conc_Typ := Full_View (Conc_Typ);
5751 end if;
5752
4d744221
JM		 5753 if Ekind (Conc_Typ) = E_Protected_Type then
5754 return New_Reference_To (RTE (RE_TK_Protected), Loc);
5755 else
5756 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
5757 return New_Reference_To (RTE (RE_TK_Task), Loc);
5758 end if;
5759
5760 -- Regular tagged kinds
5761
5762 else
5763 if Is_Limited_Record (T) then
5764 return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
5765 else
5766 return New_Reference_To (RTE (RE_TK_Tagged), Loc);
5767 end if;
5768 end if;
5769 end Tagged_Kind;
5770
758c442c
GD		 5771 --------------
5772 -- Write_DT --
5773 --------------
5774
5775 procedure Write_DT (Typ : Entity_Id) is
5776 Elmt : Elmt_Id;
5777 Prim : Node_Id;
5778
5779 begin
5780 -- Protect this procedure against wrong usage. Required because it will
5781 -- be used directly from GDB
5782
b2e1beb3 5783 if not (Typ <= Last_Node_Id)
758c442c
GD		 5784 or else not Is_Tagged_Type (Typ)
5785 then
10b93b2e 5786 Write_Str ("wrong usage: Write_DT must be used with tagged types");
758c442c
GD		 5787 Write_Eol;
5788 return;
5789 end if;
5790
5791 Write_Int (Int (Typ));
5792 Write_Str (": ");
5793 Write_Name (Chars (Typ));
5794
5795 if Is_Interface (Typ) then
5796 Write_Str (" is interface");
5797 end if;
5798
5799 Write_Eol;
5800
5801 Elmt := First_Elmt (Primitive_Operations (Typ));
5802 while Present (Elmt) loop
5803 Prim := Node (Elmt);
5804 Write_Str (" - ");
5805
5806 -- Indicate if this primitive will be allocated in the primary
5807 -- dispatch table or in a secondary dispatch table associated
5808 -- with an abstract interface type
5809
5810 if Present (DTC_Entity (Prim)) then
5811 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
5812 Write_Str ("[P] ");
5813 else
5814 Write_Str ("[s] ");
5815 end if;
5816 end if;
5817
5818 -- Output the node of this primitive operation and its name
5819
5820 Write_Int (Int (Prim));
5821 Write_Str (": ");
b0efe69e
JM		 5822
5823 if Is_Predefined_Dispatching_Operation (Prim) then
5824 Write_Str ("(predefined) ");
5825 end if;
5826
758c442c
GD		 5827 Write_Name (Chars (Prim));
5828
5829 -- Indicate if this primitive has an aliased primitive
5830
5831 if Present (Alias (Prim)) then
5832 Write_Str (" (alias = ");
5833 Write_Int (Int (Alias (Prim)));
5834
5835 -- If the DTC_Entity attribute is already set we can also output
5836 -- the name of the interface covered by this primitive (if any)
5837
5838 if Present (DTC_Entity (Alias (Prim)))
5839 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
5840 then
5841 Write_Str (" from interface ");
5842 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
5843 end if;
5844
5845 if Present (Abstract_Interface_Alias (Prim)) then
5846 Write_Str (", AI_Alias of ");
5847 Write_Name (Chars (Scope (DTC_Entity
5848 (Abstract_Interface_Alias (Prim)))));
5849 Write_Char (':');
5850 Write_Int (Int (Abstract_Interface_Alias (Prim)));
5851 end if;
5852
5853 Write_Str (")");
5854 end if;
5855
5856 -- Display the final position of this primitive in its associated
5857 -- (primary or secondary) dispatch table
5858
5859 if Present (DTC_Entity (Prim))
5860 and then DT_Position (Prim) /= No_Uint
5861 then
5862 Write_Str (" at #");
5863 Write_Int (UI_To_Int (DT_Position (Prim)));
5864 end if;
5865
dee4682a 5866 if Is_Abstract_Subprogram (Prim) then
758c442c 5867 Write_Str (" is abstract;");
bfef8d0d
JM		 5868
5869 -- Check if this is a null primitive
5870
5871 elsif Comes_From_Source (Prim)
5872 and then Ekind (Prim) = E_Procedure
5873 and then Null_Present (Parent (Prim))
5874 then
5875 Write_Str (" is null;");
758c442c
GD		 5876 end if;
5877
5878 Write_Eol;
5879
5880 Next_Elmt (Elmt);
5881 end loop;
5882 end Write_DT;
5883
70482933 5884end Exp_Disp;
GNU Compiler Collection
This page took 1.897339 seconds and 5 git commands to generate.