File : exp_disp.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ D I S P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_CG; use Exp_CG;
35 with Exp_Dbug; use Exp_Dbug;
36 with Exp_Tss; use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Freeze; use Freeze;
39 with Ghost; use Ghost;
40 with Itypes; use Itypes;
41 with Layout; use Layout;
42 with Nlists; use Nlists;
43 with Nmake; use Nmake;
44 with Namet; use Namet;
45 with Opt; use Opt;
46 with Output; use Output;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
50 with Sem; use Sem;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch6; use Sem_Ch6;
53 with Sem_Ch7; use Sem_Ch7;
54 with Sem_Ch8; use Sem_Ch8;
55 with Sem_Disp; use Sem_Disp;
56 with Sem_Eval; use Sem_Eval;
57 with Sem_Res; use Sem_Res;
58 with Sem_Type; use Sem_Type;
59 with Sem_Util; use Sem_Util;
60 with Sinfo; use Sinfo;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Stringt; use Stringt;
64 with SCIL_LL; use SCIL_LL;
65 with Tbuild; use Tbuild;
66
67 package body Exp_Disp is
68
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
72
73 function Default_Prim_Op_Position (E : Entity_Id) return Uint;
74 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
75 -- of the default primitive operations.
76
77 function Has_DT (Typ : Entity_Id) return Boolean;
78 pragma Inline (Has_DT);
79 -- Returns true if we generate a dispatch table for tagged type Typ
80
81 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
82 -- Returns true if Prim is not a predefined dispatching primitive but it is
83 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
84
85 function New_Value (From : Node_Id) return Node_Id;
86 -- From is the original Expression. New_Value is equivalent to a call to
87 -- Duplicate_Subexpr with an explicit dereference when From is an access
88 -- parameter.
89
90 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
91 -- Check if the type has a private view or if the public view appears in
92 -- the visible part of a package spec.
93
94 function Prim_Op_Kind
95 (Prim : Entity_Id;
96 Typ : Entity_Id) return Node_Id;
97 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
98 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
99 -- enumeration value.
100
101 function Tagged_Kind (T : Entity_Id) return Node_Id;
102 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
103 -- to an RE_Tagged_Kind enumeration value.
104
105 ----------------------
106 -- Apply_Tag_Checks --
107 ----------------------
108
109 procedure Apply_Tag_Checks (Call_Node : Node_Id) is
110 Loc : constant Source_Ptr := Sloc (Call_Node);
111 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
112 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
113 Param_List : constant List_Id := Parameter_Associations (Call_Node);
114
115 Subp : Entity_Id;
116 CW_Typ : Entity_Id;
117 Param : Node_Id;
118 Typ : Entity_Id;
119 Eq_Prim_Op : Entity_Id := Empty;
120
121 begin
122 if No_Run_Time_Mode then
123 Error_Msg_CRT ("tagged types", Call_Node);
124 return;
125 end if;
126
127 -- Apply_Tag_Checks is called directly from the semantics, so we
128 -- need a check to see whether expansion is active before proceeding.
129 -- In addition, there is no need to expand the call when compiling
130 -- under restriction No_Dispatching_Calls; the semantic analyzer has
131 -- previously notified the violation of this restriction.
132
133 if not Expander_Active
134 or else Restriction_Active (No_Dispatching_Calls)
135 then
136 return;
137 end if;
138
139 -- Set subprogram. If this is an inherited operation that was
140 -- overridden, the body that is being called is its alias.
141
142 Subp := Entity (Name (Call_Node));
143
144 if Present (Alias (Subp))
145 and then Is_Inherited_Operation (Subp)
146 and then No (DTC_Entity (Subp))
147 then
148 Subp := Alias (Subp);
149 end if;
150
151 -- Definition of the class-wide type and the tagged type
152
153 -- If the controlling argument is itself a tag rather than a tagged
154 -- object, then use the class-wide type associated with the subprogram's
155 -- controlling type. This case can occur when a call to an inherited
156 -- primitive has an actual that originated from a default parameter
157 -- given by a tag-indeterminate call and when there is no other
158 -- controlling argument providing the tag (AI-239 requires dispatching).
159 -- This capability of dispatching directly by tag is also needed by the
160 -- implementation of AI-260 (for the generic dispatching constructors).
161
162 if Ctrl_Typ = RTE (RE_Tag)
163 or else (RTE_Available (RE_Interface_Tag)
164 and then Ctrl_Typ = RTE (RE_Interface_Tag))
165 then
166 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
167
168 -- Class_Wide_Type is applied to the expressions used to initialize
169 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
170 -- there are cases where the controlling type is resolved to a specific
171 -- type (such as for designated types of arguments such as CW'Access).
172
173 elsif Is_Access_Type (Ctrl_Typ) then
174 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
175
176 else
177 CW_Typ := Class_Wide_Type (Ctrl_Typ);
178 end if;
179
180 Typ := Find_Specific_Type (CW_Typ);
181
182 if not Is_Limited_Type (Typ) then
183 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
184 end if;
185
186 -- Dispatching call to C++ primitive
187
188 if Is_CPP_Class (Typ) then
189 null;
190
191 -- Dispatching call to Ada primitive
192
193 elsif Present (Param_List) then
194
195 -- Generate the Tag checks when appropriate
196
197 Param := First_Actual (Call_Node);
198 while Present (Param) loop
199
200 -- No tag check with itself
201
202 if Param = Ctrl_Arg then
203 null;
204
205 -- No tag check for parameter whose type is neither tagged nor
206 -- access to tagged (for access parameters)
207
208 elsif No (Find_Controlling_Arg (Param)) then
209 null;
210
211 -- No tag check for function dispatching on result if the
212 -- Tag given by the context is this one
213
214 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
215 null;
216
217 -- "=" is the only dispatching operation allowed to get operands
218 -- with incompatible tags (it just returns false). We use
219 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
220 -- because the value will be duplicated to check the tags.
221
222 elsif Subp = Eq_Prim_Op then
223 null;
224
225 -- No check in presence of suppress flags
226
227 elsif Tag_Checks_Suppressed (Etype (Param))
228 or else (Is_Access_Type (Etype (Param))
229 and then Tag_Checks_Suppressed
230 (Designated_Type (Etype (Param))))
231 then
232 null;
233
234 -- Optimization: no tag checks if the parameters are identical
235
236 elsif Is_Entity_Name (Param)
237 and then Is_Entity_Name (Ctrl_Arg)
238 and then Entity (Param) = Entity (Ctrl_Arg)
239 then
240 null;
241
242 -- Now we need to generate the Tag check
243
244 else
245 -- Generate code for tag equality check
246
247 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
248
249 Insert_Action (Ctrl_Arg,
250 Make_Implicit_If_Statement (Call_Node,
251 Condition =>
252 Make_Op_Ne (Loc,
253 Left_Opnd =>
254 Make_Selected_Component (Loc,
255 Prefix => New_Value (Ctrl_Arg),
256 Selector_Name =>
257 New_Occurrence_Of
258 (First_Tag_Component (Typ), Loc)),
259
260 Right_Opnd =>
261 Make_Selected_Component (Loc,
262 Prefix =>
263 Unchecked_Convert_To (Typ, New_Value (Param)),
264 Selector_Name =>
265 New_Occurrence_Of
266 (First_Tag_Component (Typ), Loc))),
267
268 Then_Statements =>
269 New_List (New_Constraint_Error (Loc))));
270 end if;
271
272 Next_Actual (Param);
273 end loop;
274 end if;
275 end Apply_Tag_Checks;
276
277 ------------------------
278 -- Building_Static_DT --
279 ------------------------
280
281 function Building_Static_DT (Typ : Entity_Id) return Boolean is
282 Root_Typ : Entity_Id := Root_Type (Typ);
283
284 begin
285 -- Handle private types
286
287 if Present (Full_View (Root_Typ)) then
288 Root_Typ := Full_View (Root_Typ);
289 end if;
290
291 return Static_Dispatch_Tables
292 and then Is_Library_Level_Tagged_Type (Typ)
293
294 -- If the type is derived from a CPP class we cannot statically
295 -- build the dispatch tables because we must inherit primitives
296 -- from the CPP side.
297
298 and then not Is_CPP_Class (Root_Typ);
299 end Building_Static_DT;
300
301 ----------------------------------
302 -- Build_Static_Dispatch_Tables --
303 ----------------------------------
304
305 procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
306 Target_List : List_Id;
307
308 procedure Build_Dispatch_Tables (List : List_Id);
309 -- Build the static dispatch table of tagged types found in the list of
310 -- declarations. The generated nodes are added at the end of Target_List
311
312 procedure Build_Package_Dispatch_Tables (N : Node_Id);
313 -- Build static dispatch tables associated with package declaration N
314
315 ---------------------------
316 -- Build_Dispatch_Tables --
317 ---------------------------
318
319 procedure Build_Dispatch_Tables (List : List_Id) is
320 D : Node_Id;
321
322 begin
323 D := First (List);
324 while Present (D) loop
325
326 -- Handle nested packages and package bodies recursively. The
327 -- generated code is placed on the Target_List established for
328 -- the enclosing compilation unit.
329
330 if Nkind (D) = N_Package_Declaration then
331 Build_Package_Dispatch_Tables (D);
332
333 elsif Nkind (D) = N_Package_Body then
334 Build_Dispatch_Tables (Declarations (D));
335
336 elsif Nkind (D) = N_Package_Body_Stub
337 and then Present (Library_Unit (D))
338 then
339 Build_Dispatch_Tables
340 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
341
342 -- Handle full type declarations and derivations of library level
343 -- tagged types
344
345 elsif Nkind_In (D, N_Full_Type_Declaration,
346 N_Derived_Type_Definition)
347 and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
348 and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
349 and then not Is_Private_Type (Defining_Entity (D))
350 then
351 -- We do not generate dispatch tables for the internal types
352 -- created for a type extension with unknown discriminants
353 -- The needed information is shared with the source type,
354 -- See Expand_N_Record_Extension.
355
356 if Is_Underlying_Record_View (Defining_Entity (D))
357 or else
358 (not Comes_From_Source (Defining_Entity (D))
359 and then
360 Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
361 and then
362 not Comes_From_Source
363 (First_Subtype (Defining_Entity (D))))
364 then
365 null;
366 else
367 Insert_List_After_And_Analyze (Last (Target_List),
368 Make_DT (Defining_Entity (D)));
369 end if;
370
371 -- Handle private types of library level tagged types. We must
372 -- exchange the private and full-view to ensure the correct
373 -- expansion. If the full view is a synchronized type ignore
374 -- the type because the table will be built for the corresponding
375 -- record type, that has its own declaration.
376
377 elsif (Nkind (D) = N_Private_Type_Declaration
378 or else Nkind (D) = N_Private_Extension_Declaration)
379 and then Present (Full_View (Defining_Entity (D)))
380 then
381 declare
382 E1 : constant Entity_Id := Defining_Entity (D);
383 E2 : constant Entity_Id := Full_View (E1);
384
385 begin
386 if Is_Library_Level_Tagged_Type (E2)
387 and then Ekind (E2) /= E_Record_Subtype
388 and then not Is_Concurrent_Type (E2)
389 then
390 Exchange_Declarations (E1);
391 Insert_List_After_And_Analyze (Last (Target_List),
392 Make_DT (E1));
393 Exchange_Declarations (E2);
394 end if;
395 end;
396 end if;
397
398 Next (D);
399 end loop;
400 end Build_Dispatch_Tables;
401
402 -----------------------------------
403 -- Build_Package_Dispatch_Tables --
404 -----------------------------------
405
406 procedure Build_Package_Dispatch_Tables (N : Node_Id) is
407 Spec : constant Node_Id := Specification (N);
408 Id : constant Entity_Id := Defining_Entity (N);
409 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
410 Priv_Decls : constant List_Id := Private_Declarations (Spec);
411
412 begin
413 Push_Scope (Id);
414
415 if Present (Priv_Decls) then
416 Build_Dispatch_Tables (Vis_Decls);
417 Build_Dispatch_Tables (Priv_Decls);
418
419 elsif Present (Vis_Decls) then
420 Build_Dispatch_Tables (Vis_Decls);
421 end if;
422
423 Pop_Scope;
424 end Build_Package_Dispatch_Tables;
425
426 -- Start of processing for Build_Static_Dispatch_Tables
427
428 begin
429 if not Expander_Active
430 or else not Tagged_Type_Expansion
431 then
432 return;
433 end if;
434
435 if Nkind (N) = N_Package_Declaration then
436 declare
437 Spec : constant Node_Id := Specification (N);
438 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
439 Priv_Decls : constant List_Id := Private_Declarations (Spec);
440
441 begin
442 if Present (Priv_Decls)
443 and then Is_Non_Empty_List (Priv_Decls)
444 then
445 Target_List := Priv_Decls;
446
447 elsif not Present (Vis_Decls) then
448 Target_List := New_List;
449 Set_Private_Declarations (Spec, Target_List);
450 else
451 Target_List := Vis_Decls;
452 end if;
453
454 Build_Package_Dispatch_Tables (N);
455 end;
456
457 else pragma Assert (Nkind (N) = N_Package_Body);
458 Target_List := Declarations (N);
459 Build_Dispatch_Tables (Target_List);
460 end if;
461 end Build_Static_Dispatch_Tables;
462
463 ------------------------------
464 -- Convert_Tag_To_Interface --
465 ------------------------------
466
467 function Convert_Tag_To_Interface
468 (Typ : Entity_Id;
469 Expr : Node_Id) return Node_Id
470 is
471 Loc : constant Source_Ptr := Sloc (Expr);
472 Anon_Type : Entity_Id;
473 Result : Node_Id;
474
475 begin
476 pragma Assert (Is_Class_Wide_Type (Typ)
477 and then Is_Interface (Typ)
478 and then
479 ((Nkind (Expr) = N_Selected_Component
480 and then Is_Tag (Entity (Selector_Name (Expr))))
481 or else
482 (Nkind (Expr) = N_Function_Call
483 and then RTE_Available (RE_Displace)
484 and then Entity (Name (Expr)) = RTE (RE_Displace))));
485
486 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
487 Set_Directly_Designated_Type (Anon_Type, Typ);
488 Set_Etype (Anon_Type, Anon_Type);
489 Set_Can_Never_Be_Null (Anon_Type);
490
491 -- Decorate the size and alignment attributes of the anonymous access
492 -- type, as required by the back end.
493
494 Layout_Type (Anon_Type);
495
496 if Nkind (Expr) = N_Selected_Component
497 and then Is_Tag (Entity (Selector_Name (Expr)))
498 then
499 Result :=
500 Make_Explicit_Dereference (Loc,
501 Unchecked_Convert_To (Anon_Type,
502 Make_Attribute_Reference (Loc,
503 Prefix => Expr,
504 Attribute_Name => Name_Address)));
505 else
506 Result :=
507 Make_Explicit_Dereference (Loc,
508 Unchecked_Convert_To (Anon_Type, Expr));
509 end if;
510
511 return Result;
512 end Convert_Tag_To_Interface;
513
514 -------------------
515 -- CPP_Num_Prims --
516 -------------------
517
518 function CPP_Num_Prims (Typ : Entity_Id) return Nat is
519 CPP_Typ : Entity_Id;
520 Tag_Comp : Entity_Id;
521
522 begin
523 if not Is_Tagged_Type (Typ)
524 or else not Is_CPP_Class (Root_Type (Typ))
525 then
526 return 0;
527
528 else
529 CPP_Typ := Enclosing_CPP_Parent (Typ);
530 Tag_Comp := First_Tag_Component (CPP_Typ);
531
532 -- If number of primitives already set in the tag component, use it
533
534 if Present (Tag_Comp)
535 and then DT_Entry_Count (Tag_Comp) /= No_Uint
536 then
537 return UI_To_Int (DT_Entry_Count (Tag_Comp));
538
539 -- Otherwise, count the primitives of the enclosing CPP type
540
541 else
542 declare
543 Count : Nat := 0;
544 Elmt : Elmt_Id;
545
546 begin
547 Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
548 while Present (Elmt) loop
549 Count := Count + 1;
550 Next_Elmt (Elmt);
551 end loop;
552
553 return Count;
554 end;
555 end if;
556 end if;
557 end CPP_Num_Prims;
558
559 ------------------------------
560 -- Default_Prim_Op_Position --
561 ------------------------------
562
563 function Default_Prim_Op_Position (E : Entity_Id) return Uint is
564 TSS_Name : TSS_Name_Type;
565
566 begin
567 Get_Name_String (Chars (E));
568 TSS_Name :=
569 TSS_Name_Type
570 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
571
572 if Chars (E) = Name_uSize then
573 return Uint_1;
574
575 elsif TSS_Name = TSS_Stream_Read then
576 return Uint_2;
577
578 elsif TSS_Name = TSS_Stream_Write then
579 return Uint_3;
580
581 elsif TSS_Name = TSS_Stream_Input then
582 return Uint_4;
583
584 elsif TSS_Name = TSS_Stream_Output then
585 return Uint_5;
586
587 elsif Chars (E) = Name_Op_Eq then
588 return Uint_6;
589
590 elsif Chars (E) = Name_uAssign then
591 return Uint_7;
592
593 elsif TSS_Name = TSS_Deep_Adjust then
594 return Uint_8;
595
596 elsif TSS_Name = TSS_Deep_Finalize then
597 return Uint_9;
598
599 -- In VM targets unconditionally allow obtaining the position associated
600 -- with predefined interface primitives since in these platforms any
601 -- tagged type has these primitives.
602
603 elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
604 if Chars (E) = Name_uDisp_Asynchronous_Select then
605 return Uint_10;
606
607 elsif Chars (E) = Name_uDisp_Conditional_Select then
608 return Uint_11;
609
610 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
611 return Uint_12;
612
613 elsif Chars (E) = Name_uDisp_Get_Task_Id then
614 return Uint_13;
615
616 elsif Chars (E) = Name_uDisp_Requeue then
617 return Uint_14;
618
619 elsif Chars (E) = Name_uDisp_Timed_Select then
620 return Uint_15;
621 end if;
622 end if;
623
624 raise Program_Error;
625 end Default_Prim_Op_Position;
626
627 -----------------------------
628 -- Expand_Dispatching_Call --
629 -----------------------------
630
631 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
632 Loc : constant Source_Ptr := Sloc (Call_Node);
633 Call_Typ : constant Entity_Id := Etype (Call_Node);
634
635 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
636 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
637 Param_List : constant List_Id := Parameter_Associations (Call_Node);
638
639 Subp : Entity_Id;
640 CW_Typ : Entity_Id;
641 New_Call : Node_Id;
642 New_Call_Name : Node_Id;
643 New_Params : List_Id := No_List;
644 Param : Node_Id;
645 Res_Typ : Entity_Id;
646 Subp_Ptr_Typ : Entity_Id;
647 Subp_Typ : Entity_Id;
648 Typ : Entity_Id;
649 Eq_Prim_Op : Entity_Id := Empty;
650 Controlling_Tag : Node_Id;
651
652 function New_Value (From : Node_Id) return Node_Id;
653 -- From is the original Expression. New_Value is equivalent to a call
654 -- to Duplicate_Subexpr with an explicit dereference when From is an
655 -- access parameter.
656
657 ---------------
658 -- New_Value --
659 ---------------
660
661 function New_Value (From : Node_Id) return Node_Id is
662 Res : constant Node_Id := Duplicate_Subexpr (From);
663 begin
664 if Is_Access_Type (Etype (From)) then
665 return
666 Make_Explicit_Dereference (Sloc (From),
667 Prefix => Res);
668 else
669 return Res;
670 end if;
671 end New_Value;
672
673 -- Local variables
674
675 New_Node : Node_Id;
676 SCIL_Node : Node_Id;
677 SCIL_Related_Node : Node_Id := Call_Node;
678
679 -- Start of processing for Expand_Dispatching_Call
680
681 begin
682 if No_Run_Time_Mode then
683 Error_Msg_CRT ("tagged types", Call_Node);
684 return;
685 end if;
686
687 -- Expand_Dispatching_Call is called directly from the semantics, so we
688 -- only proceed if the expander is active.
689
690 if not Expander_Active
691
692 -- And there is no need to expand the call if we are compiling under
693 -- restriction No_Dispatching_Calls; the semantic analyzer has
694 -- previously notified the violation of this restriction.
695
696 or else Restriction_Active (No_Dispatching_Calls)
697
698 -- No action needed if the dispatching call has been already expanded
699
700 or else Is_Expanded_Dispatching_Call (Name (Call_Node))
701 then
702 return;
703 end if;
704
705 -- Set subprogram. If this is an inherited operation that was
706 -- overridden, the body that is being called is its alias.
707
708 Subp := Entity (Name (Call_Node));
709
710 if Present (Alias (Subp))
711 and then Is_Inherited_Operation (Subp)
712 and then No (DTC_Entity (Subp))
713 then
714 Subp := Alias (Subp);
715 end if;
716
717 -- Definition of the class-wide type and the tagged type
718
719 -- If the controlling argument is itself a tag rather than a tagged
720 -- object, then use the class-wide type associated with the subprogram's
721 -- controlling type. This case can occur when a call to an inherited
722 -- primitive has an actual that originated from a default parameter
723 -- given by a tag-indeterminate call and when there is no other
724 -- controlling argument providing the tag (AI-239 requires dispatching).
725 -- This capability of dispatching directly by tag is also needed by the
726 -- implementation of AI-260 (for the generic dispatching constructors).
727
728 if Ctrl_Typ = RTE (RE_Tag)
729 or else (RTE_Available (RE_Interface_Tag)
730 and then Ctrl_Typ = RTE (RE_Interface_Tag))
731 then
732 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
733
734 -- Class_Wide_Type is applied to the expressions used to initialize
735 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
736 -- there are cases where the controlling type is resolved to a specific
737 -- type (such as for designated types of arguments such as CW'Access).
738
739 elsif Is_Access_Type (Ctrl_Typ) then
740 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
741
742 else
743 CW_Typ := Class_Wide_Type (Ctrl_Typ);
744 end if;
745
746 Typ := Find_Specific_Type (CW_Typ);
747
748 if not Is_Limited_Type (Typ) then
749 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
750 end if;
751
752 -- Dispatching call to C++ primitive. Create a new parameter list
753 -- with no tag checks.
754
755 New_Params := New_List;
756
757 if Is_CPP_Class (Typ) then
758 Param := First_Actual (Call_Node);
759 while Present (Param) loop
760 Append_To (New_Params, Relocate_Node (Param));
761 Next_Actual (Param);
762 end loop;
763
764 -- Dispatching call to Ada primitive
765
766 elsif Present (Param_List) then
767 Apply_Tag_Checks (Call_Node);
768
769 Param := First_Actual (Call_Node);
770 while Present (Param) loop
771
772 -- Cases in which we may have generated run-time checks. Note that
773 -- we strip any qualification from Param before comparing with the
774 -- already-stripped controlling argument.
775
776 if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then
777 Append_To (New_Params,
778 Duplicate_Subexpr_Move_Checks (Param));
779
780 elsif Nkind (Parent (Param)) /= N_Parameter_Association
781 or else not Is_Accessibility_Actual (Parent (Param))
782 then
783 Append_To (New_Params, Relocate_Node (Param));
784 end if;
785
786 Next_Actual (Param);
787 end loop;
788 end if;
789
790 -- Generate the appropriate subprogram pointer type
791
792 if Etype (Subp) = Typ then
793 Res_Typ := CW_Typ;
794 else
795 Res_Typ := Etype (Subp);
796 end if;
797
798 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
799 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
800 Set_Etype (Subp_Typ, Res_Typ);
801 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
802 Set_Convention (Subp_Typ, Convention (Subp));
803
804 -- Notify gigi that the designated type is a dispatching primitive
805
806 Set_Is_Dispatch_Table_Entity (Subp_Typ);
807
808 -- Create a new list of parameters which is a copy of the old formal
809 -- list including the creation of a new set of matching entities.
810
811 declare
812 Old_Formal : Entity_Id := First_Formal (Subp);
813 New_Formal : Entity_Id;
814 Extra : Entity_Id := Empty;
815
816 begin
817 if Present (Old_Formal) then
818 New_Formal := New_Copy (Old_Formal);
819 Set_First_Entity (Subp_Typ, New_Formal);
820 Param := First_Actual (Call_Node);
821
822 loop
823 Set_Scope (New_Formal, Subp_Typ);
824
825 -- Change all the controlling argument types to be class-wide
826 -- to avoid a recursion in dispatching.
827
828 if Is_Controlling_Formal (New_Formal) then
829 Set_Etype (New_Formal, Etype (Param));
830 end if;
831
832 -- If the type of the formal is an itype, there was code here
833 -- introduced in 1998 in revision 1.46, to create a new itype
834 -- by copy. This seems useless, and in fact leads to semantic
835 -- errors when the itype is the completion of a type derived
836 -- from a private type.
837
838 Extra := New_Formal;
839 Next_Formal (Old_Formal);
840 exit when No (Old_Formal);
841
842 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
843 Next_Entity (New_Formal);
844 Next_Actual (Param);
845 end loop;
846
847 Set_Next_Entity (New_Formal, Empty);
848 Set_Last_Entity (Subp_Typ, Extra);
849 end if;
850
851 -- Now that the explicit formals have been duplicated, any extra
852 -- formals needed by the subprogram must be created.
853
854 if Present (Extra) then
855 Set_Extra_Formal (Extra, Empty);
856 end if;
857
858 Create_Extra_Formals (Subp_Typ);
859 end;
860
861 -- Complete description of pointer type, including size information, as
862 -- must be done with itypes to prevent order-of-elaboration anomalies
863 -- in gigi.
864
865 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
866 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
867 Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
868 Layout_Type (Subp_Ptr_Typ);
869
870 -- If the controlling argument is a value of type Ada.Tag or an abstract
871 -- interface class-wide type then use it directly. Otherwise, the tag
872 -- must be extracted from the controlling object.
873
874 if Ctrl_Typ = RTE (RE_Tag)
875 or else (RTE_Available (RE_Interface_Tag)
876 and then Ctrl_Typ = RTE (RE_Interface_Tag))
877 then
878 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
879
880 -- Extract the tag from an unchecked type conversion. Done to avoid
881 -- the expansion of additional code just to obtain the value of such
882 -- tag because the current management of interface type conversions
883 -- generates in some cases this unchecked type conversion with the
884 -- tag of the object (see Expand_Interface_Conversion).
885
886 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
887 and then
888 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
889 or else
890 (RTE_Available (RE_Interface_Tag)
891 and then
892 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
893 then
894 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
895
896 -- Ada 2005 (AI-251): Abstract interface class-wide type
897
898 elsif Is_Interface (Ctrl_Typ)
899 and then Is_Class_Wide_Type (Ctrl_Typ)
900 then
901 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
902
903 else
904 Controlling_Tag :=
905 Make_Selected_Component (Loc,
906 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
907 Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
908 end if;
909
910 -- Handle dispatching calls to predefined primitives
911
912 if Is_Predefined_Dispatching_Operation (Subp)
913 or else Is_Predefined_Dispatching_Alias (Subp)
914 then
915 Build_Get_Predefined_Prim_Op_Address (Loc,
916 Tag_Node => Controlling_Tag,
917 Position => DT_Position (Subp),
918 New_Node => New_Node);
919
920 -- Handle dispatching calls to user-defined primitives
921
922 else
923 Build_Get_Prim_Op_Address (Loc,
924 Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
925 Tag_Node => Controlling_Tag,
926 Position => DT_Position (Subp),
927 New_Node => New_Node);
928 end if;
929
930 New_Call_Name :=
931 Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
932
933 -- Generate the SCIL node for this dispatching call. Done now because
934 -- attribute SCIL_Controlling_Tag must be set after the new call name
935 -- is built to reference the nodes that will see the SCIL backend
936 -- (because Build_Get_Prim_Op_Address generates an unchecked type
937 -- conversion which relocates the controlling tag node).
938
939 if Generate_SCIL then
940 SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
941 Set_SCIL_Entity (SCIL_Node, Typ);
942 Set_SCIL_Target_Prim (SCIL_Node, Subp);
943
944 -- Common case: the controlling tag is the tag of an object
945 -- (for example, obj.tag)
946
947 if Nkind (Controlling_Tag) = N_Selected_Component then
948 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
949
950 -- Handle renaming of selected component
951
952 elsif Nkind (Controlling_Tag) = N_Identifier
953 and then Nkind (Parent (Entity (Controlling_Tag))) =
954 N_Object_Renaming_Declaration
955 and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
956 N_Selected_Component
957 then
958 Set_SCIL_Controlling_Tag (SCIL_Node,
959 Name (Parent (Entity (Controlling_Tag))));
960
961 -- If the controlling tag is an identifier, the SCIL node references
962 -- the corresponding object or parameter declaration
963
964 elsif Nkind (Controlling_Tag) = N_Identifier
965 and then Nkind_In (Parent (Entity (Controlling_Tag)),
966 N_Object_Declaration,
967 N_Parameter_Specification)
968 then
969 Set_SCIL_Controlling_Tag (SCIL_Node,
970 Parent (Entity (Controlling_Tag)));
971
972 -- If the controlling tag is a dereference, the SCIL node references
973 -- the corresponding object or parameter declaration
974
975 elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
976 and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
977 and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
978 N_Object_Declaration,
979 N_Parameter_Specification)
980 then
981 Set_SCIL_Controlling_Tag (SCIL_Node,
982 Parent (Entity (Prefix (Controlling_Tag))));
983
984 -- For a direct reference of the tag of the type the SCIL node
985 -- references the internal object declaration containing the tag
986 -- of the type.
987
988 elsif Nkind (Controlling_Tag) = N_Attribute_Reference
989 and then Attribute_Name (Controlling_Tag) = Name_Tag
990 then
991 Set_SCIL_Controlling_Tag (SCIL_Node,
992 Parent
993 (Node
994 (First_Elmt
995 (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
996
997 -- Interfaces are not supported. For now we leave the SCIL node
998 -- decorated with the Controlling_Tag. More work needed here???
999
1000 elsif Is_Interface (Etype (Controlling_Tag)) then
1001 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1002
1003 else
1004 pragma Assert (False);
1005 null;
1006 end if;
1007 end if;
1008
1009 if Nkind (Call_Node) = N_Function_Call then
1010 New_Call :=
1011 Make_Function_Call (Loc,
1012 Name => New_Call_Name,
1013 Parameter_Associations => New_Params);
1014
1015 -- If this is a dispatching "=", we must first compare the tags so
1016 -- we generate: x.tag = y.tag and then x = y
1017
1018 if Subp = Eq_Prim_Op then
1019 Param := First_Actual (Call_Node);
1020 New_Call :=
1021 Make_And_Then (Loc,
1022 Left_Opnd =>
1023 Make_Op_Eq (Loc,
1024 Left_Opnd =>
1025 Make_Selected_Component (Loc,
1026 Prefix => New_Value (Param),
1027 Selector_Name =>
1028 New_Occurrence_Of (First_Tag_Component (Typ),
1029 Loc)),
1030
1031 Right_Opnd =>
1032 Make_Selected_Component (Loc,
1033 Prefix =>
1034 Unchecked_Convert_To (Typ,
1035 New_Value (Next_Actual (Param))),
1036 Selector_Name =>
1037 New_Occurrence_Of
1038 (First_Tag_Component (Typ), Loc))),
1039 Right_Opnd => New_Call);
1040
1041 SCIL_Related_Node := Right_Opnd (New_Call);
1042 end if;
1043
1044 else
1045 New_Call :=
1046 Make_Procedure_Call_Statement (Loc,
1047 Name => New_Call_Name,
1048 Parameter_Associations => New_Params);
1049 end if;
1050
1051 -- Register the dispatching call in the call graph nodes table
1052
1053 Register_CG_Node (Call_Node);
1054
1055 Rewrite (Call_Node, New_Call);
1056
1057 -- Associate the SCIL node of this dispatching call
1058
1059 if Generate_SCIL then
1060 Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1061 end if;
1062
1063 -- Suppress all checks during the analysis of the expanded code to avoid
1064 -- the generation of spurious warnings under ZFP run-time.
1065
1066 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1067 end Expand_Dispatching_Call;
1068
1069 ---------------------------------
1070 -- Expand_Interface_Conversion --
1071 ---------------------------------
1072
1073 procedure Expand_Interface_Conversion (N : Node_Id) is
1074 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
1075 -- Return the underlying record type of Typ.
1076
1077 ----------------------------
1078 -- Underlying_Record_Type --
1079 ----------------------------
1080
1081 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is
1082 E : Entity_Id := Typ;
1083
1084 begin
1085 -- Handle access to class-wide interface types
1086
1087 if Is_Access_Type (E) then
1088 E := Etype (Directly_Designated_Type (E));
1089 end if;
1090
1091 -- Handle class-wide types. This conversion can appear explicitly in
1092 -- the source code. Example: I'Class (Obj)
1093
1094 if Is_Class_Wide_Type (E) then
1095 E := Root_Type (E);
1096 end if;
1097
1098 -- If the target type is a tagged synchronized type, the dispatch
1099 -- table info is in the corresponding record type.
1100
1101 if Is_Concurrent_Type (E) then
1102 E := Corresponding_Record_Type (E);
1103 end if;
1104
1105 -- Handle private types
1106
1107 E := Underlying_Type (E);
1108
1109 -- Handle subtypes
1110
1111 return Base_Type (E);
1112 end Underlying_Record_Type;
1113
1114 -- Local variables
1115
1116 Loc : constant Source_Ptr := Sloc (N);
1117 Etyp : constant Entity_Id := Etype (N);
1118 Operand : constant Node_Id := Expression (N);
1119 Operand_Typ : Entity_Id := Etype (Operand);
1120 Func : Node_Id;
1121 Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N));
1122 Iface_Tag : Entity_Id;
1123 Is_Static : Boolean;
1124
1125 -- Start of processing for Expand_Interface_Conversion
1126
1127 begin
1128 -- Freeze the entity associated with the target interface to have
1129 -- available the attribute Access_Disp_Table.
1130
1131 Freeze_Before (N, Iface_Typ);
1132
1133 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1134
1135 if Is_Concurrent_Type (Operand_Typ) then
1136 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1137 end if;
1138
1139 -- No displacement of the pointer to the object needed when the type of
1140 -- the operand is not an interface type and the interface is one of
1141 -- its parent types (since they share the primary dispatch table).
1142
1143 declare
1144 Opnd : Entity_Id := Operand_Typ;
1145
1146 begin
1147 if Is_Access_Type (Opnd) then
1148 Opnd := Designated_Type (Opnd);
1149 end if;
1150
1151 if not Is_Interface (Opnd)
1152 and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
1153 then
1154 return;
1155 end if;
1156 end;
1157
1158 -- Evaluate if we can statically displace the pointer to the object
1159
1160 declare
1161 Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
1162
1163 begin
1164 Is_Static :=
1165 not Is_Interface (Opnd_Typ)
1166 and then Interface_Present_In_Ancestor
1167 (Typ => Opnd_Typ,
1168 Iface => Iface_Typ)
1169 and then (Etype (Opnd_Typ) = Opnd_Typ
1170 or else not
1171 Is_Variable_Size_Record (Etype (Opnd_Typ)));
1172 end;
1173
1174 if not Tagged_Type_Expansion then
1175 return;
1176
1177 -- A static conversion to an interface type that is not classwide is
1178 -- curious but legal if the interface operation is a null procedure.
1179 -- If the operation is abstract it will be rejected later.
1180
1181 elsif Is_Static
1182 and then Is_Interface (Etype (N))
1183 and then not Is_Class_Wide_Type (Etype (N))
1184 and then Comes_From_Source (N)
1185 then
1186 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1187 Analyze (N);
1188 return;
1189 end if;
1190
1191 if not Is_Static then
1192
1193 -- Give error if configurable run time and Displace not available
1194
1195 if not RTE_Available (RE_Displace) then
1196 Error_Msg_CRT ("dynamic interface conversion", N);
1197 return;
1198 end if;
1199
1200 -- Handle conversion of access-to-class-wide interface types. Target
1201 -- can be an access to an object or an access to another class-wide
1202 -- interface (see -1- and -2- in the following example):
1203
1204 -- type Iface1_Ref is access all Iface1'Class;
1205 -- type Iface2_Ref is access all Iface1'Class;
1206
1207 -- Acc1 : Iface1_Ref := new ...
1208 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1209 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1210
1211 if Is_Access_Type (Operand_Typ) then
1212 Rewrite (N,
1213 Unchecked_Convert_To (Etype (N),
1214 Make_Function_Call (Loc,
1215 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1216 Parameter_Associations => New_List (
1217
1218 Unchecked_Convert_To (RTE (RE_Address),
1219 Relocate_Node (Expression (N))),
1220
1221 New_Occurrence_Of
1222 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1223 Loc)))));
1224
1225 Analyze (N);
1226 return;
1227 end if;
1228
1229 Rewrite (N,
1230 Make_Function_Call (Loc,
1231 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1232 Parameter_Associations => New_List (
1233 Make_Attribute_Reference (Loc,
1234 Prefix => Relocate_Node (Expression (N)),
1235 Attribute_Name => Name_Address),
1236
1237 New_Occurrence_Of
1238 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1239 Loc))));
1240
1241 Analyze (N);
1242
1243 -- If target is a class-wide interface, change the type of the data
1244 -- returned by IW_Convert to indicate this is a dispatching call.
1245
1246 declare
1247 New_Itype : Entity_Id;
1248
1249 begin
1250 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1251 Set_Etype (New_Itype, New_Itype);
1252 Set_Directly_Designated_Type (New_Itype, Etyp);
1253
1254 Rewrite (N,
1255 Make_Explicit_Dereference (Loc,
1256 Prefix =>
1257 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1258 Analyze (N);
1259 Freeze_Itype (New_Itype, N);
1260
1261 return;
1262 end;
1263 end if;
1264
1265 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1266 pragma Assert (Iface_Tag /= Empty);
1267
1268 -- Keep separate access types to interfaces because one internal
1269 -- function is used to handle the null value (see following comments)
1270
1271 if not Is_Access_Type (Etype (N)) then
1272
1273 -- Statically displace the pointer to the object to reference the
1274 -- component containing the secondary dispatch table.
1275
1276 Rewrite (N,
1277 Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1278 Make_Selected_Component (Loc,
1279 Prefix => Relocate_Node (Expression (N)),
1280 Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1281
1282 else
1283 -- Build internal function to handle the case in which the actual is
1284 -- null. If the actual is null returns null because no displacement
1285 -- is required; otherwise performs a type conversion that will be
1286 -- expanded in the code that returns the value of the displaced
1287 -- actual. That is:
1288
1289 -- function Func (O : Address) return Iface_Typ is
1290 -- type Op_Typ is access all Operand_Typ;
1291 -- Aux : Op_Typ := To_Op_Typ (O);
1292 -- begin
1293 -- if O = Null_Address then
1294 -- return null;
1295 -- else
1296 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1297 -- end if;
1298 -- end Func;
1299
1300 declare
1301 Desig_Typ : Entity_Id;
1302 Fent : Entity_Id;
1303 New_Typ_Decl : Node_Id;
1304 Stats : List_Id;
1305
1306 begin
1307 Desig_Typ := Etype (Expression (N));
1308
1309 if Is_Access_Type (Desig_Typ) then
1310 Desig_Typ :=
1311 Available_View (Directly_Designated_Type (Desig_Typ));
1312 end if;
1313
1314 if Is_Concurrent_Type (Desig_Typ) then
1315 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1316 end if;
1317
1318 New_Typ_Decl :=
1319 Make_Full_Type_Declaration (Loc,
1320 Defining_Identifier => Make_Temporary (Loc, 'T'),
1321 Type_Definition =>
1322 Make_Access_To_Object_Definition (Loc,
1323 All_Present => True,
1324 Null_Exclusion_Present => False,
1325 Constant_Present => False,
1326 Subtype_Indication =>
1327 New_Occurrence_Of (Desig_Typ, Loc)));
1328
1329 Stats := New_List (
1330 Make_Simple_Return_Statement (Loc,
1331 Unchecked_Convert_To (Etype (N),
1332 Make_Attribute_Reference (Loc,
1333 Prefix =>
1334 Make_Selected_Component (Loc,
1335 Prefix =>
1336 Unchecked_Convert_To
1337 (Defining_Identifier (New_Typ_Decl),
1338 Make_Identifier (Loc, Name_uO)),
1339 Selector_Name =>
1340 New_Occurrence_Of (Iface_Tag, Loc)),
1341 Attribute_Name => Name_Address))));
1342
1343 -- If the type is null-excluding, no need for the null branch.
1344 -- Otherwise we need to check for it and return null.
1345
1346 if not Can_Never_Be_Null (Etype (N)) then
1347 Stats := New_List (
1348 Make_If_Statement (Loc,
1349 Condition =>
1350 Make_Op_Eq (Loc,
1351 Left_Opnd => Make_Identifier (Loc, Name_uO),
1352 Right_Opnd => New_Occurrence_Of
1353 (RTE (RE_Null_Address), Loc)),
1354
1355 Then_Statements => New_List (
1356 Make_Simple_Return_Statement (Loc, Make_Null (Loc))),
1357 Else_Statements => Stats));
1358 end if;
1359
1360 Fent := Make_Temporary (Loc, 'F');
1361 Func :=
1362 Make_Subprogram_Body (Loc,
1363 Specification =>
1364 Make_Function_Specification (Loc,
1365 Defining_Unit_Name => Fent,
1366
1367 Parameter_Specifications => New_List (
1368 Make_Parameter_Specification (Loc,
1369 Defining_Identifier =>
1370 Make_Defining_Identifier (Loc, Name_uO),
1371 Parameter_Type =>
1372 New_Occurrence_Of (RTE (RE_Address), Loc))),
1373
1374 Result_Definition =>
1375 New_Occurrence_Of (Etype (N), Loc)),
1376
1377 Declarations => New_List (New_Typ_Decl),
1378
1379 Handled_Statement_Sequence =>
1380 Make_Handled_Sequence_Of_Statements (Loc, Stats));
1381
1382 -- Place function body before the expression containing the
1383 -- conversion. We suppress all checks because the body of the
1384 -- internally generated function already takes care of the case
1385 -- in which the actual is null; therefore there is no need to
1386 -- double check that the pointer is not null when the program
1387 -- executes the alternative that performs the type conversion).
1388
1389 Insert_Action (N, Func, Suppress => All_Checks);
1390
1391 if Is_Access_Type (Etype (Expression (N))) then
1392
1393 Apply_Accessibility_Check
1394 (N => Expression (N),
1395 Typ => Etype (N),
1396 Insert_Node => N);
1397
1398 -- Generate: Func (Address!(Expression))
1399
1400 Rewrite (N,
1401 Make_Function_Call (Loc,
1402 Name => New_Occurrence_Of (Fent, Loc),
1403 Parameter_Associations => New_List (
1404 Unchecked_Convert_To (RTE (RE_Address),
1405 Relocate_Node (Expression (N))))));
1406
1407 else
1408 -- Generate: Func (Operand_Typ!(Expression)'Address)
1409
1410 Rewrite (N,
1411 Make_Function_Call (Loc,
1412 Name => New_Occurrence_Of (Fent, Loc),
1413 Parameter_Associations => New_List (
1414 Make_Attribute_Reference (Loc,
1415 Prefix => Unchecked_Convert_To (Operand_Typ,
1416 Relocate_Node (Expression (N))),
1417 Attribute_Name => Name_Address))));
1418 end if;
1419 end;
1420 end if;
1421
1422 Analyze (N);
1423 end Expand_Interface_Conversion;
1424
1425 ------------------------------
1426 -- Expand_Interface_Actuals --
1427 ------------------------------
1428
1429 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1430 Actual : Node_Id;
1431 Actual_Dup : Node_Id;
1432 Actual_Typ : Entity_Id;
1433 Anon : Entity_Id;
1434 Conversion : Node_Id;
1435 Formal : Entity_Id;
1436 Formal_Typ : Entity_Id;
1437 Subp : Entity_Id;
1438 Formal_DDT : Entity_Id;
1439 Actual_DDT : Entity_Id;
1440
1441 begin
1442 -- This subprogram is called directly from the semantics, so we need a
1443 -- check to see whether expansion is active before proceeding.
1444
1445 if not Expander_Active then
1446 return;
1447 end if;
1448
1449 -- Call using access to subprogram with explicit dereference
1450
1451 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1452 Subp := Etype (Name (Call_Node));
1453
1454 -- Call using selected component
1455
1456 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1457 Subp := Entity (Selector_Name (Name (Call_Node)));
1458
1459 -- Call using direct name
1460
1461 else
1462 Subp := Entity (Name (Call_Node));
1463 end if;
1464
1465 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1466 -- displacement
1467
1468 Formal := First_Formal (Subp);
1469 Actual := First_Actual (Call_Node);
1470 while Present (Formal) loop
1471 Formal_Typ := Etype (Formal);
1472
1473 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1474 Formal_Typ := Full_View (Formal_Typ);
1475 end if;
1476
1477 if Is_Access_Type (Formal_Typ) then
1478 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1479 end if;
1480
1481 Actual_Typ := Etype (Actual);
1482
1483 if Is_Access_Type (Actual_Typ) then
1484 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1485 end if;
1486
1487 if Is_Interface (Formal_Typ)
1488 and then Is_Class_Wide_Type (Formal_Typ)
1489 then
1490 -- No need to displace the pointer if the type of the actual
1491 -- coincides with the type of the formal.
1492
1493 if Actual_Typ = Formal_Typ then
1494 null;
1495
1496 -- No need to displace the pointer if the interface type is a
1497 -- parent of the type of the actual because in this case the
1498 -- interface primitives are located in the primary dispatch table.
1499
1500 elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1501 Use_Full_View => True)
1502 then
1503 null;
1504
1505 -- Implicit conversion to the class-wide formal type to force the
1506 -- displacement of the pointer.
1507
1508 else
1509 -- Normally, expansion of actuals for calls to build-in-place
1510 -- functions happens as part of Expand_Actuals, but in this
1511 -- case the call will be wrapped in a conversion and soon after
1512 -- expanded further to handle the displacement for a class-wide
1513 -- interface conversion, so if this is a BIP call then we need
1514 -- to handle it now.
1515
1516 if Ada_Version >= Ada_2005
1517 and then Is_Build_In_Place_Function_Call (Actual)
1518 then
1519 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1520 end if;
1521
1522 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1523 Rewrite (Actual, Conversion);
1524 Analyze_And_Resolve (Actual, Formal_Typ);
1525 end if;
1526
1527 -- Access to class-wide interface type
1528
1529 elsif Is_Access_Type (Formal_Typ)
1530 and then Is_Interface (Formal_DDT)
1531 and then Is_Class_Wide_Type (Formal_DDT)
1532 and then Interface_Present_In_Ancestor
1533 (Typ => Actual_DDT,
1534 Iface => Etype (Formal_DDT))
1535 then
1536 -- Handle attributes 'Access and 'Unchecked_Access
1537
1538 if Nkind (Actual) = N_Attribute_Reference
1539 and then
1540 (Attribute_Name (Actual) = Name_Access
1541 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1542 then
1543 -- This case must have been handled by the analysis and
1544 -- expansion of 'Access. The only exception is when types
1545 -- match and no further expansion is required.
1546
1547 pragma Assert (Base_Type (Etype (Prefix (Actual)))
1548 = Base_Type (Formal_DDT));
1549 null;
1550
1551 -- No need to displace the pointer if the type of the actual
1552 -- coincides with the type of the formal.
1553
1554 elsif Actual_DDT = Formal_DDT then
1555 null;
1556
1557 -- No need to displace the pointer if the interface type is
1558 -- a parent of the type of the actual because in this case the
1559 -- interface primitives are located in the primary dispatch table.
1560
1561 elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1562 Use_Full_View => True)
1563 then
1564 null;
1565
1566 else
1567 Actual_Dup := Relocate_Node (Actual);
1568
1569 if From_Limited_With (Actual_Typ) then
1570
1571 -- If the type of the actual parameter comes from a
1572 -- limited with-clause and the non-limited view is already
1573 -- available, we replace the anonymous access type by
1574 -- a duplicate declaration whose designated type is the
1575 -- non-limited view.
1576
1577 if Has_Non_Limited_View (Actual_DDT) then
1578 Anon := New_Copy (Actual_Typ);
1579
1580 if Is_Itype (Anon) then
1581 Set_Scope (Anon, Current_Scope);
1582 end if;
1583
1584 Set_Directly_Designated_Type
1585 (Anon, Non_Limited_View (Actual_DDT));
1586 Set_Etype (Actual_Dup, Anon);
1587 end if;
1588 end if;
1589
1590 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1591 Rewrite (Actual, Conversion);
1592 Analyze_And_Resolve (Actual, Formal_Typ);
1593 end if;
1594 end if;
1595
1596 Next_Actual (Actual);
1597 Next_Formal (Formal);
1598 end loop;
1599 end Expand_Interface_Actuals;
1600
1601 ----------------------------
1602 -- Expand_Interface_Thunk --
1603 ----------------------------
1604
1605 procedure Expand_Interface_Thunk
1606 (Prim : Node_Id;
1607 Thunk_Id : out Entity_Id;
1608 Thunk_Code : out Node_Id)
1609 is
1610 Loc : constant Source_Ptr := Sloc (Prim);
1611 Actuals : constant List_Id := New_List;
1612 Decl : constant List_Id := New_List;
1613 Formals : constant List_Id := New_List;
1614 Target : constant Entity_Id := Ultimate_Alias (Prim);
1615
1616 Decl_1 : Node_Id;
1617 Decl_2 : Node_Id;
1618 Expr : Node_Id;
1619 Formal : Node_Id;
1620 Ftyp : Entity_Id;
1621 Iface_Formal : Node_Id;
1622 New_Arg : Node_Id;
1623 Offset_To_Top : Node_Id;
1624 Target_Formal : Entity_Id;
1625
1626 begin
1627 Thunk_Id := Empty;
1628 Thunk_Code := Empty;
1629
1630 -- No thunk needed if the primitive has been eliminated
1631
1632 if Is_Eliminated (Ultimate_Alias (Prim)) then
1633 return;
1634
1635 -- In case of primitives that are functions without formals and a
1636 -- controlling result there is no need to build the thunk.
1637
1638 elsif not Present (First_Formal (Target)) then
1639 pragma Assert (Ekind (Target) = E_Function
1640 and then Has_Controlling_Result (Target));
1641 return;
1642 end if;
1643
1644 -- Duplicate the formals of the Target primitive. In the thunk, the type
1645 -- of the controlling formal is the covered interface type (instead of
1646 -- the target tagged type). Done to avoid problems with discriminated
1647 -- tagged types because, if the controlling type has discriminants with
1648 -- default values, then the type conversions done inside the body of
1649 -- the thunk (after the displacement of the pointer to the base of the
1650 -- actual object) generate code that modify its contents.
1651
1652 -- Note: This special management is not done for predefined primitives
1653 -- because???
1654
1655 if not Is_Predefined_Dispatching_Operation (Prim) then
1656 Iface_Formal := First_Formal (Interface_Alias (Prim));
1657 end if;
1658
1659 Formal := First_Formal (Target);
1660 while Present (Formal) loop
1661 Ftyp := Etype (Formal);
1662
1663 -- Use the interface type as the type of the controlling formal (see
1664 -- comment above).
1665
1666 if not Is_Controlling_Formal (Formal)
1667 or else Is_Predefined_Dispatching_Operation (Prim)
1668 then
1669 Ftyp := Etype (Formal);
1670 Expr := New_Copy_Tree (Expression (Parent (Formal)));
1671 else
1672 Ftyp := Etype (Iface_Formal);
1673 Expr := Empty;
1674 end if;
1675
1676 Append_To (Formals,
1677 Make_Parameter_Specification (Loc,
1678 Defining_Identifier =>
1679 Make_Defining_Identifier (Sloc (Formal),
1680 Chars => Chars (Formal)),
1681 In_Present => In_Present (Parent (Formal)),
1682 Out_Present => Out_Present (Parent (Formal)),
1683 Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
1684 Expression => Expr));
1685
1686 if not Is_Predefined_Dispatching_Operation (Prim) then
1687 Next_Formal (Iface_Formal);
1688 end if;
1689
1690 Next_Formal (Formal);
1691 end loop;
1692
1693 Target_Formal := First_Formal (Target);
1694 Formal := First (Formals);
1695 while Present (Formal) loop
1696
1697 -- If the parent is a constrained discriminated type, then the
1698 -- primitive operation will have been defined on a first subtype.
1699 -- For proper matching with controlling type, use base type.
1700
1701 if Ekind (Target_Formal) = E_In_Parameter
1702 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1703 then
1704 Ftyp :=
1705 Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1706 else
1707 Ftyp := Base_Type (Etype (Target_Formal));
1708 end if;
1709
1710 -- For concurrent types, the relevant information is found in the
1711 -- Corresponding_Record_Type, rather than the type entity itself.
1712
1713 if Is_Concurrent_Type (Ftyp) then
1714 Ftyp := Corresponding_Record_Type (Ftyp);
1715 end if;
1716
1717 if Ekind (Target_Formal) = E_In_Parameter
1718 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1719 and then Is_Controlling_Formal (Target_Formal)
1720 then
1721 -- Generate:
1722 -- type T is access all <<type of the target formal>>
1723 -- S : Storage_Offset := Storage_Offset!(Formal)
1724 -- - Offset_To_Top (address!(Formal))
1725
1726 Decl_2 :=
1727 Make_Full_Type_Declaration (Loc,
1728 Defining_Identifier => Make_Temporary (Loc, 'T'),
1729 Type_Definition =>
1730 Make_Access_To_Object_Definition (Loc,
1731 All_Present => True,
1732 Null_Exclusion_Present => False,
1733 Constant_Present => False,
1734 Subtype_Indication =>
1735 New_Occurrence_Of (Ftyp, Loc)));
1736
1737 New_Arg :=
1738 Unchecked_Convert_To (RTE (RE_Address),
1739 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1740
1741 if not RTE_Available (RE_Offset_To_Top) then
1742 Offset_To_Top :=
1743 Build_Offset_To_Top (Loc, New_Arg);
1744 else
1745 Offset_To_Top :=
1746 Make_Function_Call (Loc,
1747 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1748 Parameter_Associations => New_List (New_Arg));
1749 end if;
1750
1751 Decl_1 :=
1752 Make_Object_Declaration (Loc,
1753 Defining_Identifier => Make_Temporary (Loc, 'S'),
1754 Constant_Present => True,
1755 Object_Definition =>
1756 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
1757 Expression =>
1758 Make_Op_Subtract (Loc,
1759 Left_Opnd =>
1760 Unchecked_Convert_To
1761 (RTE (RE_Storage_Offset),
1762 New_Occurrence_Of
1763 (Defining_Identifier (Formal), Loc)),
1764 Right_Opnd =>
1765 Offset_To_Top));
1766
1767 Append_To (Decl, Decl_2);
1768 Append_To (Decl, Decl_1);
1769
1770 -- Reference the new actual. Generate:
1771 -- T!(S)
1772
1773 Append_To (Actuals,
1774 Unchecked_Convert_To
1775 (Defining_Identifier (Decl_2),
1776 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
1777
1778 elsif Is_Controlling_Formal (Target_Formal) then
1779
1780 -- Generate:
1781 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1782 -- - Offset_To_Top (Formal'Address)
1783 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1784
1785 New_Arg :=
1786 Make_Attribute_Reference (Loc,
1787 Prefix =>
1788 New_Occurrence_Of (Defining_Identifier (Formal), Loc),
1789 Attribute_Name =>
1790 Name_Address);
1791
1792 if not RTE_Available (RE_Offset_To_Top) then
1793 Offset_To_Top :=
1794 Build_Offset_To_Top (Loc, New_Arg);
1795 else
1796 Offset_To_Top :=
1797 Make_Function_Call (Loc,
1798 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1799 Parameter_Associations => New_List (New_Arg));
1800 end if;
1801
1802 Decl_1 :=
1803 Make_Object_Declaration (Loc,
1804 Defining_Identifier => Make_Temporary (Loc, 'S'),
1805 Constant_Present => True,
1806 Object_Definition =>
1807 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
1808 Expression =>
1809 Make_Op_Subtract (Loc,
1810 Left_Opnd =>
1811 Unchecked_Convert_To
1812 (RTE (RE_Storage_Offset),
1813 Make_Attribute_Reference (Loc,
1814 Prefix =>
1815 New_Occurrence_Of
1816 (Defining_Identifier (Formal), Loc),
1817 Attribute_Name => Name_Address)),
1818 Right_Opnd =>
1819 Offset_To_Top));
1820
1821 Decl_2 :=
1822 Make_Object_Declaration (Loc,
1823 Defining_Identifier => Make_Temporary (Loc, 'S'),
1824 Constant_Present => True,
1825 Object_Definition =>
1826 New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc),
1827 Expression =>
1828 Unchecked_Convert_To
1829 (RTE (RE_Addr_Ptr),
1830 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
1831
1832 Append_To (Decl, Decl_1);
1833 Append_To (Decl, Decl_2);
1834
1835 -- Reference the new actual, generate:
1836 -- Target_Formal (S2.all)
1837
1838 Append_To (Actuals,
1839 Unchecked_Convert_To (Ftyp,
1840 Make_Explicit_Dereference (Loc,
1841 New_Occurrence_Of (Defining_Identifier (Decl_2), Loc))));
1842
1843 -- Ensure proper matching of access types. Required to avoid
1844 -- reporting spurious errors.
1845
1846 elsif Is_Access_Type (Etype (Target_Formal)) then
1847 Append_To (Actuals,
1848 Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
1849 New_Occurrence_Of (Defining_Identifier (Formal), Loc)));
1850
1851 -- No special management required for this actual
1852
1853 else
1854 Append_To (Actuals,
1855 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1856 end if;
1857
1858 Next_Formal (Target_Formal);
1859 Next (Formal);
1860 end loop;
1861
1862 Thunk_Id := Make_Temporary (Loc, 'T');
1863 Set_Ekind (Thunk_Id, Ekind (Prim));
1864 Set_Is_Thunk (Thunk_Id);
1865 Set_Convention (Thunk_Id, Convention (Prim));
1866 Set_Thunk_Entity (Thunk_Id, Target);
1867
1868 -- Procedure case
1869
1870 if Ekind (Target) = E_Procedure then
1871 Thunk_Code :=
1872 Make_Subprogram_Body (Loc,
1873 Specification =>
1874 Make_Procedure_Specification (Loc,
1875 Defining_Unit_Name => Thunk_Id,
1876 Parameter_Specifications => Formals),
1877 Declarations => Decl,
1878 Handled_Statement_Sequence =>
1879 Make_Handled_Sequence_Of_Statements (Loc,
1880 Statements => New_List (
1881 Make_Procedure_Call_Statement (Loc,
1882 Name => New_Occurrence_Of (Target, Loc),
1883 Parameter_Associations => Actuals))));
1884
1885 -- Function case
1886
1887 else pragma Assert (Ekind (Target) = E_Function);
1888 declare
1889 Result_Def : Node_Id;
1890 Call_Node : Node_Id;
1891
1892 begin
1893 Call_Node :=
1894 Make_Function_Call (Loc,
1895 Name => New_Occurrence_Of (Target, Loc),
1896 Parameter_Associations => Actuals);
1897
1898 if not Is_Interface (Etype (Prim)) then
1899 Result_Def := New_Copy (Result_Definition (Parent (Target)));
1900
1901 -- Thunk of function returning a class-wide interface object. No
1902 -- extra displacement needed since the displacement is generated
1903 -- in the return statement of Prim. Example:
1904
1905 -- type Iface is interface ...
1906 -- function F (O : Iface) return Iface'Class;
1907
1908 -- type T is new ... and Iface with ...
1909 -- function F (O : T) return Iface'Class;
1910
1911 elsif Is_Class_Wide_Type (Etype (Prim)) then
1912 Result_Def := New_Occurrence_Of (Etype (Prim), Loc);
1913
1914 -- Thunk of function returning an interface object. Displacement
1915 -- needed. Example:
1916
1917 -- type Iface is interface ...
1918 -- function F (O : Iface) return Iface;
1919
1920 -- type T is new ... and Iface with ...
1921 -- function F (O : T) return T;
1922
1923 else
1924 Result_Def :=
1925 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
1926
1927 -- Adding implicit conversion to force the displacement of
1928 -- the pointer to the object to reference the corresponding
1929 -- secondary dispatch table.
1930
1931 Call_Node :=
1932 Make_Type_Conversion (Loc,
1933 Subtype_Mark =>
1934 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
1935 Expression => Relocate_Node (Call_Node));
1936 end if;
1937
1938 Thunk_Code :=
1939 Make_Subprogram_Body (Loc,
1940 Specification =>
1941 Make_Function_Specification (Loc,
1942 Defining_Unit_Name => Thunk_Id,
1943 Parameter_Specifications => Formals,
1944 Result_Definition => Result_Def),
1945 Declarations => Decl,
1946 Handled_Statement_Sequence =>
1947 Make_Handled_Sequence_Of_Statements (Loc,
1948 Statements => New_List (
1949 Make_Simple_Return_Statement (Loc, Call_Node))));
1950 end;
1951 end if;
1952 end Expand_Interface_Thunk;
1953
1954 --------------------------
1955 -- Has_CPP_Constructors --
1956 --------------------------
1957
1958 function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
1959 E : Entity_Id;
1960
1961 begin
1962 -- Look for the constructor entities
1963
1964 E := Next_Entity (Typ);
1965 while Present (E) loop
1966 if Ekind (E) = E_Function and then Is_Constructor (E) then
1967 return True;
1968 end if;
1969
1970 Next_Entity (E);
1971 end loop;
1972
1973 return False;
1974 end Has_CPP_Constructors;
1975
1976 ------------
1977 -- Has_DT --
1978 ------------
1979
1980 function Has_DT (Typ : Entity_Id) return Boolean is
1981 begin
1982 return not Is_Interface (Typ)
1983 and then not Restriction_Active (No_Dispatching_Calls);
1984 end Has_DT;
1985
1986 ----------------------------------
1987 -- Is_Expanded_Dispatching_Call --
1988 ----------------------------------
1989
1990 function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
1991 begin
1992 return Nkind (N) in N_Subprogram_Call
1993 and then Nkind (Name (N)) = N_Explicit_Dereference
1994 and then Is_Dispatch_Table_Entity (Etype (Name (N)));
1995 end Is_Expanded_Dispatching_Call;
1996
1997 -----------------------------------------
1998 -- Is_Predefined_Dispatching_Operation --
1999 -----------------------------------------
2000
2001 function Is_Predefined_Dispatching_Operation
2002 (E : Entity_Id) return Boolean
2003 is
2004 TSS_Name : TSS_Name_Type;
2005
2006 begin
2007 if not Is_Dispatching_Operation (E) then
2008 return False;
2009 end if;
2010
2011 Get_Name_String (Chars (E));
2012
2013 -- Most predefined primitives have internally generated names. Equality
2014 -- must be treated differently; the predefined operation is recognized
2015 -- as a homogeneous binary operator that returns Boolean.
2016
2017 if Name_Len > TSS_Name_Type'Last then
2018 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2019 .. Name_Len));
2020 if Chars (E) = Name_uSize
2021 or else TSS_Name = TSS_Stream_Read
2022 or else TSS_Name = TSS_Stream_Write
2023 or else TSS_Name = TSS_Stream_Input
2024 or else TSS_Name = TSS_Stream_Output
2025 or else
2026 (Chars (E) = Name_Op_Eq
2027 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2028 or else Chars (E) = Name_uAssign
2029 or else TSS_Name = TSS_Deep_Adjust
2030 or else TSS_Name = TSS_Deep_Finalize
2031 or else Is_Predefined_Interface_Primitive (E)
2032 then
2033 return True;
2034 end if;
2035 end if;
2036
2037 return False;
2038 end Is_Predefined_Dispatching_Operation;
2039
2040 ---------------------------------------
2041 -- Is_Predefined_Internal_Operation --
2042 ---------------------------------------
2043
2044 function Is_Predefined_Internal_Operation
2045 (E : Entity_Id) return Boolean
2046 is
2047 TSS_Name : TSS_Name_Type;
2048
2049 begin
2050 if not Is_Dispatching_Operation (E) then
2051 return False;
2052 end if;
2053
2054 Get_Name_String (Chars (E));
2055
2056 -- Most predefined primitives have internally generated names. Equality
2057 -- must be treated differently; the predefined operation is recognized
2058 -- as a homogeneous binary operator that returns Boolean.
2059
2060 if Name_Len > TSS_Name_Type'Last then
2061 TSS_Name :=
2062 TSS_Name_Type
2063 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2064
2065 if Nam_In (Chars (E), Name_uSize, Name_uAssign)
2066 or else
2067 (Chars (E) = Name_Op_Eq
2068 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2069 or else TSS_Name = TSS_Deep_Adjust
2070 or else TSS_Name = TSS_Deep_Finalize
2071 or else Is_Predefined_Interface_Primitive (E)
2072 then
2073 return True;
2074 end if;
2075 end if;
2076
2077 return False;
2078 end Is_Predefined_Internal_Operation;
2079
2080 -------------------------------------
2081 -- Is_Predefined_Dispatching_Alias --
2082 -------------------------------------
2083
2084 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2085 is
2086 begin
2087 return not Is_Predefined_Dispatching_Operation (Prim)
2088 and then Present (Alias (Prim))
2089 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2090 end Is_Predefined_Dispatching_Alias;
2091
2092 ---------------------------------------
2093 -- Is_Predefined_Interface_Primitive --
2094 ---------------------------------------
2095
2096 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2097 begin
2098 -- In VM targets we don't restrict the functionality of this test to
2099 -- compiling in Ada 2005 mode since in VM targets any tagged type has
2100 -- these primitives.
2101
2102 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2103 and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
2104 Name_uDisp_Conditional_Select,
2105 Name_uDisp_Get_Prim_Op_Kind,
2106 Name_uDisp_Get_Task_Id,
2107 Name_uDisp_Requeue,
2108 Name_uDisp_Timed_Select);
2109 end Is_Predefined_Interface_Primitive;
2110
2111 ----------------------------------------
2112 -- Make_Disp_Asynchronous_Select_Body --
2113 ----------------------------------------
2114
2115 -- For interface types, generate:
2116
2117 -- procedure _Disp_Asynchronous_Select
2118 -- (T : in out <Typ>;
2119 -- S : Integer;
2120 -- P : System.Address;
2121 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2122 -- F : out Boolean)
2123 -- is
2124 -- begin
2125 -- F := False;
2126 -- C := Ada.Tags.POK_Function;
2127 -- end _Disp_Asynchronous_Select;
2128
2129 -- For protected types, generate:
2130
2131 -- procedure _Disp_Asynchronous_Select
2132 -- (T : in out <Typ>;
2133 -- S : Integer;
2134 -- P : System.Address;
2135 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2136 -- F : out Boolean)
2137 -- is
2138 -- I : Integer :=
2139 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2140 -- Bnn : System.Tasking.Protected_Objects.Operations.
2141 -- Communication_Block;
2142 -- begin
2143 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2144 -- (T._object'Access,
2145 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2146 -- P,
2147 -- System.Tasking.Asynchronous_Call,
2148 -- Bnn);
2149 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2150 -- end _Disp_Asynchronous_Select;
2151
2152 -- For task types, generate:
2153
2154 -- procedure _Disp_Asynchronous_Select
2155 -- (T : in out <Typ>;
2156 -- S : Integer;
2157 -- P : System.Address;
2158 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2159 -- F : out Boolean)
2160 -- is
2161 -- I : Integer :=
2162 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2163 -- begin
2164 -- System.Tasking.Rendezvous.Task_Entry_Call
2165 -- (T._task_id,
2166 -- System.Tasking.Task_Entry_Index (I),
2167 -- P,
2168 -- System.Tasking.Asynchronous_Call,
2169 -- F);
2170 -- end _Disp_Asynchronous_Select;
2171
2172 function Make_Disp_Asynchronous_Select_Body
2173 (Typ : Entity_Id) return Node_Id
2174 is
2175 Com_Block : Entity_Id;
2176 Conc_Typ : Entity_Id := Empty;
2177 Decls : constant List_Id := New_List;
2178 Loc : constant Source_Ptr := Sloc (Typ);
2179 Obj_Ref : Node_Id;
2180 Stmts : constant List_Id := New_List;
2181 Tag_Node : Node_Id;
2182
2183 begin
2184 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2185
2186 -- Null body is generated for interface types
2187
2188 if Is_Interface (Typ) then
2189 return
2190 Make_Subprogram_Body (Loc,
2191 Specification =>
2192 Make_Disp_Asynchronous_Select_Spec (Typ),
2193 Declarations => New_List,
2194 Handled_Statement_Sequence =>
2195 Make_Handled_Sequence_Of_Statements (Loc,
2196 New_List (
2197 Make_Assignment_Statement (Loc,
2198 Name => Make_Identifier (Loc, Name_uF),
2199 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2200 end if;
2201
2202 if Is_Concurrent_Record_Type (Typ) then
2203 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2204
2205 -- Generate:
2206 -- I : Integer :=
2207 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2208
2209 -- where I will be used to capture the entry index of the primitive
2210 -- wrapper at position S.
2211
2212 if Tagged_Type_Expansion then
2213 Tag_Node :=
2214 Unchecked_Convert_To (RTE (RE_Tag),
2215 New_Occurrence_Of
2216 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2217 else
2218 Tag_Node :=
2219 Make_Attribute_Reference (Loc,
2220 Prefix => New_Occurrence_Of (Typ, Loc),
2221 Attribute_Name => Name_Tag);
2222 end if;
2223
2224 Append_To (Decls,
2225 Make_Object_Declaration (Loc,
2226 Defining_Identifier =>
2227 Make_Defining_Identifier (Loc, Name_uI),
2228 Object_Definition =>
2229 New_Occurrence_Of (Standard_Integer, Loc),
2230 Expression =>
2231 Make_Function_Call (Loc,
2232 Name =>
2233 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2234 Parameter_Associations =>
2235 New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
2236
2237 if Ekind (Conc_Typ) = E_Protected_Type then
2238
2239 -- Generate:
2240 -- Bnn : Communication_Block;
2241
2242 Com_Block := Make_Temporary (Loc, 'B');
2243 Append_To (Decls,
2244 Make_Object_Declaration (Loc,
2245 Defining_Identifier => Com_Block,
2246 Object_Definition =>
2247 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2248
2249 -- Build T._object'Access for calls below
2250
2251 Obj_Ref :=
2252 Make_Attribute_Reference (Loc,
2253 Attribute_Name => Name_Unchecked_Access,
2254 Prefix =>
2255 Make_Selected_Component (Loc,
2256 Prefix => Make_Identifier (Loc, Name_uT),
2257 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2258
2259 case Corresponding_Runtime_Package (Conc_Typ) is
2260 when System_Tasking_Protected_Objects_Entries =>
2261
2262 -- Generate:
2263 -- Protected_Entry_Call
2264 -- (T._object'Access, -- Object
2265 -- Protected_Entry_Index! (I), -- E
2266 -- P, -- Uninterpreted_Data
2267 -- Asynchronous_Call, -- Mode
2268 -- Bnn); -- Communication_Block
2269
2270 -- where T is the protected object, I is the entry index, P
2271 -- is the wrapped parameters and B is the name of the
2272 -- communication block.
2273
2274 Append_To (Stmts,
2275 Make_Procedure_Call_Statement (Loc,
2276 Name =>
2277 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2278 Parameter_Associations =>
2279 New_List (
2280 Obj_Ref,
2281
2282 Make_Unchecked_Type_Conversion (Loc, -- entry index
2283 Subtype_Mark =>
2284 New_Occurrence_Of
2285 (RTE (RE_Protected_Entry_Index), Loc),
2286 Expression => Make_Identifier (Loc, Name_uI)),
2287
2288 Make_Identifier (Loc, Name_uP), -- parameter block
2289 New_Occurrence_Of -- Asynchronous_Call
2290 (RTE (RE_Asynchronous_Call), Loc),
2291 New_Occurrence_Of -- comm block
2292 (Com_Block, Loc))));
2293
2294 when others =>
2295 raise Program_Error;
2296 end case;
2297
2298 -- Generate:
2299 -- B := Dummy_Communication_Block (Bnn);
2300
2301 Append_To (Stmts,
2302 Make_Assignment_Statement (Loc,
2303 Name => Make_Identifier (Loc, Name_uB),
2304 Expression =>
2305 Make_Unchecked_Type_Conversion (Loc,
2306 Subtype_Mark =>
2307 New_Occurrence_Of
2308 (RTE (RE_Dummy_Communication_Block), Loc),
2309 Expression => New_Occurrence_Of (Com_Block, Loc))));
2310
2311 -- Generate:
2312 -- F := False;
2313
2314 Append_To (Stmts,
2315 Make_Assignment_Statement (Loc,
2316 Name => Make_Identifier (Loc, Name_uF),
2317 Expression => New_Occurrence_Of (Standard_False, Loc)));
2318
2319 else
2320 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2321
2322 -- Generate:
2323 -- Task_Entry_Call
2324 -- (T._task_id, -- Acceptor
2325 -- Task_Entry_Index! (I), -- E
2326 -- P, -- Uninterpreted_Data
2327 -- Asynchronous_Call, -- Mode
2328 -- F); -- Rendezvous_Successful
2329
2330 -- where T is the task object, I is the entry index, P is the
2331 -- wrapped parameters and F is the status flag.
2332
2333 Append_To (Stmts,
2334 Make_Procedure_Call_Statement (Loc,
2335 Name =>
2336 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2337 Parameter_Associations =>
2338 New_List (
2339 Make_Selected_Component (Loc, -- T._task_id
2340 Prefix => Make_Identifier (Loc, Name_uT),
2341 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2342
2343 Make_Unchecked_Type_Conversion (Loc, -- entry index
2344 Subtype_Mark =>
2345 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2346 Expression => Make_Identifier (Loc, Name_uI)),
2347
2348 Make_Identifier (Loc, Name_uP), -- parameter block
2349 New_Occurrence_Of -- Asynchronous_Call
2350 (RTE (RE_Asynchronous_Call), Loc),
2351 Make_Identifier (Loc, Name_uF)))); -- status flag
2352 end if;
2353
2354 else
2355 -- Ensure that the statements list is non-empty
2356
2357 Append_To (Stmts,
2358 Make_Assignment_Statement (Loc,
2359 Name => Make_Identifier (Loc, Name_uF),
2360 Expression => New_Occurrence_Of (Standard_False, Loc)));
2361 end if;
2362
2363 return
2364 Make_Subprogram_Body (Loc,
2365 Specification =>
2366 Make_Disp_Asynchronous_Select_Spec (Typ),
2367 Declarations => Decls,
2368 Handled_Statement_Sequence =>
2369 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2370 end Make_Disp_Asynchronous_Select_Body;
2371
2372 ----------------------------------------
2373 -- Make_Disp_Asynchronous_Select_Spec --
2374 ----------------------------------------
2375
2376 function Make_Disp_Asynchronous_Select_Spec
2377 (Typ : Entity_Id) return Node_Id
2378 is
2379 Loc : constant Source_Ptr := Sloc (Typ);
2380 Def_Id : constant Node_Id :=
2381 Make_Defining_Identifier (Loc,
2382 Name_uDisp_Asynchronous_Select);
2383 Params : constant List_Id := New_List;
2384
2385 begin
2386 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2387
2388 -- T : in out Typ; -- Object parameter
2389 -- S : Integer; -- Primitive operation slot
2390 -- P : Address; -- Wrapped parameters
2391 -- B : out Dummy_Communication_Block; -- Communication block dummy
2392 -- F : out Boolean; -- Status flag
2393
2394 Append_List_To (Params, New_List (
2395
2396 Make_Parameter_Specification (Loc,
2397 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2398 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2399 In_Present => True,
2400 Out_Present => True),
2401
2402 Make_Parameter_Specification (Loc,
2403 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2404 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2405
2406 Make_Parameter_Specification (Loc,
2407 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2408 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2409
2410 Make_Parameter_Specification (Loc,
2411 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB),
2412 Parameter_Type =>
2413 New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
2414 Out_Present => True),
2415
2416 Make_Parameter_Specification (Loc,
2417 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2418 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2419 Out_Present => True)));
2420
2421 return
2422 Make_Procedure_Specification (Loc,
2423 Defining_Unit_Name => Def_Id,
2424 Parameter_Specifications => Params);
2425 end Make_Disp_Asynchronous_Select_Spec;
2426
2427 ---------------------------------------
2428 -- Make_Disp_Conditional_Select_Body --
2429 ---------------------------------------
2430
2431 -- For interface types, generate:
2432
2433 -- procedure _Disp_Conditional_Select
2434 -- (T : in out <Typ>;
2435 -- S : Integer;
2436 -- P : System.Address;
2437 -- C : out Ada.Tags.Prim_Op_Kind;
2438 -- F : out Boolean)
2439 -- is
2440 -- begin
2441 -- F := False;
2442 -- C := Ada.Tags.POK_Function;
2443 -- end _Disp_Conditional_Select;
2444
2445 -- For protected types, generate:
2446
2447 -- procedure _Disp_Conditional_Select
2448 -- (T : in out <Typ>;
2449 -- S : Integer;
2450 -- P : System.Address;
2451 -- C : out Ada.Tags.Prim_Op_Kind;
2452 -- F : out Boolean)
2453 -- is
2454 -- I : Integer;
2455 -- Bnn : System.Tasking.Protected_Objects.Operations.
2456 -- Communication_Block;
2457
2458 -- begin
2459 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2460
2461 -- if C = Ada.Tags.POK_Procedure
2462 -- or else C = Ada.Tags.POK_Protected_Procedure
2463 -- or else C = Ada.Tags.POK_Task_Procedure
2464 -- then
2465 -- F := True;
2466 -- return;
2467 -- end if;
2468
2469 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2470 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2471 -- (T.object'Access,
2472 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2473 -- P,
2474 -- System.Tasking.Conditional_Call,
2475 -- Bnn);
2476 -- F := not Cancelled (Bnn);
2477 -- end _Disp_Conditional_Select;
2478
2479 -- For task types, generate:
2480
2481 -- procedure _Disp_Conditional_Select
2482 -- (T : in out <Typ>;
2483 -- S : Integer;
2484 -- P : System.Address;
2485 -- C : out Ada.Tags.Prim_Op_Kind;
2486 -- F : out Boolean)
2487 -- is
2488 -- I : Integer;
2489
2490 -- begin
2491 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2492 -- System.Tasking.Rendezvous.Task_Entry_Call
2493 -- (T._task_id,
2494 -- System.Tasking.Task_Entry_Index (I),
2495 -- P,
2496 -- System.Tasking.Conditional_Call,
2497 -- F);
2498 -- end _Disp_Conditional_Select;
2499
2500 function Make_Disp_Conditional_Select_Body
2501 (Typ : Entity_Id) return Node_Id
2502 is
2503 Loc : constant Source_Ptr := Sloc (Typ);
2504 Blk_Nam : Entity_Id;
2505 Conc_Typ : Entity_Id := Empty;
2506 Decls : constant List_Id := New_List;
2507 Obj_Ref : Node_Id;
2508 Stmts : constant List_Id := New_List;
2509 Tag_Node : Node_Id;
2510
2511 begin
2512 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2513
2514 -- Null body is generated for interface types
2515
2516 if Is_Interface (Typ) then
2517 return
2518 Make_Subprogram_Body (Loc,
2519 Specification =>
2520 Make_Disp_Conditional_Select_Spec (Typ),
2521 Declarations => No_List,
2522 Handled_Statement_Sequence =>
2523 Make_Handled_Sequence_Of_Statements (Loc,
2524 New_List (Make_Assignment_Statement (Loc,
2525 Name => Make_Identifier (Loc, Name_uF),
2526 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2527 end if;
2528
2529 if Is_Concurrent_Record_Type (Typ) then
2530 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2531
2532 -- Generate:
2533 -- I : Integer;
2534
2535 -- where I will be used to capture the entry index of the primitive
2536 -- wrapper at position S.
2537
2538 Append_To (Decls,
2539 Make_Object_Declaration (Loc,
2540 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
2541 Object_Definition =>
2542 New_Occurrence_Of (Standard_Integer, Loc)));
2543
2544 -- Generate:
2545 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2546
2547 -- if C = POK_Procedure
2548 -- or else C = POK_Protected_Procedure
2549 -- or else C = POK_Task_Procedure;
2550 -- then
2551 -- F := True;
2552 -- return;
2553 -- end if;
2554
2555 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2556
2557 -- Generate:
2558 -- Bnn : Communication_Block;
2559
2560 -- where Bnn is the name of the communication block used in the
2561 -- call to Protected_Entry_Call.
2562
2563 Blk_Nam := Make_Temporary (Loc, 'B');
2564 Append_To (Decls,
2565 Make_Object_Declaration (Loc,
2566 Defining_Identifier => Blk_Nam,
2567 Object_Definition =>
2568 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2569
2570 -- Generate:
2571 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2572
2573 -- I is the entry index and S is the dispatch table slot
2574
2575 if Tagged_Type_Expansion then
2576 Tag_Node :=
2577 Unchecked_Convert_To (RTE (RE_Tag),
2578 New_Occurrence_Of
2579 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2580
2581 else
2582 Tag_Node :=
2583 Make_Attribute_Reference (Loc,
2584 Prefix => New_Occurrence_Of (Typ, Loc),
2585 Attribute_Name => Name_Tag);
2586 end if;
2587
2588 Append_To (Stmts,
2589 Make_Assignment_Statement (Loc,
2590 Name => Make_Identifier (Loc, Name_uI),
2591 Expression =>
2592 Make_Function_Call (Loc,
2593 Name =>
2594 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2595 Parameter_Associations => New_List (
2596 Tag_Node,
2597 Make_Identifier (Loc, Name_uS)))));
2598
2599 if Ekind (Conc_Typ) = E_Protected_Type then
2600
2601 Obj_Ref := -- T._object'Access
2602 Make_Attribute_Reference (Loc,
2603 Attribute_Name => Name_Unchecked_Access,
2604 Prefix =>
2605 Make_Selected_Component (Loc,
2606 Prefix => Make_Identifier (Loc, Name_uT),
2607 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2608
2609 case Corresponding_Runtime_Package (Conc_Typ) is
2610 when System_Tasking_Protected_Objects_Entries =>
2611 -- Generate:
2612
2613 -- Protected_Entry_Call
2614 -- (T._object'Access, -- Object
2615 -- Protected_Entry_Index! (I), -- E
2616 -- P, -- Uninterpreted_Data
2617 -- Conditional_Call, -- Mode
2618 -- Bnn); -- Block
2619
2620 -- where T is the protected object, I is the entry index, P
2621 -- are the wrapped parameters and Bnn is the name of the
2622 -- communication block.
2623
2624 Append_To (Stmts,
2625 Make_Procedure_Call_Statement (Loc,
2626 Name =>
2627 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2628 Parameter_Associations => New_List (
2629 Obj_Ref,
2630
2631 Make_Unchecked_Type_Conversion (Loc, -- entry index
2632 Subtype_Mark =>
2633 New_Occurrence_Of
2634 (RTE (RE_Protected_Entry_Index), Loc),
2635 Expression => Make_Identifier (Loc, Name_uI)),
2636
2637 Make_Identifier (Loc, Name_uP), -- parameter block
2638
2639 New_Occurrence_Of -- Conditional_Call
2640 (RTE (RE_Conditional_Call), Loc),
2641 New_Occurrence_Of -- Bnn
2642 (Blk_Nam, Loc))));
2643
2644 when System_Tasking_Protected_Objects_Single_Entry =>
2645
2646 -- If we are compiling for a restricted run-time, the call
2647 -- uses the simpler form.
2648
2649 Append_To (Stmts,
2650 Make_Procedure_Call_Statement (Loc,
2651 Name =>
2652 New_Occurrence_Of
2653 (RTE (RE_Protected_Single_Entry_Call), Loc),
2654 Parameter_Associations => New_List (
2655 Obj_Ref,
2656
2657 Make_Attribute_Reference (Loc,
2658 Prefix => Make_Identifier (Loc, Name_uP),
2659 Attribute_Name => Name_Address),
2660
2661 New_Occurrence_Of
2662 (RTE (RE_Conditional_Call), Loc))));
2663 when others =>
2664 raise Program_Error;
2665 end case;
2666
2667 -- Generate:
2668 -- F := not Cancelled (Bnn);
2669
2670 -- where F is the success flag. The status of Cancelled is negated
2671 -- in order to match the behaviour of the version for task types.
2672
2673 Append_To (Stmts,
2674 Make_Assignment_Statement (Loc,
2675 Name => Make_Identifier (Loc, Name_uF),
2676 Expression =>
2677 Make_Op_Not (Loc,
2678 Right_Opnd =>
2679 Make_Function_Call (Loc,
2680 Name =>
2681 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
2682 Parameter_Associations => New_List (
2683 New_Occurrence_Of (Blk_Nam, Loc))))));
2684 else
2685 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2686
2687 -- Generate:
2688 -- Task_Entry_Call
2689 -- (T._task_id, -- Acceptor
2690 -- Task_Entry_Index! (I), -- E
2691 -- P, -- Uninterpreted_Data
2692 -- Conditional_Call, -- Mode
2693 -- F); -- Rendezvous_Successful
2694
2695 -- where T is the task object, I is the entry index, P are the
2696 -- wrapped parameters and F is the status flag.
2697
2698 Append_To (Stmts,
2699 Make_Procedure_Call_Statement (Loc,
2700 Name =>
2701 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2702 Parameter_Associations => New_List (
2703
2704 Make_Selected_Component (Loc, -- T._task_id
2705 Prefix => Make_Identifier (Loc, Name_uT),
2706 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2707
2708 Make_Unchecked_Type_Conversion (Loc, -- entry index
2709 Subtype_Mark =>
2710 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2711 Expression => Make_Identifier (Loc, Name_uI)),
2712
2713 Make_Identifier (Loc, Name_uP), -- parameter block
2714 New_Occurrence_Of -- Conditional_Call
2715 (RTE (RE_Conditional_Call), Loc),
2716 Make_Identifier (Loc, Name_uF)))); -- status flag
2717 end if;
2718
2719 else
2720 -- Initialize out parameters
2721
2722 Append_To (Stmts,
2723 Make_Assignment_Statement (Loc,
2724 Name => Make_Identifier (Loc, Name_uF),
2725 Expression => New_Occurrence_Of (Standard_False, Loc)));
2726 Append_To (Stmts,
2727 Make_Assignment_Statement (Loc,
2728 Name => Make_Identifier (Loc, Name_uC),
2729 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
2730 end if;
2731
2732 return
2733 Make_Subprogram_Body (Loc,
2734 Specification =>
2735 Make_Disp_Conditional_Select_Spec (Typ),
2736 Declarations => Decls,
2737 Handled_Statement_Sequence =>
2738 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2739 end Make_Disp_Conditional_Select_Body;
2740
2741 ---------------------------------------
2742 -- Make_Disp_Conditional_Select_Spec --
2743 ---------------------------------------
2744
2745 function Make_Disp_Conditional_Select_Spec
2746 (Typ : Entity_Id) return Node_Id
2747 is
2748 Loc : constant Source_Ptr := Sloc (Typ);
2749 Def_Id : constant Node_Id :=
2750 Make_Defining_Identifier (Loc,
2751 Name_uDisp_Conditional_Select);
2752 Params : constant List_Id := New_List;
2753
2754 begin
2755 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2756
2757 -- T : in out Typ; -- Object parameter
2758 -- S : Integer; -- Primitive operation slot
2759 -- P : Address; -- Wrapped parameters
2760 -- C : out Prim_Op_Kind; -- Call kind
2761 -- F : out Boolean; -- Status flag
2762
2763 Append_List_To (Params, New_List (
2764
2765 Make_Parameter_Specification (Loc,
2766 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2767 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2768 In_Present => True,
2769 Out_Present => True),
2770
2771 Make_Parameter_Specification (Loc,
2772 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2773 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2774
2775 Make_Parameter_Specification (Loc,
2776 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2777 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2778
2779 Make_Parameter_Specification (Loc,
2780 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2781 Parameter_Type =>
2782 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2783 Out_Present => True),
2784
2785 Make_Parameter_Specification (Loc,
2786 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2787 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2788 Out_Present => True)));
2789
2790 return
2791 Make_Procedure_Specification (Loc,
2792 Defining_Unit_Name => Def_Id,
2793 Parameter_Specifications => Params);
2794 end Make_Disp_Conditional_Select_Spec;
2795
2796 -------------------------------------
2797 -- Make_Disp_Get_Prim_Op_Kind_Body --
2798 -------------------------------------
2799
2800 function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is
2801 Loc : constant Source_Ptr := Sloc (Typ);
2802 Tag_Node : Node_Id;
2803
2804 begin
2805 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2806
2807 if Is_Interface (Typ) then
2808 return
2809 Make_Subprogram_Body (Loc,
2810 Specification =>
2811 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2812 Declarations => New_List,
2813 Handled_Statement_Sequence =>
2814 Make_Handled_Sequence_Of_Statements (Loc,
2815 New_List (Make_Null_Statement (Loc))));
2816 end if;
2817
2818 -- Generate:
2819 -- C := get_prim_op_kind (tag! (<type>VP), S);
2820
2821 -- where C is the out parameter capturing the call kind and S is the
2822 -- dispatch table slot number.
2823
2824 if Tagged_Type_Expansion then
2825 Tag_Node :=
2826 Unchecked_Convert_To (RTE (RE_Tag),
2827 New_Occurrence_Of
2828 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2829
2830 else
2831 Tag_Node :=
2832 Make_Attribute_Reference (Loc,
2833 Prefix => New_Occurrence_Of (Typ, Loc),
2834 Attribute_Name => Name_Tag);
2835 end if;
2836
2837 return
2838 Make_Subprogram_Body (Loc,
2839 Specification =>
2840 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2841 Declarations => New_List,
2842 Handled_Statement_Sequence =>
2843 Make_Handled_Sequence_Of_Statements (Loc,
2844 New_List (
2845 Make_Assignment_Statement (Loc,
2846 Name => Make_Identifier (Loc, Name_uC),
2847 Expression =>
2848 Make_Function_Call (Loc,
2849 Name =>
2850 New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
2851 Parameter_Associations => New_List (
2852 Tag_Node,
2853 Make_Identifier (Loc, Name_uS)))))));
2854 end Make_Disp_Get_Prim_Op_Kind_Body;
2855
2856 -------------------------------------
2857 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2858 -------------------------------------
2859
2860 function Make_Disp_Get_Prim_Op_Kind_Spec
2861 (Typ : Entity_Id) return Node_Id
2862 is
2863 Loc : constant Source_Ptr := Sloc (Typ);
2864 Def_Id : constant Node_Id :=
2865 Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
2866 Params : constant List_Id := New_List;
2867
2868 begin
2869 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2870
2871 -- T : in out Typ; -- Object parameter
2872 -- S : Integer; -- Primitive operation slot
2873 -- C : out Prim_Op_Kind; -- Call kind
2874
2875 Append_List_To (Params, New_List (
2876
2877 Make_Parameter_Specification (Loc,
2878 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2879 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2880 In_Present => True,
2881 Out_Present => True),
2882
2883 Make_Parameter_Specification (Loc,
2884 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2885 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2886
2887 Make_Parameter_Specification (Loc,
2888 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2889 Parameter_Type =>
2890 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2891 Out_Present => True)));
2892
2893 return
2894 Make_Procedure_Specification (Loc,
2895 Defining_Unit_Name => Def_Id,
2896 Parameter_Specifications => Params);
2897 end Make_Disp_Get_Prim_Op_Kind_Spec;
2898
2899 --------------------------------
2900 -- Make_Disp_Get_Task_Id_Body --
2901 --------------------------------
2902
2903 function Make_Disp_Get_Task_Id_Body
2904 (Typ : Entity_Id) return Node_Id
2905 is
2906 Loc : constant Source_Ptr := Sloc (Typ);
2907 Ret : Node_Id;
2908
2909 begin
2910 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2911
2912 if Is_Concurrent_Record_Type (Typ)
2913 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2914 then
2915 -- Generate:
2916 -- return To_Address (_T._task_id);
2917
2918 Ret :=
2919 Make_Simple_Return_Statement (Loc,
2920 Expression =>
2921 Make_Unchecked_Type_Conversion (Loc,
2922 Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
2923 Expression =>
2924 Make_Selected_Component (Loc,
2925 Prefix => Make_Identifier (Loc, Name_uT),
2926 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
2927
2928 -- A null body is constructed for non-task types
2929
2930 else
2931 -- Generate:
2932 -- return Null_Address;
2933
2934 Ret :=
2935 Make_Simple_Return_Statement (Loc,
2936 Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
2937 end if;
2938
2939 return
2940 Make_Subprogram_Body (Loc,
2941 Specification => Make_Disp_Get_Task_Id_Spec (Typ),
2942 Declarations => New_List,
2943 Handled_Statement_Sequence =>
2944 Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
2945 end Make_Disp_Get_Task_Id_Body;
2946
2947 --------------------------------
2948 -- Make_Disp_Get_Task_Id_Spec --
2949 --------------------------------
2950
2951 function Make_Disp_Get_Task_Id_Spec
2952 (Typ : Entity_Id) return Node_Id
2953 is
2954 Loc : constant Source_Ptr := Sloc (Typ);
2955
2956 begin
2957 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2958
2959 return
2960 Make_Function_Specification (Loc,
2961 Defining_Unit_Name =>
2962 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2963 Parameter_Specifications => New_List (
2964 Make_Parameter_Specification (Loc,
2965 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2966 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
2967 Result_Definition =>
2968 New_Occurrence_Of (RTE (RE_Address), Loc));
2969 end Make_Disp_Get_Task_Id_Spec;
2970
2971 ----------------------------
2972 -- Make_Disp_Requeue_Body --
2973 ----------------------------
2974
2975 function Make_Disp_Requeue_Body
2976 (Typ : Entity_Id) return Node_Id
2977 is
2978 Loc : constant Source_Ptr := Sloc (Typ);
2979 Conc_Typ : Entity_Id := Empty;
2980 Stmts : constant List_Id := New_List;
2981
2982 begin
2983 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2984
2985 -- Null body is generated for interface types and non-concurrent
2986 -- tagged types.
2987
2988 if Is_Interface (Typ)
2989 or else not Is_Concurrent_Record_Type (Typ)
2990 then
2991 return
2992 Make_Subprogram_Body (Loc,
2993 Specification => Make_Disp_Requeue_Spec (Typ),
2994 Declarations => No_List,
2995 Handled_Statement_Sequence =>
2996 Make_Handled_Sequence_Of_Statements (Loc,
2997 New_List (Make_Null_Statement (Loc))));
2998 end if;
2999
3000 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3001
3002 if Ekind (Conc_Typ) = E_Protected_Type then
3003
3004 -- Generate statements:
3005 -- if F then
3006 -- System.Tasking.Protected_Objects.Operations.
3007 -- Requeue_Protected_Entry
3008 -- (Protection_Entries_Access (P),
3009 -- O._object'Unchecked_Access,
3010 -- Protected_Entry_Index (I),
3011 -- A);
3012 -- else
3013 -- System.Tasking.Protected_Objects.Operations.
3014 -- Requeue_Task_To_Protected_Entry
3015 -- (O._object'Unchecked_Access,
3016 -- Protected_Entry_Index (I),
3017 -- A);
3018 -- end if;
3019
3020 if Restriction_Active (No_Entry_Queue) then
3021 Append_To (Stmts, Make_Null_Statement (Loc));
3022 else
3023 Append_To (Stmts,
3024 Make_If_Statement (Loc,
3025 Condition => Make_Identifier (Loc, Name_uF),
3026
3027 Then_Statements =>
3028 New_List (
3029
3030 -- Call to Requeue_Protected_Entry
3031
3032 Make_Procedure_Call_Statement (Loc,
3033 Name =>
3034 New_Occurrence_Of
3035 (RTE (RE_Requeue_Protected_Entry), Loc),
3036 Parameter_Associations =>
3037 New_List (
3038
3039 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3040 Subtype_Mark =>
3041 New_Occurrence_Of (
3042 RTE (RE_Protection_Entries_Access), Loc),
3043 Expression =>
3044 Make_Identifier (Loc, Name_uP)),
3045
3046 Make_Attribute_Reference (Loc, -- O._object'Acc
3047 Attribute_Name =>
3048 Name_Unchecked_Access,
3049 Prefix =>
3050 Make_Selected_Component (Loc,
3051 Prefix =>
3052 Make_Identifier (Loc, Name_uO),
3053 Selector_Name =>
3054 Make_Identifier (Loc, Name_uObject))),
3055
3056 Make_Unchecked_Type_Conversion (Loc, -- entry index
3057 Subtype_Mark =>
3058 New_Occurrence_Of
3059 (RTE (RE_Protected_Entry_Index), Loc),
3060 Expression => Make_Identifier (Loc, Name_uI)),
3061
3062 Make_Identifier (Loc, Name_uA)))), -- abort status
3063
3064 Else_Statements =>
3065 New_List (
3066
3067 -- Call to Requeue_Task_To_Protected_Entry
3068
3069 Make_Procedure_Call_Statement (Loc,
3070 Name =>
3071 New_Occurrence_Of
3072 (RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3073 Parameter_Associations =>
3074 New_List (
3075
3076 Make_Attribute_Reference (Loc, -- O._object'Acc
3077 Attribute_Name => Name_Unchecked_Access,
3078 Prefix =>
3079 Make_Selected_Component (Loc,
3080 Prefix =>
3081 Make_Identifier (Loc, Name_uO),
3082 Selector_Name =>
3083 Make_Identifier (Loc, Name_uObject))),
3084
3085 Make_Unchecked_Type_Conversion (Loc, -- entry index
3086 Subtype_Mark =>
3087 New_Occurrence_Of
3088 (RTE (RE_Protected_Entry_Index), Loc),
3089 Expression => Make_Identifier (Loc, Name_uI)),
3090
3091 Make_Identifier (Loc, Name_uA)))))); -- abort status
3092 end if;
3093
3094 else
3095 pragma Assert (Is_Task_Type (Conc_Typ));
3096
3097 -- Generate:
3098 -- if F then
3099 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3100 -- (Protection_Entries_Access (P),
3101 -- O._task_id,
3102 -- Task_Entry_Index (I),
3103 -- A);
3104 -- else
3105 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3106 -- (O._task_id,
3107 -- Task_Entry_Index (I),
3108 -- A);
3109 -- end if;
3110
3111 Append_To (Stmts,
3112 Make_If_Statement (Loc,
3113 Condition => Make_Identifier (Loc, Name_uF),
3114
3115 Then_Statements => New_List (
3116
3117 -- Call to Requeue_Protected_To_Task_Entry
3118
3119 Make_Procedure_Call_Statement (Loc,
3120 Name =>
3121 New_Occurrence_Of
3122 (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3123
3124 Parameter_Associations => New_List (
3125
3126 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3127 Subtype_Mark =>
3128 New_Occurrence_Of
3129 (RTE (RE_Protection_Entries_Access), Loc),
3130 Expression => Make_Identifier (Loc, Name_uP)),
3131
3132 Make_Selected_Component (Loc, -- O._task_id
3133 Prefix => Make_Identifier (Loc, Name_uO),
3134 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3135
3136 Make_Unchecked_Type_Conversion (Loc, -- entry index
3137 Subtype_Mark =>
3138 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3139 Expression => Make_Identifier (Loc, Name_uI)),
3140
3141 Make_Identifier (Loc, Name_uA)))), -- abort status
3142
3143 Else_Statements => New_List (
3144
3145 -- Call to Requeue_Task_Entry
3146
3147 Make_Procedure_Call_Statement (Loc,
3148 Name =>
3149 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
3150
3151 Parameter_Associations => New_List (
3152
3153 Make_Selected_Component (Loc, -- O._task_id
3154 Prefix => Make_Identifier (Loc, Name_uO),
3155 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3156
3157 Make_Unchecked_Type_Conversion (Loc, -- entry index
3158 Subtype_Mark =>
3159 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3160 Expression => Make_Identifier (Loc, Name_uI)),
3161
3162 Make_Identifier (Loc, Name_uA)))))); -- abort status
3163 end if;
3164
3165 -- Even though no declarations are needed in both cases, we allocate
3166 -- a list for entities added by Freeze.
3167
3168 return
3169 Make_Subprogram_Body (Loc,
3170 Specification => Make_Disp_Requeue_Spec (Typ),
3171 Declarations => New_List,
3172 Handled_Statement_Sequence =>
3173 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3174 end Make_Disp_Requeue_Body;
3175
3176 ----------------------------
3177 -- Make_Disp_Requeue_Spec --
3178 ----------------------------
3179
3180 function Make_Disp_Requeue_Spec
3181 (Typ : Entity_Id) return Node_Id
3182 is
3183 Loc : constant Source_Ptr := Sloc (Typ);
3184
3185 begin
3186 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3187
3188 -- O : in out Typ; - Object parameter
3189 -- F : Boolean; - Protected (True) / task (False) flag
3190 -- P : Address; - Protection_Entries_Access value
3191 -- I : Entry_Index - Index of entry call
3192 -- A : Boolean - Abort flag
3193
3194 -- Note that the Protection_Entries_Access value is represented as a
3195 -- System.Address in order to avoid dragging in the tasking runtime
3196 -- when compiling sources without tasking constructs.
3197
3198 return
3199 Make_Procedure_Specification (Loc,
3200 Defining_Unit_Name =>
3201 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3202
3203 Parameter_Specifications => New_List (
3204
3205 Make_Parameter_Specification (Loc, -- O
3206 Defining_Identifier =>
3207 Make_Defining_Identifier (Loc, Name_uO),
3208 Parameter_Type =>
3209 New_Occurrence_Of (Typ, Loc),
3210 In_Present => True,
3211 Out_Present => True),
3212
3213 Make_Parameter_Specification (Loc, -- F
3214 Defining_Identifier =>
3215 Make_Defining_Identifier (Loc, Name_uF),
3216 Parameter_Type =>
3217 New_Occurrence_Of (Standard_Boolean, Loc)),
3218
3219 Make_Parameter_Specification (Loc, -- P
3220 Defining_Identifier =>
3221 Make_Defining_Identifier (Loc, Name_uP),
3222 Parameter_Type =>
3223 New_Occurrence_Of (RTE (RE_Address), Loc)),
3224
3225 Make_Parameter_Specification (Loc, -- I
3226 Defining_Identifier =>
3227 Make_Defining_Identifier (Loc, Name_uI),
3228 Parameter_Type =>
3229 New_Occurrence_Of (Standard_Integer, Loc)),
3230
3231 Make_Parameter_Specification (Loc, -- A
3232 Defining_Identifier =>
3233 Make_Defining_Identifier (Loc, Name_uA),
3234 Parameter_Type =>
3235 New_Occurrence_Of (Standard_Boolean, Loc))));
3236 end Make_Disp_Requeue_Spec;
3237
3238 ---------------------------------
3239 -- Make_Disp_Timed_Select_Body --
3240 ---------------------------------
3241
3242 -- For interface types, generate:
3243
3244 -- procedure _Disp_Timed_Select
3245 -- (T : in out <Typ>;
3246 -- S : Integer;
3247 -- P : System.Address;
3248 -- D : Duration;
3249 -- M : Integer;
3250 -- C : out Ada.Tags.Prim_Op_Kind;
3251 -- F : out Boolean)
3252 -- is
3253 -- begin
3254 -- F := False;
3255 -- C := Ada.Tags.POK_Function;
3256 -- end _Disp_Timed_Select;
3257
3258 -- For protected types, generate:
3259
3260 -- procedure _Disp_Timed_Select
3261 -- (T : in out <Typ>;
3262 -- S : Integer;
3263 -- P : System.Address;
3264 -- D : Duration;
3265 -- M : Integer;
3266 -- C : out Ada.Tags.Prim_Op_Kind;
3267 -- F : out Boolean)
3268 -- is
3269 -- I : Integer;
3270
3271 -- begin
3272 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3273
3274 -- if C = Ada.Tags.POK_Procedure
3275 -- or else C = Ada.Tags.POK_Protected_Procedure
3276 -- or else C = Ada.Tags.POK_Task_Procedure
3277 -- then
3278 -- F := True;
3279 -- return;
3280 -- end if;
3281
3282 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3283 -- System.Tasking.Protected_Objects.Operations.
3284 -- Timed_Protected_Entry_Call
3285 -- (T._object'Access,
3286 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3287 -- P,
3288 -- D,
3289 -- M,
3290 -- F);
3291 -- end _Disp_Timed_Select;
3292
3293 -- For task types, generate:
3294
3295 -- procedure _Disp_Timed_Select
3296 -- (T : in out <Typ>;
3297 -- S : Integer;
3298 -- P : System.Address;
3299 -- D : Duration;
3300 -- M : Integer;
3301 -- C : out Ada.Tags.Prim_Op_Kind;
3302 -- F : out Boolean)
3303 -- is
3304 -- I : Integer;
3305
3306 -- begin
3307 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3308 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3309 -- (T._task_id,
3310 -- System.Tasking.Task_Entry_Index (I),
3311 -- P,
3312 -- D,
3313 -- M,
3314 -- F);
3315 -- end _Disp_Time_Select;
3316
3317 function Make_Disp_Timed_Select_Body
3318 (Typ : Entity_Id) return Node_Id
3319 is
3320 Loc : constant Source_Ptr := Sloc (Typ);
3321 Conc_Typ : Entity_Id := Empty;
3322 Decls : constant List_Id := New_List;
3323 Obj_Ref : Node_Id;
3324 Stmts : constant List_Id := New_List;
3325 Tag_Node : Node_Id;
3326
3327 begin
3328 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3329
3330 -- Null body is generated for interface types
3331
3332 if Is_Interface (Typ) then
3333 return
3334 Make_Subprogram_Body (Loc,
3335 Specification => Make_Disp_Timed_Select_Spec (Typ),
3336 Declarations => New_List,
3337 Handled_Statement_Sequence =>
3338 Make_Handled_Sequence_Of_Statements (Loc,
3339 New_List (
3340 Make_Assignment_Statement (Loc,
3341 Name => Make_Identifier (Loc, Name_uF),
3342 Expression => New_Occurrence_Of (Standard_False, Loc)))));
3343 end if;
3344
3345 if Is_Concurrent_Record_Type (Typ) then
3346 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3347
3348 -- Generate:
3349 -- I : Integer;
3350
3351 -- where I will be used to capture the entry index of the primitive
3352 -- wrapper at position S.
3353
3354 Append_To (Decls,
3355 Make_Object_Declaration (Loc,
3356 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3357 Object_Definition =>
3358 New_Occurrence_Of (Standard_Integer, Loc)));
3359
3360 -- Generate:
3361 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3362
3363 -- if C = POK_Procedure
3364 -- or else C = POK_Protected_Procedure
3365 -- or else C = POK_Task_Procedure;
3366 -- then
3367 -- F := True;
3368 -- return;
3369 -- end if;
3370
3371 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3372
3373 -- Generate:
3374 -- I := Get_Entry_Index (tag! (<type>VP), S);
3375
3376 -- I is the entry index and S is the dispatch table slot
3377
3378 if Tagged_Type_Expansion then
3379 Tag_Node :=
3380 Unchecked_Convert_To (RTE (RE_Tag),
3381 New_Occurrence_Of
3382 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3383
3384 else
3385 Tag_Node :=
3386 Make_Attribute_Reference (Loc,
3387 Prefix => New_Occurrence_Of (Typ, Loc),
3388 Attribute_Name => Name_Tag);
3389 end if;
3390
3391 Append_To (Stmts,
3392 Make_Assignment_Statement (Loc,
3393 Name => Make_Identifier (Loc, Name_uI),
3394 Expression =>
3395 Make_Function_Call (Loc,
3396 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
3397 Parameter_Associations => New_List (
3398 Tag_Node,
3399 Make_Identifier (Loc, Name_uS)))));
3400
3401 -- Protected case
3402
3403 if Ekind (Conc_Typ) = E_Protected_Type then
3404
3405 -- Build T._object'Access
3406
3407 Obj_Ref :=
3408 Make_Attribute_Reference (Loc,
3409 Attribute_Name => Name_Unchecked_Access,
3410 Prefix =>
3411 Make_Selected_Component (Loc,
3412 Prefix => Make_Identifier (Loc, Name_uT),
3413 Selector_Name => Make_Identifier (Loc, Name_uObject)));
3414
3415 -- Normal case, No_Entry_Queue restriction not active. In this
3416 -- case we generate:
3417
3418 -- Timed_Protected_Entry_Call
3419 -- (T._object'access,
3420 -- Protected_Entry_Index! (I),
3421 -- P, D, M, F);
3422
3423 -- where T is the protected object, I is the entry index, P are
3424 -- the wrapped parameters, D is the delay amount, M is the delay
3425 -- mode and F is the status flag.
3426
3427 -- Historically, there was also an implementation for single
3428 -- entry protected types (in s-tposen). However, it was removed
3429 -- by also testing for no No_Select_Statements restriction in
3430 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3431 -- implementation of s-tposen.adb and provided consistency between
3432 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3433 -- (s-tposen*.adb).
3434
3435 case Corresponding_Runtime_Package (Conc_Typ) is
3436 when System_Tasking_Protected_Objects_Entries =>
3437 Append_To (Stmts,
3438 Make_Procedure_Call_Statement (Loc,
3439 Name =>
3440 New_Occurrence_Of
3441 (RTE (RE_Timed_Protected_Entry_Call), Loc),
3442 Parameter_Associations => New_List (
3443 Obj_Ref,
3444
3445 Make_Unchecked_Type_Conversion (Loc, -- entry index
3446 Subtype_Mark =>
3447 New_Occurrence_Of
3448 (RTE (RE_Protected_Entry_Index), Loc),
3449 Expression => Make_Identifier (Loc, Name_uI)),
3450
3451 Make_Identifier (Loc, Name_uP), -- parameter block
3452 Make_Identifier (Loc, Name_uD), -- delay
3453 Make_Identifier (Loc, Name_uM), -- delay mode
3454 Make_Identifier (Loc, Name_uF)))); -- status flag
3455
3456 when others =>
3457 raise Program_Error;
3458 end case;
3459
3460 -- Task case
3461
3462 else
3463 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3464
3465 -- Generate:
3466 -- Timed_Task_Entry_Call (
3467 -- T._task_id,
3468 -- Task_Entry_Index! (I),
3469 -- P,
3470 -- D,
3471 -- M,
3472 -- F);
3473
3474 -- where T is the task object, I is the entry index, P are the
3475 -- wrapped parameters, D is the delay amount, M is the delay
3476 -- mode and F is the status flag.
3477
3478 Append_To (Stmts,
3479 Make_Procedure_Call_Statement (Loc,
3480 Name =>
3481 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
3482
3483 Parameter_Associations => New_List (
3484 Make_Selected_Component (Loc, -- T._task_id
3485 Prefix => Make_Identifier (Loc, Name_uT),
3486 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3487
3488 Make_Unchecked_Type_Conversion (Loc, -- entry index
3489 Subtype_Mark =>
3490 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3491 Expression => Make_Identifier (Loc, Name_uI)),
3492
3493 Make_Identifier (Loc, Name_uP), -- parameter block
3494 Make_Identifier (Loc, Name_uD), -- delay
3495 Make_Identifier (Loc, Name_uM), -- delay mode
3496 Make_Identifier (Loc, Name_uF)))); -- status flag
3497 end if;
3498
3499 else
3500 -- Initialize out parameters
3501
3502 Append_To (Stmts,
3503 Make_Assignment_Statement (Loc,
3504 Name => Make_Identifier (Loc, Name_uF),
3505 Expression => New_Occurrence_Of (Standard_False, Loc)));
3506 Append_To (Stmts,
3507 Make_Assignment_Statement (Loc,
3508 Name => Make_Identifier (Loc, Name_uC),
3509 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
3510 end if;
3511
3512 return
3513 Make_Subprogram_Body (Loc,
3514 Specification => Make_Disp_Timed_Select_Spec (Typ),
3515 Declarations => Decls,
3516 Handled_Statement_Sequence =>
3517 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3518 end Make_Disp_Timed_Select_Body;
3519
3520 ---------------------------------
3521 -- Make_Disp_Timed_Select_Spec --
3522 ---------------------------------
3523
3524 function Make_Disp_Timed_Select_Spec
3525 (Typ : Entity_Id) return Node_Id
3526 is
3527 Loc : constant Source_Ptr := Sloc (Typ);
3528 Def_Id : constant Node_Id :=
3529 Make_Defining_Identifier (Loc,
3530 Name_uDisp_Timed_Select);
3531 Params : constant List_Id := New_List;
3532
3533 begin
3534 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3535
3536 -- T : in out Typ; -- Object parameter
3537 -- S : Integer; -- Primitive operation slot
3538 -- P : Address; -- Wrapped parameters
3539 -- D : Duration; -- Delay
3540 -- M : Integer; -- Delay Mode
3541 -- C : out Prim_Op_Kind; -- Call kind
3542 -- F : out Boolean; -- Status flag
3543
3544 Append_List_To (Params, New_List (
3545
3546 Make_Parameter_Specification (Loc,
3547 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3548 Parameter_Type => New_Occurrence_Of (Typ, Loc),
3549 In_Present => True,
3550 Out_Present => True),
3551
3552 Make_Parameter_Specification (Loc,
3553 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3554 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3555
3556 Make_Parameter_Specification (Loc,
3557 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
3558 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
3559
3560 Make_Parameter_Specification (Loc,
3561 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
3562 Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)),
3563
3564 Make_Parameter_Specification (Loc,
3565 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
3566 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3567
3568 Make_Parameter_Specification (Loc,
3569 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3570 Parameter_Type =>
3571 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3572 Out_Present => True)));
3573
3574 Append_To (Params,
3575 Make_Parameter_Specification (Loc,
3576 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
3577 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
3578 Out_Present => True));
3579
3580 return
3581 Make_Procedure_Specification (Loc,
3582 Defining_Unit_Name => Def_Id,
3583 Parameter_Specifications => Params);
3584 end Make_Disp_Timed_Select_Spec;
3585
3586 -------------
3587 -- Make_DT --
3588 -------------
3589
3590 -- The frontend supports two models for expanding dispatch tables
3591 -- associated with library-level defined tagged types: statically and
3592 -- non-statically allocated dispatch tables. In the former case the object
3593 -- containing the dispatch table is constant and it is initialized by means
3594 -- of a positional aggregate. In the latter case, the object containing
3595 -- the dispatch table is a variable which is initialized by means of
3596 -- assignments.
3597
3598 -- In case of locally defined tagged types, the object containing the
3599 -- object containing the dispatch table is always a variable (instead of a
3600 -- constant). This is currently required to give support to late overriding
3601 -- of primitives. For example:
3602
3603 -- procedure Example is
3604 -- package Pkg is
3605 -- type T1 is tagged null record;
3606 -- procedure Prim (O : T1);
3607 -- end Pkg;
3608
3609 -- type T2 is new Pkg.T1 with null record;
3610 -- procedure Prim (X : T2) is -- late overriding
3611 -- begin
3612 -- ...
3613 -- ...
3614 -- end;
3615
3616 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3617 Loc : constant Source_Ptr := Sloc (Typ);
3618
3619 Max_Predef_Prims : constant Int :=
3620 UI_To_Int
3621 (Intval
3622 (Expression
3623 (Parent (RTE (RE_Max_Predef_Prims)))));
3624
3625 DT_Decl : constant Elist_Id := New_Elmt_List;
3626 DT_Aggr : constant Elist_Id := New_Elmt_List;
3627 -- Entities marked with attribute Is_Dispatch_Table_Entity
3628
3629 procedure Check_Premature_Freezing
3630 (Subp : Entity_Id;
3631 Tagged_Type : Entity_Id;
3632 Typ : Entity_Id);
3633 -- Verify that all untagged types in the profile of a subprogram are
3634 -- frozen at the point the subprogram is frozen. This enforces the rule
3635 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3636 -- is frozen, enough must be known about it to build the activation
3637 -- record for it, which requires at least that the size of all
3638 -- parameters be known. Controlling arguments are by-reference,
3639 -- and therefore the rule only applies to untagged types. Typical
3640 -- violation of the rule involves an object declaration that freezes a
3641 -- tagged type, when one of its primitive operations has a type in its
3642 -- profile whose full view has not been analyzed yet. More complex cases
3643 -- involve composite types that have one private unfrozen subcomponent.
3644
3645 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3646 -- Export the dispatch table DT of tagged type Typ. Required to generate
3647 -- forward references and statically allocate the table. For primary
3648 -- dispatch tables Index is 0; for secondary dispatch tables the value
3649 -- of index must match the Suffix_Index value assigned to the table by
3650 -- Make_Tags when generating its unique external name, and it is used to
3651 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3652 -- the external name generated by Import_DT.
3653
3654 procedure Make_Secondary_DT
3655 (Typ : Entity_Id;
3656 Iface : Entity_Id;
3657 Suffix_Index : Int;
3658 Num_Iface_Prims : Nat;
3659 Iface_DT_Ptr : Entity_Id;
3660 Predef_Prims_Ptr : Entity_Id;
3661 Build_Thunks : Boolean;
3662 Result : List_Id);
3663 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3664 -- Table of Typ associated with Iface. Each abstract interface of Typ
3665 -- has two secondary dispatch tables: one containing pointers to thunks
3666 -- and another containing pointers to the primitives covering the
3667 -- interface primitives. The former secondary table is generated when
3668 -- Build_Thunks is True, and provides common support for dispatching
3669 -- calls through interface types; the latter secondary table is
3670 -- generated when Build_Thunks is False, and provides support for
3671 -- Generic Dispatching Constructors that dispatch calls through
3672 -- interface types. When constructing this latter table the value of
3673 -- Suffix_Index is -1 to indicate that there is no need to export such
3674 -- table when building statically allocated dispatch tables; a positive
3675 -- value of Suffix_Index must match the Suffix_Index value assigned to
3676 -- this secondary dispatch table by Make_Tags when its unique external
3677 -- name was generated.
3678
3679 ------------------------------
3680 -- Check_Premature_Freezing --
3681 ------------------------------
3682
3683 procedure Check_Premature_Freezing
3684 (Subp : Entity_Id;
3685 Tagged_Type : Entity_Id;
3686 Typ : Entity_Id)
3687 is
3688 Comp : Entity_Id;
3689
3690 function Is_Actual_For_Formal_Incomplete_Type
3691 (T : Entity_Id) return Boolean;
3692 -- In Ada 2012, if a nested generic has an incomplete formal type,
3693 -- the actual may be (and usually is) a private type whose completion
3694 -- appears later. It is safe to build the dispatch table in this
3695 -- case, gigi will have full views available.
3696
3697 ------------------------------------------
3698 -- Is_Actual_For_Formal_Incomplete_Type --
3699 ------------------------------------------
3700
3701 function Is_Actual_For_Formal_Incomplete_Type
3702 (T : Entity_Id) return Boolean
3703 is
3704 Gen_Par : Entity_Id;
3705 F : Node_Id;
3706
3707 begin
3708 if not Is_Generic_Instance (Current_Scope)
3709 or else not Used_As_Generic_Actual (T)
3710 then
3711 return False;
3712 else
3713 Gen_Par := Generic_Parent (Parent (Current_Scope));
3714 end if;
3715
3716 F :=
3717 First
3718 (Generic_Formal_Declarations
3719 (Unit_Declaration_Node (Gen_Par)));
3720 while Present (F) loop
3721 if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3722 return True;
3723 end if;
3724
3725 Next (F);
3726 end loop;
3727
3728 return False;
3729 end Is_Actual_For_Formal_Incomplete_Type;
3730
3731 -- Start of processing for Check_Premature_Freezing
3732
3733 begin
3734 -- Note that if the type is a (subtype of) a generic actual, the
3735 -- actual will have been frozen by the instantiation.
3736
3737 if Present (N)
3738 and then Is_Private_Type (Typ)
3739 and then No (Full_View (Typ))
3740 and then not Is_Generic_Type (Typ)
3741 and then not Is_Tagged_Type (Typ)
3742 and then not Is_Frozen (Typ)
3743 and then not Is_Generic_Actual_Type (Typ)
3744 then
3745 Error_Msg_Sloc := Sloc (Subp);
3746 Error_Msg_NE
3747 ("declaration must appear after completion of type &", N, Typ);
3748 Error_Msg_NE
3749 ("\which is an untagged type in the profile of "
3750 & "primitive operation & declared#", N, Subp);
3751
3752 else
3753 Comp := Private_Component (Typ);
3754
3755 if not Is_Tagged_Type (Typ)
3756 and then Present (Comp)
3757 and then not Is_Frozen (Comp)
3758 and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
3759 then
3760 Error_Msg_Sloc := Sloc (Subp);
3761 Error_Msg_Node_2 := Subp;
3762 Error_Msg_Name_1 := Chars (Tagged_Type);
3763 Error_Msg_NE
3764 ("declaration must appear after completion of type &",
3765 N, Comp);
3766 Error_Msg_NE
3767 ("\which is a component of untagged type& in the profile "
3768 & "of primitive & of type % that is frozen by the "
3769 & "declaration ", N, Typ);
3770 end if;
3771 end if;
3772 end Check_Premature_Freezing;
3773
3774 ---------------
3775 -- Export_DT --
3776 ---------------
3777
3778 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3779 is
3780 Count : Nat;
3781 Elmt : Elmt_Id;
3782
3783 begin
3784 Set_Is_Statically_Allocated (DT);
3785 Set_Is_True_Constant (DT);
3786 Set_Is_Exported (DT);
3787
3788 Count := 0;
3789 Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
3790 while Count /= Index loop
3791 Next_Elmt (Elmt);
3792 Count := Count + 1;
3793 end loop;
3794
3795 pragma Assert (Related_Type (Node (Elmt)) = Typ);
3796
3797 Get_External_Name (Node (Elmt));
3798 Set_Interface_Name (DT,
3799 Make_String_Literal (Loc,
3800 Strval => String_From_Name_Buffer));
3801
3802 -- Ensure proper Sprint output of this implicit importation
3803
3804 Set_Is_Internal (DT);
3805 Set_Is_Public (DT);
3806 end Export_DT;
3807
3808 -----------------------
3809 -- Make_Secondary_DT --
3810 -----------------------
3811
3812 procedure Make_Secondary_DT
3813 (Typ : Entity_Id;
3814 Iface : Entity_Id;
3815 Suffix_Index : Int;
3816 Num_Iface_Prims : Nat;
3817 Iface_DT_Ptr : Entity_Id;
3818 Predef_Prims_Ptr : Entity_Id;
3819 Build_Thunks : Boolean;
3820 Result : List_Id)
3821 is
3822 Loc : constant Source_Ptr := Sloc (Typ);
3823 Exporting_Table : constant Boolean :=
3824 Building_Static_DT (Typ)
3825 and then Suffix_Index > 0;
3826 Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T');
3827 Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R');
3828 DT_Constr_List : List_Id;
3829 DT_Aggr_List : List_Id;
3830 Empty_DT : Boolean := False;
3831 Nb_Predef_Prims : Nat := 0;
3832 Nb_Prim : Nat;
3833 New_Node : Node_Id;
3834 OSD : Entity_Id;
3835 OSD_Aggr_List : List_Id;
3836 Pos : Nat;
3837 Prim : Entity_Id;
3838 Prim_Elmt : Elmt_Id;
3839 Prim_Ops_Aggr_List : List_Id;
3840
3841 begin
3842 -- Handle cases in which we do not generate statically allocated
3843 -- dispatch tables.
3844
3845 if not Building_Static_DT (Typ) then
3846 Set_Ekind (Predef_Prims, E_Variable);
3847 Set_Ekind (Iface_DT, E_Variable);
3848
3849 -- Statically allocated dispatch tables and related entities are
3850 -- constants.
3851
3852 else
3853 Set_Ekind (Predef_Prims, E_Constant);
3854 Set_Is_Statically_Allocated (Predef_Prims);
3855 Set_Is_True_Constant (Predef_Prims);
3856
3857 Set_Ekind (Iface_DT, E_Constant);
3858 Set_Is_Statically_Allocated (Iface_DT);
3859 Set_Is_True_Constant (Iface_DT);
3860 end if;
3861
3862 -- Calculate the number of slots of the dispatch table. If the number
3863 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3864 -- DT because at run time the pointer to this dummy entry will be
3865 -- used as the tag.
3866
3867 if Num_Iface_Prims = 0 then
3868 Empty_DT := True;
3869 Nb_Prim := 1;
3870 else
3871 Nb_Prim := Num_Iface_Prims;
3872 end if;
3873
3874 -- Generate:
3875
3876 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3877 -- (predef-prim-op-thunk-1'address,
3878 -- predef-prim-op-thunk-2'address,
3879 -- ...
3880 -- predef-prim-op-thunk-n'address);
3881 -- for Predef_Prims'Alignment use Address'Alignment
3882
3883 -- Stage 1: Calculate the number of predefined primitives
3884
3885 if not Building_Static_DT (Typ) then
3886 Nb_Predef_Prims := Max_Predef_Prims;
3887 else
3888 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3889 while Present (Prim_Elmt) loop
3890 Prim := Node (Prim_Elmt);
3891
3892 if Is_Predefined_Dispatching_Operation (Prim)
3893 and then not Is_Abstract_Subprogram (Prim)
3894 then
3895 Pos := UI_To_Int (DT_Position (Prim));
3896
3897 if Pos > Nb_Predef_Prims then
3898 Nb_Predef_Prims := Pos;
3899 end if;
3900 end if;
3901
3902 Next_Elmt (Prim_Elmt);
3903 end loop;
3904 end if;
3905
3906 if Generate_SCIL then
3907 Nb_Predef_Prims := 0;
3908 end if;
3909
3910 -- Stage 2: Create the thunks associated with the predefined
3911 -- primitives and save their entity to fill the aggregate.
3912
3913 declare
3914 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
3915 Decl : Node_Id;
3916 Thunk_Id : Entity_Id;
3917 Thunk_Code : Node_Id;
3918
3919 begin
3920 Prim_Ops_Aggr_List := New_List;
3921 Prim_Table := (others => Empty);
3922
3923 if Building_Static_DT (Typ) then
3924 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3925 while Present (Prim_Elmt) loop
3926 Prim := Node (Prim_Elmt);
3927
3928 if Is_Predefined_Dispatching_Operation (Prim)
3929 and then not Is_Abstract_Subprogram (Prim)
3930 and then not Is_Eliminated (Prim)
3931 and then not Generate_SCIL
3932 and then not Present (Prim_Table
3933 (UI_To_Int (DT_Position (Prim))))
3934 then
3935 if not Build_Thunks then
3936 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
3937 Alias (Prim);
3938
3939 else
3940 Expand_Interface_Thunk
3941 (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
3942
3943 if Present (Thunk_Id) then
3944 Append_To (Result, Thunk_Code);
3945 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
3946 Thunk_Id;
3947 end if;
3948 end if;
3949 end if;
3950
3951 Next_Elmt (Prim_Elmt);
3952 end loop;
3953 end if;
3954
3955 for J in Prim_Table'Range loop
3956 if Present (Prim_Table (J)) then
3957 New_Node :=
3958 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3959 Make_Attribute_Reference (Loc,
3960 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
3961 Attribute_Name => Name_Unrestricted_Access));
3962 else
3963 New_Node := Make_Null (Loc);
3964 end if;
3965
3966 Append_To (Prim_Ops_Aggr_List, New_Node);
3967 end loop;
3968
3969 New_Node :=
3970 Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List);
3971
3972 -- Remember aggregates initializing dispatch tables
3973
3974 Append_Elmt (New_Node, DT_Aggr);
3975
3976 Decl :=
3977 Make_Subtype_Declaration (Loc,
3978 Defining_Identifier => Make_Temporary (Loc, 'S'),
3979 Subtype_Indication =>
3980 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
3981
3982 Append_To (Result, Decl);
3983
3984 Append_To (Result,
3985 Make_Object_Declaration (Loc,
3986 Defining_Identifier => Predef_Prims,
3987 Constant_Present => Building_Static_DT (Typ),
3988 Aliased_Present => True,
3989 Object_Definition => New_Occurrence_Of
3990 (Defining_Identifier (Decl), Loc),
3991 Expression => New_Node));
3992
3993 Append_To (Result,
3994 Make_Attribute_Definition_Clause (Loc,
3995 Name => New_Occurrence_Of (Predef_Prims, Loc),
3996 Chars => Name_Alignment,
3997 Expression =>
3998 Make_Attribute_Reference (Loc,
3999 Prefix =>
4000 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4001 Attribute_Name => Name_Alignment)));
4002 end;
4003
4004 -- Generate
4005
4006 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4007 -- (OSD_Table => (1 => <value>,
4008 -- ...
4009 -- N => <value>));
4010
4011 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4012 -- ([ Signature => <sig-value> ],
4013 -- Tag_Kind => <tag_kind-value>,
4014 -- Predef_Prims => Predef_Prims'Address,
4015 -- Offset_To_Top => 0,
4016 -- OSD => OSD'Address,
4017 -- Prims_Ptr => (prim-op-1'address,
4018 -- prim-op-2'address,
4019 -- ...
4020 -- prim-op-n'address));
4021 -- for Iface_DT'Alignment use Address'Alignment;
4022
4023 -- Stage 3: Initialize the discriminant and the record components
4024
4025 DT_Constr_List := New_List;
4026 DT_Aggr_List := New_List;
4027
4028 -- Nb_Prim
4029
4030 Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4031 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4032
4033 -- Signature
4034
4035 if RTE_Record_Component_Available (RE_Signature) then
4036 Append_To (DT_Aggr_List,
4037 New_Occurrence_Of (RTE (RE_Secondary_DT), Loc));
4038 end if;
4039
4040 -- Tag_Kind
4041
4042 if RTE_Record_Component_Available (RE_Tag_Kind) then
4043 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4044 end if;
4045
4046 -- Predef_Prims
4047
4048 Append_To (DT_Aggr_List,
4049 Make_Attribute_Reference (Loc,
4050 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
4051 Attribute_Name => Name_Address));
4052
4053 -- Note: The correct value of Offset_To_Top will be set by the init
4054 -- subprogram
4055
4056 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4057
4058 -- Generate the Object Specific Data table required to dispatch calls
4059 -- through synchronized interfaces.
4060
4061 if Empty_DT
4062 or else Is_Abstract_Type (Typ)
4063 or else Is_Controlled (Typ)
4064 or else Restriction_Active (No_Dispatching_Calls)
4065 or else not Is_Limited_Type (Typ)
4066 or else not Has_Interfaces (Typ)
4067 or else not Build_Thunks
4068 or else not RTE_Record_Component_Available (RE_OSD_Table)
4069 then
4070 -- No OSD table required
4071
4072 Append_To (DT_Aggr_List,
4073 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
4074
4075 else
4076 OSD_Aggr_List := New_List;
4077
4078 declare
4079 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4080 Prim : Entity_Id;
4081 Prim_Alias : Entity_Id;
4082 Prim_Elmt : Elmt_Id;
4083 E : Entity_Id;
4084 Count : Nat := 0;
4085 Pos : Nat;
4086
4087 begin
4088 Prim_Table := (others => Empty);
4089 Prim_Alias := Empty;
4090
4091 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4092 while Present (Prim_Elmt) loop
4093 Prim := Node (Prim_Elmt);
4094
4095 if Present (Interface_Alias (Prim))
4096 and then Find_Dispatching_Type
4097 (Interface_Alias (Prim)) = Iface
4098 then
4099 Prim_Alias := Interface_Alias (Prim);
4100 E := Ultimate_Alias (Prim);
4101 Pos := UI_To_Int (DT_Position (Prim_Alias));
4102
4103 if Present (Prim_Table (Pos)) then
4104 pragma Assert (Prim_Table (Pos) = E);
4105 null;
4106
4107 else
4108 Prim_Table (Pos) := E;
4109
4110 Append_To (OSD_Aggr_List,
4111 Make_Component_Association (Loc,
4112 Choices => New_List (
4113 Make_Integer_Literal (Loc,
4114 DT_Position (Prim_Alias))),
4115 Expression =>
4116 Make_Integer_Literal (Loc,
4117 DT_Position (Alias (Prim)))));
4118
4119 Count := Count + 1;
4120 end if;
4121 end if;
4122
4123 Next_Elmt (Prim_Elmt);
4124 end loop;
4125 pragma Assert (Count = Nb_Prim);
4126 end;
4127
4128 OSD := Make_Temporary (Loc, 'I');
4129
4130 Append_To (Result,
4131 Make_Object_Declaration (Loc,
4132 Defining_Identifier => OSD,
4133 Object_Definition =>
4134 Make_Subtype_Indication (Loc,
4135 Subtype_Mark =>
4136 New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
4137 Constraint =>
4138 Make_Index_Or_Discriminant_Constraint (Loc,
4139 Constraints => New_List (
4140 Make_Integer_Literal (Loc, Nb_Prim)))),
4141
4142 Expression =>
4143 Make_Aggregate (Loc,
4144 Component_Associations => New_List (
4145 Make_Component_Association (Loc,
4146 Choices => New_List (
4147 New_Occurrence_Of
4148 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4149 Expression =>
4150 Make_Integer_Literal (Loc, Nb_Prim)),
4151
4152 Make_Component_Association (Loc,
4153 Choices => New_List (
4154 New_Occurrence_Of
4155 (RTE_Record_Component (RE_OSD_Table), Loc)),
4156 Expression => Make_Aggregate (Loc,
4157 Component_Associations => OSD_Aggr_List))))));
4158
4159 Append_To (Result,
4160 Make_Attribute_Definition_Clause (Loc,
4161 Name => New_Occurrence_Of (OSD, Loc),
4162 Chars => Name_Alignment,
4163 Expression =>
4164 Make_Attribute_Reference (Loc,
4165 Prefix =>
4166 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4167 Attribute_Name => Name_Alignment)));
4168
4169 -- In secondary dispatch tables the Typeinfo component contains
4170 -- the address of the Object Specific Data (see a-tags.ads)
4171
4172 Append_To (DT_Aggr_List,
4173 Make_Attribute_Reference (Loc,
4174 Prefix => New_Occurrence_Of (OSD, Loc),
4175 Attribute_Name => Name_Address));
4176 end if;
4177
4178 -- Initialize the table of primitive operations
4179
4180 Prim_Ops_Aggr_List := New_List;
4181
4182 if Empty_DT then
4183 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4184
4185 elsif Is_Abstract_Type (Typ)
4186 or else not Building_Static_DT (Typ)
4187 then
4188 for J in 1 .. Nb_Prim loop
4189 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4190 end loop;
4191
4192 else
4193 declare
4194 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4195 E : Entity_Id;
4196 Prim_Pos : Nat;
4197 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4198 Thunk_Code : Node_Id;
4199 Thunk_Id : Entity_Id;
4200
4201 begin
4202 Prim_Table := (others => Empty);
4203
4204 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4205 while Present (Prim_Elmt) loop
4206 Prim := Node (Prim_Elmt);
4207 E := Ultimate_Alias (Prim);
4208 Prim_Pos := UI_To_Int (DT_Position (E));
4209
4210 -- Do not reference predefined primitives because they are
4211 -- located in a separate dispatch table; skip abstract and
4212 -- eliminated primitives; skip primitives located in the C++
4213 -- part of the dispatch table because their slot is set by
4214 -- the IC routine.
4215
4216 if not Is_Predefined_Dispatching_Operation (Prim)
4217 and then Present (Interface_Alias (Prim))
4218 and then not Is_Abstract_Subprogram (Alias (Prim))
4219 and then not Is_Eliminated (Alias (Prim))
4220 and then (not Is_CPP_Class (Root_Type (Typ))
4221 or else Prim_Pos > CPP_Nb_Prims)
4222 and then Find_Dispatching_Type
4223 (Interface_Alias (Prim)) = Iface
4224
4225 -- Generate the code of the thunk only if the abstract
4226 -- interface type is not an immediate ancestor of
4227 -- Tagged_Type. Otherwise the DT associated with the
4228 -- interface is the primary DT.
4229
4230 and then not Is_Ancestor (Iface, Typ,
4231 Use_Full_View => True)
4232 then
4233 if not Build_Thunks then
4234 Prim_Pos :=
4235 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4236 Prim_Table (Prim_Pos) := Alias (Prim);
4237
4238 else
4239 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4240
4241 if Present (Thunk_Id) then
4242 Prim_Pos :=
4243 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4244
4245 Prim_Table (Prim_Pos) := Thunk_Id;
4246 Append_To (Result, Thunk_Code);
4247 end if;
4248 end if;
4249 end if;
4250
4251 Next_Elmt (Prim_Elmt);
4252 end loop;
4253
4254 for J in Prim_Table'Range loop
4255 if Present (Prim_Table (J)) then
4256 New_Node :=
4257 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4258 Make_Attribute_Reference (Loc,
4259 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4260 Attribute_Name => Name_Unrestricted_Access));
4261
4262 else
4263 New_Node := Make_Null (Loc);
4264 end if;
4265
4266 Append_To (Prim_Ops_Aggr_List, New_Node);
4267 end loop;
4268 end;
4269 end if;
4270
4271 New_Node :=
4272 Make_Aggregate (Loc,
4273 Expressions => Prim_Ops_Aggr_List);
4274
4275 Append_To (DT_Aggr_List, New_Node);
4276
4277 -- Remember aggregates initializing dispatch tables
4278
4279 Append_Elmt (New_Node, DT_Aggr);
4280
4281 -- Note: Secondary dispatch tables cannot be declared constant
4282 -- because the component Offset_To_Top is currently initialized
4283 -- by the IP routine.
4284
4285 Append_To (Result,
4286 Make_Object_Declaration (Loc,
4287 Defining_Identifier => Iface_DT,
4288 Aliased_Present => True,
4289 Constant_Present => False,
4290
4291 Object_Definition =>
4292 Make_Subtype_Indication (Loc,
4293 Subtype_Mark => New_Occurrence_Of
4294 (RTE (RE_Dispatch_Table_Wrapper), Loc),
4295 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4296 Constraints => DT_Constr_List)),
4297
4298 Expression =>
4299 Make_Aggregate (Loc,
4300 Expressions => DT_Aggr_List)));
4301
4302 Append_To (Result,
4303 Make_Attribute_Definition_Clause (Loc,
4304 Name => New_Occurrence_Of (Iface_DT, Loc),
4305 Chars => Name_Alignment,
4306
4307 Expression =>
4308 Make_Attribute_Reference (Loc,
4309 Prefix =>
4310 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4311 Attribute_Name => Name_Alignment)));
4312
4313 if Exporting_Table then
4314 Export_DT (Typ, Iface_DT, Suffix_Index);
4315
4316 -- Generate code to create the pointer to the dispatch table
4317
4318 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4319
4320 -- Note: This declaration is not added here if the table is exported
4321 -- because in such case Make_Tags has already added this declaration.
4322
4323 else
4324 Append_To (Result,
4325 Make_Object_Declaration (Loc,
4326 Defining_Identifier => Iface_DT_Ptr,
4327 Constant_Present => True,
4328
4329 Object_Definition =>
4330 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc),
4331
4332 Expression =>
4333 Unchecked_Convert_To (RTE (RE_Interface_Tag),
4334 Make_Attribute_Reference (Loc,
4335 Prefix =>
4336 Make_Selected_Component (Loc,
4337 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4338 Selector_Name =>
4339 New_Occurrence_Of
4340 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4341 Attribute_Name => Name_Address))));
4342 end if;
4343
4344 Append_To (Result,
4345 Make_Object_Declaration (Loc,
4346 Defining_Identifier => Predef_Prims_Ptr,
4347 Constant_Present => True,
4348
4349 Object_Definition =>
4350 New_Occurrence_Of (RTE (RE_Address), Loc),
4351
4352 Expression =>
4353 Make_Attribute_Reference (Loc,
4354 Prefix =>
4355 Make_Selected_Component (Loc,
4356 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4357 Selector_Name =>
4358 New_Occurrence_Of
4359 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4360 Attribute_Name => Name_Address)));
4361
4362 -- Remember entities containing dispatch tables
4363
4364 Append_Elmt (Predef_Prims, DT_Decl);
4365 Append_Elmt (Iface_DT, DT_Decl);
4366 end Make_Secondary_DT;
4367
4368 -- Local variables
4369
4370 Elab_Code : constant List_Id := New_List;
4371 Result : constant List_Id := New_List;
4372 Tname : constant Name_Id := Chars (Typ);
4373 AI : Elmt_Id;
4374 AI_Tag_Elmt : Elmt_Id;
4375 AI_Tag_Comp : Elmt_Id;
4376 DT_Aggr_List : List_Id;
4377 DT_Constr_List : List_Id;
4378 DT_Ptr : Entity_Id;
4379 ITable : Node_Id;
4380 I_Depth : Nat := 0;
4381 Iface_Table_Node : Node_Id;
4382 Name_ITable : Name_Id;
4383 Nb_Predef_Prims : Nat := 0;
4384 Nb_Prim : Nat := 0;
4385 New_Node : Node_Id;
4386 Num_Ifaces : Nat := 0;
4387 Parent_Typ : Entity_Id;
4388 Prim : Entity_Id;
4389 Prim_Elmt : Elmt_Id;
4390 Prim_Ops_Aggr_List : List_Id;
4391 Suffix_Index : Int;
4392 Typ_Comps : Elist_Id;
4393 Typ_Ifaces : Elist_Id;
4394 TSD_Aggr_List : List_Id;
4395 TSD_Tags_List : List_Id;
4396
4397 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4398
4399 -- The following name entries are used by Make_DT to generate a number
4400 -- of entities related to a tagged type. These entities may be generated
4401 -- in a scope other than that of the tagged type declaration, and if
4402 -- the entities for two tagged types with the same name happen to be
4403 -- generated in the same scope, we have to take care to use different
4404 -- names. This is achieved by means of a unique serial number appended
4405 -- to each generated entity name.
4406
4407 Name_DT : constant Name_Id :=
4408 New_External_Name (Tname, 'T', Suffix_Index => -1);
4409 Name_Exname : constant Name_Id :=
4410 New_External_Name (Tname, 'E', Suffix_Index => -1);
4411 Name_HT_Link : constant Name_Id :=
4412 New_External_Name (Tname, 'H', Suffix_Index => -1);
4413 Name_Predef_Prims : constant Name_Id :=
4414 New_External_Name (Tname, 'R', Suffix_Index => -1);
4415 Name_SSD : constant Name_Id :=
4416 New_External_Name (Tname, 'S', Suffix_Index => -1);
4417 Name_TSD : constant Name_Id :=
4418 New_External_Name (Tname, 'B', Suffix_Index => -1);
4419
4420 -- Entities built with above names
4421
4422 DT : constant Entity_Id :=
4423 Make_Defining_Identifier (Loc, Name_DT);
4424 Exname : constant Entity_Id :=
4425 Make_Defining_Identifier (Loc, Name_Exname);
4426 HT_Link : constant Entity_Id :=
4427 Make_Defining_Identifier (Loc, Name_HT_Link);
4428 Predef_Prims : constant Entity_Id :=
4429 Make_Defining_Identifier (Loc, Name_Predef_Prims);
4430 SSD : constant Entity_Id :=
4431 Make_Defining_Identifier (Loc, Name_SSD);
4432 TSD : constant Entity_Id :=
4433 Make_Defining_Identifier (Loc, Name_TSD);
4434
4435 -- Start of processing for Make_DT
4436
4437 begin
4438 pragma Assert (Is_Frozen (Typ));
4439
4440 -- The tagged type being processed may be subject to pragma Ghost. Set
4441 -- the mode now to ensure that any nodes generated during dispatch table
4442 -- creation are properly marked as Ghost.
4443
4444 Set_Ghost_Mode (Declaration_Node (Typ), Typ);
4445
4446 -- Handle cases in which there is no need to build the dispatch table
4447
4448 if Has_Dispatch_Table (Typ)
4449 or else No (Access_Disp_Table (Typ))
4450 or else Is_CPP_Class (Typ)
4451 then
4452 Ghost_Mode := Save_Ghost_Mode;
4453 return Result;
4454
4455 elsif No_Run_Time_Mode then
4456 Error_Msg_CRT ("tagged types", Typ);
4457 Ghost_Mode := Save_Ghost_Mode;
4458 return Result;
4459
4460 elsif not RTE_Available (RE_Tag) then
4461 Append_To (Result,
4462 Make_Object_Declaration (Loc,
4463 Defining_Identifier => Node (First_Elmt
4464 (Access_Disp_Table (Typ))),
4465 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4466 Constant_Present => True,
4467 Expression =>
4468 Unchecked_Convert_To (RTE (RE_Tag),
4469 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
4470
4471 Analyze_List (Result, Suppress => All_Checks);
4472 Error_Msg_CRT ("tagged types", Typ);
4473 Ghost_Mode := Save_Ghost_Mode;
4474 return Result;
4475 end if;
4476
4477 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4478 -- correct. Valid values are 9 under configurable runtime or 15
4479 -- with full runtime.
4480
4481 if RTE_Available (RE_Interface_Data) then
4482 if Max_Predef_Prims /= 15 then
4483 Error_Msg_N ("run-time library configuration error", Typ);
4484 Ghost_Mode := Save_Ghost_Mode;
4485 return Result;
4486 end if;
4487 else
4488 if Max_Predef_Prims /= 9 then
4489 Error_Msg_N ("run-time library configuration error", Typ);
4490 Error_Msg_CRT ("tagged types", Typ);
4491 Ghost_Mode := Save_Ghost_Mode;
4492 return Result;
4493 end if;
4494 end if;
4495
4496 -- Initialize Parent_Typ handling private types
4497
4498 Parent_Typ := Etype (Typ);
4499
4500 if Present (Full_View (Parent_Typ)) then
4501 Parent_Typ := Full_View (Parent_Typ);
4502 end if;
4503
4504 -- Ensure that all the primitives are frozen. This is only required when
4505 -- building static dispatch tables --- the primitives must be frozen to
4506 -- be referenced (otherwise we have problems with the backend). It is
4507 -- not a requirement with nonstatic dispatch tables because in this case
4508 -- we generate now an empty dispatch table; the extra code required to
4509 -- register the primitives in the slots will be generated later --- when
4510 -- each primitive is frozen (see Freeze_Subprogram).
4511
4512 if Building_Static_DT (Typ) then
4513 declare
4514 Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
4515 Prim : Entity_Id;
4516 Prim_Elmt : Elmt_Id;
4517 Frnodes : List_Id;
4518
4519 begin
4520 Freezing_Library_Level_Tagged_Type := True;
4521
4522 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4523 while Present (Prim_Elmt) loop
4524 Prim := Node (Prim_Elmt);
4525 Frnodes := Freeze_Entity (Prim, Typ);
4526
4527 declare
4528 F : Entity_Id;
4529
4530 begin
4531 F := First_Formal (Prim);
4532 while Present (F) loop
4533 Check_Premature_Freezing (Prim, Typ, Etype (F));
4534 Next_Formal (F);
4535 end loop;
4536
4537 Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4538 end;
4539
4540 if Present (Frnodes) then
4541 Append_List_To (Result, Frnodes);
4542 end if;
4543
4544 Next_Elmt (Prim_Elmt);
4545 end loop;
4546
4547 Freezing_Library_Level_Tagged_Type := Save;
4548 end;
4549 end if;
4550
4551 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4552
4553 if Has_Interfaces (Typ) then
4554 Collect_Interface_Components (Typ, Typ_Comps);
4555
4556 -- Each secondary dispatch table is assigned an unique positive
4557 -- suffix index; such value also corresponds with the location of
4558 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4559
4560 -- Note: This value must be kept sync with the Suffix_Index values
4561 -- generated by Make_Tags
4562
4563 Suffix_Index := 1;
4564 AI_Tag_Elmt :=
4565 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4566
4567 AI_Tag_Comp := First_Elmt (Typ_Comps);
4568 while Present (AI_Tag_Comp) loop
4569 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4570
4571 -- Build the secondary table containing pointers to thunks
4572
4573 Make_Secondary_DT
4574 (Typ => Typ,
4575 Iface => Base_Type
4576 (Related_Type (Node (AI_Tag_Comp))),
4577 Suffix_Index => Suffix_Index,
4578 Num_Iface_Prims => UI_To_Int
4579 (DT_Entry_Count (Node (AI_Tag_Comp))),
4580 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4581 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4582 Build_Thunks => True,
4583 Result => Result);
4584
4585 -- Skip secondary dispatch table referencing thunks to predefined
4586 -- primitives.
4587
4588 Next_Elmt (AI_Tag_Elmt);
4589 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4590
4591 -- Secondary dispatch table referencing user-defined primitives
4592 -- covered by this interface.
4593
4594 Next_Elmt (AI_Tag_Elmt);
4595 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4596
4597 -- Build the secondary table containing pointers to primitives
4598 -- (used to give support to Generic Dispatching Constructors).
4599
4600 Make_Secondary_DT
4601 (Typ => Typ,
4602 Iface => Base_Type
4603 (Related_Type (Node (AI_Tag_Comp))),
4604 Suffix_Index => -1,
4605 Num_Iface_Prims => UI_To_Int
4606 (DT_Entry_Count (Node (AI_Tag_Comp))),
4607 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4608 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4609 Build_Thunks => False,
4610 Result => Result);
4611
4612 -- Skip secondary dispatch table referencing predefined primitives
4613
4614 Next_Elmt (AI_Tag_Elmt);
4615 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4616
4617 Suffix_Index := Suffix_Index + 1;
4618 Next_Elmt (AI_Tag_Elmt);
4619 Next_Elmt (AI_Tag_Comp);
4620 end loop;
4621 end if;
4622
4623 -- Get the _tag entity and number of primitives of its dispatch table
4624
4625 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
4626 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4627
4628 if Generate_SCIL then
4629 Nb_Prim := 0;
4630 end if;
4631
4632 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
4633 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4634 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4635 Set_Is_Statically_Allocated (Predef_Prims,
4636 Is_Library_Level_Tagged_Type (Typ));
4637
4638 -- In case of locally defined tagged type we declare the object
4639 -- containing the dispatch table by means of a variable. Its
4640 -- initialization is done later by means of an assignment. This is
4641 -- required to generate its External_Tag.
4642
4643 if not Building_Static_DT (Typ) then
4644
4645 -- Generate:
4646 -- DT : No_Dispatch_Table_Wrapper;
4647 -- for DT'Alignment use Address'Alignment;
4648 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4649
4650 if not Has_DT (Typ) then
4651 Append_To (Result,
4652 Make_Object_Declaration (Loc,
4653 Defining_Identifier => DT,
4654 Aliased_Present => True,
4655 Constant_Present => False,
4656 Object_Definition =>
4657 New_Occurrence_Of
4658 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4659
4660 Append_To (Result,
4661 Make_Attribute_Definition_Clause (Loc,
4662 Name => New_Occurrence_Of (DT, Loc),
4663 Chars => Name_Alignment,
4664 Expression =>
4665 Make_Attribute_Reference (Loc,
4666 Prefix =>
4667 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4668 Attribute_Name => Name_Alignment)));
4669
4670 Append_To (Result,
4671 Make_Object_Declaration (Loc,
4672 Defining_Identifier => DT_Ptr,
4673 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4674 Constant_Present => True,
4675 Expression =>
4676 Unchecked_Convert_To (RTE (RE_Tag),
4677 Make_Attribute_Reference (Loc,
4678 Prefix =>
4679 Make_Selected_Component (Loc,
4680 Prefix => New_Occurrence_Of (DT, Loc),
4681 Selector_Name =>
4682 New_Occurrence_Of
4683 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4684 Attribute_Name => Name_Address))));
4685
4686 Set_Is_Statically_Allocated (DT_Ptr,
4687 Is_Library_Level_Tagged_Type (Typ));
4688
4689 -- Generate the SCIL node for the previous object declaration
4690 -- because it has a tag initialization.
4691
4692 if Generate_SCIL then
4693 New_Node :=
4694 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4695 Set_SCIL_Entity (New_Node, Typ);
4696 Set_SCIL_Node (Last (Result), New_Node);
4697
4698 goto Early_Exit_For_SCIL;
4699
4700 -- Gnat2scil has its own implementation of dispatch tables,
4701 -- different than what is being implemented here. Generating
4702 -- further dispatch table initialization code would just
4703 -- cause gnat2scil to generate useless Scil which CodePeer
4704 -- would waste time and space analyzing, so we skip it.
4705 end if;
4706
4707 -- Generate:
4708 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4709 -- for DT'Alignment use Address'Alignment;
4710 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4711
4712 else
4713 -- If the tagged type has no primitives we add a dummy slot
4714 -- whose address will be the tag of this type.
4715
4716 if Nb_Prim = 0 then
4717 DT_Constr_List :=
4718 New_List (Make_Integer_Literal (Loc, 1));
4719 else
4720 DT_Constr_List :=
4721 New_List (Make_Integer_Literal (Loc, Nb_Prim));
4722 end if;
4723
4724 Append_To (Result,
4725 Make_Object_Declaration (Loc,
4726 Defining_Identifier => DT,
4727 Aliased_Present => True,
4728 Constant_Present => False,
4729 Object_Definition =>
4730 Make_Subtype_Indication (Loc,
4731 Subtype_Mark =>
4732 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
4733 Constraint =>
4734 Make_Index_Or_Discriminant_Constraint (Loc,
4735 Constraints => DT_Constr_List))));
4736
4737 Append_To (Result,
4738 Make_Attribute_Definition_Clause (Loc,
4739 Name => New_Occurrence_Of (DT, Loc),
4740 Chars => Name_Alignment,
4741 Expression =>
4742 Make_Attribute_Reference (Loc,
4743 Prefix =>
4744 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4745 Attribute_Name => Name_Alignment)));
4746
4747 Append_To (Result,
4748 Make_Object_Declaration (Loc,
4749 Defining_Identifier => DT_Ptr,
4750 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4751 Constant_Present => True,
4752 Expression =>
4753 Unchecked_Convert_To (RTE (RE_Tag),
4754 Make_Attribute_Reference (Loc,
4755 Prefix =>
4756 Make_Selected_Component (Loc,
4757 Prefix => New_Occurrence_Of (DT, Loc),
4758 Selector_Name =>
4759 New_Occurrence_Of
4760 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4761 Attribute_Name => Name_Address))));
4762
4763 Set_Is_Statically_Allocated (DT_Ptr,
4764 Is_Library_Level_Tagged_Type (Typ));
4765
4766 -- Generate the SCIL node for the previous object declaration
4767 -- because it has a tag initialization.
4768
4769 if Generate_SCIL then
4770 New_Node :=
4771 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4772 Set_SCIL_Entity (New_Node, Typ);
4773 Set_SCIL_Node (Last (Result), New_Node);
4774
4775 goto Early_Exit_For_SCIL;
4776
4777 -- Gnat2scil has its own implementation of dispatch tables,
4778 -- different than what is being implemented here. Generating
4779 -- further dispatch table initialization code would just
4780 -- cause gnat2scil to generate useless Scil which CodePeer
4781 -- would waste time and space analyzing, so we skip it.
4782 end if;
4783
4784 Append_To (Result,
4785 Make_Object_Declaration (Loc,
4786 Defining_Identifier =>
4787 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4788 Constant_Present => True,
4789 Object_Definition =>
4790 New_Occurrence_Of (RTE (RE_Address), Loc),
4791 Expression =>
4792 Make_Attribute_Reference (Loc,
4793 Prefix =>
4794 Make_Selected_Component (Loc,
4795 Prefix => New_Occurrence_Of (DT, Loc),
4796 Selector_Name =>
4797 New_Occurrence_Of
4798 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4799 Attribute_Name => Name_Address)));
4800 end if;
4801 end if;
4802
4803 -- Generate: Exname : constant String := full_qualified_name (typ);
4804 -- The type itself may be an anonymous parent type, so use the first
4805 -- subtype to have a user-recognizable name.
4806
4807 Append_To (Result,
4808 Make_Object_Declaration (Loc,
4809 Defining_Identifier => Exname,
4810 Constant_Present => True,
4811 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4812 Expression =>
4813 Make_String_Literal (Loc,
4814 Strval => Fully_Qualified_Name_String (First_Subtype (Typ)))));
4815 Set_Is_Statically_Allocated (Exname);
4816 Set_Is_True_Constant (Exname);
4817
4818 -- Declare the object used by Ada.Tags.Register_Tag
4819
4820 if RTE_Available (RE_Register_Tag) then
4821 Append_To (Result,
4822 Make_Object_Declaration (Loc,
4823 Defining_Identifier => HT_Link,
4824 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc)));
4825 end if;
4826
4827 -- Generate code to create the storage for the type specific data object
4828 -- with enough space to store the tags of the ancestors plus the tags
4829 -- of all the implemented interfaces (as described in a-tags.adb).
4830
4831 -- TSD : Type_Specific_Data (I_Depth) :=
4832 -- (Idepth => I_Depth,
4833 -- Access_Level => Type_Access_Level (Typ),
4834 -- Alignment => Typ'Alignment,
4835 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4836 -- External_Tag => Cstring_Ptr!(Exname'Address))
4837 -- HT_Link => HT_Link'Address,
4838 -- Transportable => <<boolean-value>>,
4839 -- Type_Is_Abstract => <<boolean-value>>,
4840 -- Needs_Finalization => <<boolean-value>>,
4841 -- [ Size_Func => Size_Prim'Access, ]
4842 -- [ Interfaces_Table => <<access-value>>, ]
4843 -- [ SSD => SSD_Table'Address ]
4844 -- Tags_Table => (0 => null,
4845 -- 1 => Parent'Tag
4846 -- ...);
4847 -- for TSD'Alignment use Address'Alignment
4848
4849 TSD_Aggr_List := New_List;
4850
4851 -- Idepth: Count ancestors to compute the inheritance depth. For private
4852 -- extensions, always go to the full view in order to compute the real
4853 -- inheritance depth.
4854
4855 declare
4856 Current_Typ : Entity_Id;
4857 Parent_Typ : Entity_Id;
4858
4859 begin
4860 I_Depth := 0;
4861 Current_Typ := Typ;
4862 loop
4863 Parent_Typ := Etype (Current_Typ);
4864
4865 if Is_Private_Type (Parent_Typ) then
4866 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4867 end if;
4868
4869 exit when Parent_Typ = Current_Typ;
4870
4871 I_Depth := I_Depth + 1;
4872 Current_Typ := Parent_Typ;
4873 end loop;
4874 end;
4875
4876 Append_To (TSD_Aggr_List,
4877 Make_Integer_Literal (Loc, I_Depth));
4878
4879 -- Access_Level
4880
4881 Append_To (TSD_Aggr_List,
4882 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4883
4884 -- Alignment
4885
4886 -- For CPP types we cannot rely on the value of 'Alignment provided
4887 -- by the backend to initialize this TSD field.
4888
4889 if Convention (Typ) = Convention_CPP
4890 or else Is_CPP_Class (Root_Type (Typ))
4891 then
4892 Append_To (TSD_Aggr_List,
4893 Make_Integer_Literal (Loc, 0));
4894 else
4895 Append_To (TSD_Aggr_List,
4896 Make_Attribute_Reference (Loc,
4897 Prefix => New_Occurrence_Of (Typ, Loc),
4898 Attribute_Name => Name_Alignment));
4899 end if;
4900
4901 -- Expanded_Name
4902
4903 Append_To (TSD_Aggr_List,
4904 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4905 Make_Attribute_Reference (Loc,
4906 Prefix => New_Occurrence_Of (Exname, Loc),
4907 Attribute_Name => Name_Address)));
4908
4909 -- External_Tag of a local tagged type
4910
4911 -- <typ>A : constant String :=
4912 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4913
4914 -- The reason we generate this strange name is that we do not want to
4915 -- enter local tagged types in the global hash table used to compute
4916 -- the Internal_Tag attribute for two reasons:
4917
4918 -- 1. It is hard to avoid a tasking race condition for entering the
4919 -- entry into the hash table.
4920
4921 -- 2. It would cause a storage leak, unless we rig up considerable
4922 -- mechanism to remove the entry from the hash table on exit.
4923
4924 -- So what we do is to generate the above external tag name, where the
4925 -- hex address is the address of the local dispatch table (i.e. exactly
4926 -- the value we want if Internal_Tag is computed from this string).
4927
4928 -- Of course this value will only be valid if the tagged type is still
4929 -- in scope, but it clearly must be erroneous to compute the internal
4930 -- tag of a tagged type that is out of scope.
4931
4932 -- We don't do this processing if an explicit external tag has been
4933 -- specified. That's an odd case for which we have already issued a
4934 -- warning, where we will not be able to compute the internal tag.
4935
4936 if not Is_Library_Level_Entity (Typ)
4937 and then not Has_External_Tag_Rep_Clause (Typ)
4938 then
4939 declare
4940 Exname : constant Entity_Id :=
4941 Make_Defining_Identifier (Loc,
4942 Chars => New_External_Name (Tname, 'A'));
4943 Full_Name : constant String_Id :=
4944 Fully_Qualified_Name_String (First_Subtype (Typ));
4945 Str1_Id : String_Id;
4946 Str2_Id : String_Id;
4947
4948 begin
4949 -- Generate:
4950 -- Str1 = "Internal tag at 16#";
4951
4952 Start_String;
4953 Store_String_Chars ("Internal tag at 16#");
4954 Str1_Id := End_String;
4955
4956 -- Generate:
4957 -- Str2 = "#: <type-full-name>";
4958
4959 Start_String;
4960 Store_String_Chars ("#: ");
4961 Store_String_Chars (Full_Name);
4962 Str2_Id := End_String;
4963
4964 -- Generate:
4965 -- Exname : constant String :=
4966 -- Str1 & Address_Image (Tag) & Str2;
4967
4968 if RTE_Available (RE_Address_Image) then
4969 Append_To (Result,
4970 Make_Object_Declaration (Loc,
4971 Defining_Identifier => Exname,
4972 Constant_Present => True,
4973 Object_Definition => New_Occurrence_Of
4974 (Standard_String, Loc),
4975 Expression =>
4976 Make_Op_Concat (Loc,
4977 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
4978 Right_Opnd =>
4979 Make_Op_Concat (Loc,
4980 Left_Opnd =>
4981 Make_Function_Call (Loc,
4982 Name =>
4983 New_Occurrence_Of
4984 (RTE (RE_Address_Image), Loc),
4985 Parameter_Associations => New_List (
4986 Unchecked_Convert_To (RTE (RE_Address),
4987 New_Occurrence_Of (DT_Ptr, Loc)))),
4988 Right_Opnd =>
4989 Make_String_Literal (Loc, Str2_Id)))));
4990
4991 else
4992 Append_To (Result,
4993 Make_Object_Declaration (Loc,
4994 Defining_Identifier => Exname,
4995 Constant_Present => True,
4996 Object_Definition =>
4997 New_Occurrence_Of (Standard_String, Loc),
4998 Expression =>
4999 Make_Op_Concat (Loc,
5000 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
5001 Right_Opnd => Make_String_Literal (Loc, Str2_Id))));
5002 end if;
5003
5004 New_Node :=
5005 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5006 Make_Attribute_Reference (Loc,
5007 Prefix => New_Occurrence_Of (Exname, Loc),
5008 Attribute_Name => Name_Address));
5009 end;
5010
5011 -- External tag of a library-level tagged type: Check for a definition
5012 -- of External_Tag. The clause is considered only if it applies to this
5013 -- specific tagged type, as opposed to one of its ancestors.
5014 -- If the type is an unconstrained type extension, we are building the
5015 -- dispatch table of its anonymous base type, so the external tag, if
5016 -- any was specified, must be retrieved from the first subtype. Go to
5017 -- the full view in case the clause is in the private part.
5018
5019 else
5020 declare
5021 Def : constant Node_Id := Get_Attribute_Definition_Clause
5022 (Underlying_Type (First_Subtype (Typ)),
5023 Attribute_External_Tag);
5024
5025 Old_Val : String_Id;
5026 New_Val : String_Id;
5027 E : Entity_Id;
5028
5029 begin
5030 if not Present (Def)
5031 or else Entity (Name (Def)) /= First_Subtype (Typ)
5032 then
5033 New_Node :=
5034 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5035 Make_Attribute_Reference (Loc,
5036 Prefix => New_Occurrence_Of (Exname, Loc),
5037 Attribute_Name => Name_Address));
5038 else
5039 Old_Val := Strval (Expr_Value_S (Expression (Def)));
5040
5041 -- For the rep clause "for <typ>'external_tag use y" generate:
5042
5043 -- <typ>A : constant string := y;
5044 --
5045 -- <typ>A'Address is used to set the External_Tag component
5046 -- of the TSD
5047
5048 -- Create a new nul terminated string if it is not already
5049
5050 if String_Length (Old_Val) > 0
5051 and then
5052 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5053 then
5054 New_Val := Old_Val;
5055 else
5056 Start_String (Old_Val);
5057 Store_String_Char (Get_Char_Code (ASCII.NUL));
5058 New_Val := End_String;
5059 end if;
5060
5061 E := Make_Defining_Identifier (Loc,
5062 New_External_Name (Chars (Typ), 'A'));
5063
5064 Append_To (Result,
5065 Make_Object_Declaration (Loc,
5066 Defining_Identifier => E,
5067 Constant_Present => True,
5068 Object_Definition =>
5069 New_Occurrence_Of (Standard_String, Loc),
5070 Expression =>
5071 Make_String_Literal (Loc, New_Val)));
5072
5073 New_Node :=
5074 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5075 Make_Attribute_Reference (Loc,
5076 Prefix => New_Occurrence_Of (E, Loc),
5077 Attribute_Name => Name_Address));
5078 end if;
5079 end;
5080 end if;
5081
5082 Append_To (TSD_Aggr_List, New_Node);
5083
5084 -- HT_Link
5085
5086 if RTE_Available (RE_Register_Tag) then
5087 Append_To (TSD_Aggr_List,
5088 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5089 Make_Attribute_Reference (Loc,
5090 Prefix => New_Occurrence_Of (HT_Link, Loc),
5091 Attribute_Name => Name_Address)));
5092 else
5093 Append_To (TSD_Aggr_List,
5094 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5095 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5096 end if;
5097
5098 -- Transportable: Set for types that can be used in remote calls
5099 -- with respect to E.4(18) legality rules.
5100
5101 declare
5102 Transportable : Entity_Id;
5103
5104 begin
5105 Transportable :=
5106 Boolean_Literals
5107 (Is_Pure (Typ)
5108 or else Is_Shared_Passive (Typ)
5109 or else
5110 ((Is_Remote_Types (Typ)
5111 or else Is_Remote_Call_Interface (Typ))
5112 and then Original_View_In_Visible_Part (Typ))
5113 or else not Comes_From_Source (Typ));
5114
5115 Append_To (TSD_Aggr_List,
5116 New_Occurrence_Of (Transportable, Loc));
5117 end;
5118
5119 -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5120 -- not available in the HIE runtime.
5121
5122 if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
5123 declare
5124 Type_Is_Abstract : Entity_Id;
5125 begin
5126 Type_Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
5127 Append_To (TSD_Aggr_List,
5128 New_Occurrence_Of (Type_Is_Abstract, Loc));
5129 end;
5130 end if;
5131
5132 -- Needs_Finalization: Set if the type is controlled or has controlled
5133 -- components.
5134
5135 declare
5136 Needs_Fin : Entity_Id;
5137 begin
5138 Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5139 Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5140 end;
5141
5142 -- Size_Func
5143
5144 if RTE_Record_Component_Available (RE_Size_Func) then
5145
5146 -- Initialize this field to Null_Address if we are not building
5147 -- static dispatch tables static or if the size function is not
5148 -- available. In the former case we cannot initialize this field
5149 -- until the function is frozen and registered in the dispatch
5150 -- table (see Register_Primitive).
5151
5152 if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5153 Append_To (TSD_Aggr_List,
5154 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5155 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5156
5157 else
5158 declare
5159 Prim_Elmt : Elmt_Id;
5160 Prim : Entity_Id;
5161 Size_Comp : Node_Id;
5162
5163 begin
5164 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5165 while Present (Prim_Elmt) loop
5166 Prim := Node (Prim_Elmt);
5167
5168 if Chars (Prim) = Name_uSize then
5169 Prim := Ultimate_Alias (Prim);
5170
5171 if Is_Abstract_Subprogram (Prim) then
5172 Size_Comp :=
5173 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5174 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
5175 else
5176 Size_Comp :=
5177 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5178 Make_Attribute_Reference (Loc,
5179 Prefix => New_Occurrence_Of (Prim, Loc),
5180 Attribute_Name => Name_Unrestricted_Access));
5181 end if;
5182
5183 exit;
5184 end if;
5185
5186 Next_Elmt (Prim_Elmt);
5187 end loop;
5188
5189 pragma Assert (Present (Size_Comp));
5190 Append_To (TSD_Aggr_List, Size_Comp);
5191 end;
5192 end if;
5193 end if;
5194
5195 -- Interfaces_Table (required for AI-405)
5196
5197 if RTE_Record_Component_Available (RE_Interfaces_Table) then
5198
5199 -- Count the number of interface types implemented by Typ
5200
5201 Collect_Interfaces (Typ, Typ_Ifaces);
5202
5203 AI := First_Elmt (Typ_Ifaces);
5204 while Present (AI) loop
5205 Num_Ifaces := Num_Ifaces + 1;
5206 Next_Elmt (AI);
5207 end loop;
5208
5209 if Num_Ifaces = 0 then
5210 Iface_Table_Node := Make_Null (Loc);
5211
5212 -- Generate the Interface_Table object
5213
5214 else
5215 declare
5216 TSD_Ifaces_List : constant List_Id := New_List;
5217 Elmt : Elmt_Id;
5218 Sec_DT_Tag : Node_Id;
5219
5220 begin
5221 AI := First_Elmt (Typ_Ifaces);
5222 while Present (AI) loop
5223 if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5224 Sec_DT_Tag :=
5225 New_Occurrence_Of (DT_Ptr, Loc);
5226 else
5227 Elmt :=
5228 Next_Elmt
5229 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5230 pragma Assert (Has_Thunks (Node (Elmt)));
5231
5232 while Is_Tag (Node (Elmt))
5233 and then not
5234 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5235 Use_Full_View => True)
5236 loop
5237 pragma Assert (Has_Thunks (Node (Elmt)));
5238 Next_Elmt (Elmt);
5239 pragma Assert (Has_Thunks (Node (Elmt)));
5240 Next_Elmt (Elmt);
5241 pragma Assert (not Has_Thunks (Node (Elmt)));
5242 Next_Elmt (Elmt);
5243 pragma Assert (not Has_Thunks (Node (Elmt)));
5244 Next_Elmt (Elmt);
5245 end loop;
5246
5247 pragma Assert (Ekind (Node (Elmt)) = E_Constant
5248 and then not
5249 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5250 Sec_DT_Tag :=
5251 New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Elmt))),
5252 Loc);
5253 end if;
5254
5255 Append_To (TSD_Ifaces_List,
5256 Make_Aggregate (Loc,
5257 Expressions => New_List (
5258
5259 -- Iface_Tag
5260
5261 Unchecked_Convert_To (RTE (RE_Tag),
5262 New_Occurrence_Of
5263 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5264 Loc)),
5265
5266 -- Static_Offset_To_Top
5267
5268 New_Occurrence_Of (Standard_True, Loc),
5269
5270 -- Offset_To_Top_Value
5271
5272 Make_Integer_Literal (Loc, 0),
5273
5274 -- Offset_To_Top_Func
5275
5276 Make_Null (Loc),
5277
5278 -- Secondary_DT
5279
5280 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5281
5282 )));
5283
5284 Next_Elmt (AI);
5285 end loop;
5286
5287 Name_ITable := New_External_Name (Tname, 'I');
5288 ITable := Make_Defining_Identifier (Loc, Name_ITable);
5289 Set_Is_Statically_Allocated (ITable,
5290 Is_Library_Level_Tagged_Type (Typ));
5291
5292 -- The table of interfaces is not constant; its slots are
5293 -- filled at run time by the IP routine using attribute
5294 -- 'Position to know the location of the tag components
5295 -- (and this attribute cannot be safely used before the
5296 -- object is initialized).
5297
5298 Append_To (Result,
5299 Make_Object_Declaration (Loc,
5300 Defining_Identifier => ITable,
5301 Aliased_Present => True,
5302 Constant_Present => False,
5303 Object_Definition =>
5304 Make_Subtype_Indication (Loc,
5305 Subtype_Mark =>
5306 New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
5307 Constraint =>
5308 Make_Index_Or_Discriminant_Constraint (Loc,
5309 Constraints => New_List (
5310 Make_Integer_Literal (Loc, Num_Ifaces)))),
5311
5312 Expression => Make_Aggregate (Loc,
5313 Expressions => New_List (
5314 Make_Integer_Literal (Loc, Num_Ifaces),
5315 Make_Aggregate (Loc, TSD_Ifaces_List)))));
5316
5317 Append_To (Result,
5318 Make_Attribute_Definition_Clause (Loc,
5319 Name => New_Occurrence_Of (ITable, Loc),
5320 Chars => Name_Alignment,
5321 Expression =>
5322 Make_Attribute_Reference (Loc,
5323 Prefix =>
5324 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5325 Attribute_Name => Name_Alignment)));
5326
5327 Iface_Table_Node :=
5328 Make_Attribute_Reference (Loc,
5329 Prefix => New_Occurrence_Of (ITable, Loc),
5330 Attribute_Name => Name_Unchecked_Access);
5331 end;
5332 end if;
5333
5334 Append_To (TSD_Aggr_List, Iface_Table_Node);
5335 end if;
5336
5337 -- Generate the Select Specific Data table for synchronized types that
5338 -- implement synchronized interfaces. The size of the table is
5339 -- constrained by the number of non-predefined primitive operations.
5340
5341 if RTE_Record_Component_Available (RE_SSD) then
5342 if Ada_Version >= Ada_2005
5343 and then Has_DT (Typ)
5344 and then Is_Concurrent_Record_Type (Typ)
5345 and then Has_Interfaces (Typ)
5346 and then Nb_Prim > 0
5347 and then not Is_Abstract_Type (Typ)
5348 and then not Is_Controlled (Typ)
5349 and then not Restriction_Active (No_Dispatching_Calls)
5350 and then not Restriction_Active (No_Select_Statements)
5351 then
5352 Append_To (Result,
5353 Make_Object_Declaration (Loc,
5354 Defining_Identifier => SSD,
5355 Aliased_Present => True,
5356 Object_Definition =>
5357 Make_Subtype_Indication (Loc,
5358 Subtype_Mark => New_Occurrence_Of (
5359 RTE (RE_Select_Specific_Data), Loc),
5360 Constraint =>
5361 Make_Index_Or_Discriminant_Constraint (Loc,
5362 Constraints => New_List (
5363 Make_Integer_Literal (Loc, Nb_Prim))))));
5364
5365 Append_To (Result,
5366 Make_Attribute_Definition_Clause (Loc,
5367 Name => New_Occurrence_Of (SSD, Loc),
5368 Chars => Name_Alignment,
5369 Expression =>
5370 Make_Attribute_Reference (Loc,
5371 Prefix =>
5372 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5373 Attribute_Name => Name_Alignment)));
5374
5375 -- This table is initialized by Make_Select_Specific_Data_Table,
5376 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5377
5378 Append_To (TSD_Aggr_List,
5379 Make_Attribute_Reference (Loc,
5380 Prefix => New_Occurrence_Of (SSD, Loc),
5381 Attribute_Name => Name_Unchecked_Access));
5382 else
5383 Append_To (TSD_Aggr_List, Make_Null (Loc));
5384 end if;
5385 end if;
5386
5387 -- Initialize the table of ancestor tags. In case of interface types
5388 -- this table is not needed.
5389
5390 TSD_Tags_List := New_List;
5391
5392 -- If we are not statically allocating the dispatch table then we must
5393 -- fill position 0 with null because we still have not generated the
5394 -- tag of Typ.
5395
5396 if not Building_Static_DT (Typ)
5397 or else Is_Interface (Typ)
5398 then
5399 Append_To (TSD_Tags_List,
5400 Unchecked_Convert_To (RTE (RE_Tag),
5401 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5402
5403 -- Otherwise we can safely reference the tag
5404
5405 else
5406 Append_To (TSD_Tags_List,
5407 New_Occurrence_Of (DT_Ptr, Loc));
5408 end if;
5409
5410 -- Fill the rest of the table with the tags of the ancestors
5411
5412 declare
5413 Current_Typ : Entity_Id;
5414 Parent_Typ : Entity_Id;
5415 Pos : Nat;
5416
5417 begin
5418 Pos := 1;
5419 Current_Typ := Typ;
5420
5421 loop
5422 Parent_Typ := Etype (Current_Typ);
5423
5424 if Is_Private_Type (Parent_Typ) then
5425 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5426 end if;
5427
5428 exit when Parent_Typ = Current_Typ;
5429
5430 if Is_CPP_Class (Parent_Typ) then
5431
5432 -- The tags defined in the C++ side will be inherited when
5433 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5434
5435 Append_To (TSD_Tags_List,
5436 Unchecked_Convert_To (RTE (RE_Tag),
5437 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5438 else
5439 Append_To (TSD_Tags_List,
5440 New_Occurrence_Of
5441 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5442 Loc));
5443 end if;
5444
5445 Pos := Pos + 1;
5446 Current_Typ := Parent_Typ;
5447 end loop;
5448
5449 pragma Assert (Pos = I_Depth + 1);
5450 end;
5451
5452 Append_To (TSD_Aggr_List,
5453 Make_Aggregate (Loc,
5454 Expressions => TSD_Tags_List));
5455
5456 -- Build the TSD object
5457
5458 Append_To (Result,
5459 Make_Object_Declaration (Loc,
5460 Defining_Identifier => TSD,
5461 Aliased_Present => True,
5462 Constant_Present => Building_Static_DT (Typ),
5463 Object_Definition =>
5464 Make_Subtype_Indication (Loc,
5465 Subtype_Mark => New_Occurrence_Of (
5466 RTE (RE_Type_Specific_Data), Loc),
5467 Constraint =>
5468 Make_Index_Or_Discriminant_Constraint (Loc,
5469 Constraints => New_List (
5470 Make_Integer_Literal (Loc, I_Depth)))),
5471
5472 Expression => Make_Aggregate (Loc,
5473 Expressions => TSD_Aggr_List)));
5474
5475 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5476
5477 Append_To (Result,
5478 Make_Attribute_Definition_Clause (Loc,
5479 Name => New_Occurrence_Of (TSD, Loc),
5480 Chars => Name_Alignment,
5481 Expression =>
5482 Make_Attribute_Reference (Loc,
5483 Prefix =>
5484 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5485 Attribute_Name => Name_Alignment)));
5486
5487 -- Initialize or declare the dispatch table object
5488
5489 if not Has_DT (Typ) then
5490 DT_Constr_List := New_List;
5491 DT_Aggr_List := New_List;
5492
5493 -- Typeinfo
5494
5495 New_Node :=
5496 Make_Attribute_Reference (Loc,
5497 Prefix => New_Occurrence_Of (TSD, Loc),
5498 Attribute_Name => Name_Address);
5499
5500 Append_To (DT_Constr_List, New_Node);
5501 Append_To (DT_Aggr_List, New_Copy (New_Node));
5502 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5503
5504 -- In case of locally defined tagged types we have already declared
5505 -- and uninitialized object for the dispatch table, which is now
5506 -- initialized by means of the following assignment:
5507
5508 -- DT := (TSD'Address, 0);
5509
5510 if not Building_Static_DT (Typ) then
5511 Append_To (Result,
5512 Make_Assignment_Statement (Loc,
5513 Name => New_Occurrence_Of (DT, Loc),
5514 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5515
5516 -- In case of library level tagged types we declare and export now
5517 -- the constant object containing the dummy dispatch table. There
5518 -- is no need to declare the tag here because it has been previously
5519 -- declared by Make_Tags
5520
5521 -- DT : aliased constant No_Dispatch_Table :=
5522 -- (NDT_TSD => TSD'Address;
5523 -- NDT_Prims_Ptr => 0);
5524 -- for DT'Alignment use Address'Alignment;
5525
5526 else
5527 Append_To (Result,
5528 Make_Object_Declaration (Loc,
5529 Defining_Identifier => DT,
5530 Aliased_Present => True,
5531 Constant_Present => True,
5532 Object_Definition =>
5533 New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5534 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5535
5536 Append_To (Result,
5537 Make_Attribute_Definition_Clause (Loc,
5538 Name => New_Occurrence_Of (DT, Loc),
5539 Chars => Name_Alignment,
5540 Expression =>
5541 Make_Attribute_Reference (Loc,
5542 Prefix =>
5543 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5544 Attribute_Name => Name_Alignment)));
5545
5546 Export_DT (Typ, DT);
5547 end if;
5548
5549 -- Common case: Typ has a dispatch table
5550
5551 -- Generate:
5552
5553 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5554 -- (predef-prim-op-1'address,
5555 -- predef-prim-op-2'address,
5556 -- ...
5557 -- predef-prim-op-n'address);
5558 -- for Predef_Prims'Alignment use Address'Alignment
5559
5560 -- DT : Dispatch_Table (Nb_Prims) :=
5561 -- (Signature => <sig-value>,
5562 -- Tag_Kind => <tag_kind-value>,
5563 -- Predef_Prims => Predef_Prims'First'Address,
5564 -- Offset_To_Top => 0,
5565 -- TSD => TSD'Address;
5566 -- Prims_Ptr => (prim-op-1'address,
5567 -- prim-op-2'address,
5568 -- ...
5569 -- prim-op-n'address));
5570 -- for DT'Alignment use Address'Alignment
5571
5572 else
5573 declare
5574 Pos : Nat;
5575
5576 begin
5577 if not Building_Static_DT (Typ) then
5578 Nb_Predef_Prims := Max_Predef_Prims;
5579
5580 else
5581 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5582 while Present (Prim_Elmt) loop
5583 Prim := Node (Prim_Elmt);
5584
5585 if Is_Predefined_Dispatching_Operation (Prim)
5586 and then not Is_Abstract_Subprogram (Prim)
5587 then
5588 Pos := UI_To_Int (DT_Position (Prim));
5589
5590 if Pos > Nb_Predef_Prims then
5591 Nb_Predef_Prims := Pos;
5592 end if;
5593 end if;
5594
5595 Next_Elmt (Prim_Elmt);
5596 end loop;
5597 end if;
5598
5599 declare
5600 Prim_Table : array
5601 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5602 Decl : Node_Id;
5603 E : Entity_Id;
5604
5605 begin
5606 Prim_Ops_Aggr_List := New_List;
5607
5608 Prim_Table := (others => Empty);
5609
5610 if Building_Static_DT (Typ) then
5611 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5612 while Present (Prim_Elmt) loop
5613 Prim := Node (Prim_Elmt);
5614
5615 if Is_Predefined_Dispatching_Operation (Prim)
5616 and then not Is_Abstract_Subprogram (Prim)
5617 and then not Is_Eliminated (Prim)
5618 and then not Present (Prim_Table
5619 (UI_To_Int (DT_Position (Prim))))
5620 then
5621 E := Ultimate_Alias (Prim);
5622 pragma Assert (not Is_Abstract_Subprogram (E));
5623 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5624 end if;
5625
5626 Next_Elmt (Prim_Elmt);
5627 end loop;
5628 end if;
5629
5630 for J in Prim_Table'Range loop
5631 if Present (Prim_Table (J)) then
5632 New_Node :=
5633 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5634 Make_Attribute_Reference (Loc,
5635 Prefix =>
5636 New_Occurrence_Of (Prim_Table (J), Loc),
5637 Attribute_Name => Name_Unrestricted_Access));
5638 else
5639 New_Node := Make_Null (Loc);
5640 end if;
5641
5642 Append_To (Prim_Ops_Aggr_List, New_Node);
5643 end loop;
5644
5645 New_Node :=
5646 Make_Aggregate (Loc,
5647 Expressions => Prim_Ops_Aggr_List);
5648
5649 Decl :=
5650 Make_Subtype_Declaration (Loc,
5651 Defining_Identifier => Make_Temporary (Loc, 'S'),
5652 Subtype_Indication =>
5653 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
5654
5655 Append_To (Result, Decl);
5656
5657 Append_To (Result,
5658 Make_Object_Declaration (Loc,
5659 Defining_Identifier => Predef_Prims,
5660 Aliased_Present => True,
5661 Constant_Present => Building_Static_DT (Typ),
5662 Object_Definition =>
5663 New_Occurrence_Of (Defining_Identifier (Decl), Loc),
5664 Expression => New_Node));
5665
5666 -- Remember aggregates initializing dispatch tables
5667
5668 Append_Elmt (New_Node, DT_Aggr);
5669
5670 Append_To (Result,
5671 Make_Attribute_Definition_Clause (Loc,
5672 Name => New_Occurrence_Of (Predef_Prims, Loc),
5673 Chars => Name_Alignment,
5674 Expression =>
5675 Make_Attribute_Reference (Loc,
5676 Prefix =>
5677 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5678 Attribute_Name => Name_Alignment)));
5679 end;
5680 end;
5681
5682 -- Stage 1: Initialize the discriminant and the record components
5683
5684 DT_Constr_List := New_List;
5685 DT_Aggr_List := New_List;
5686
5687 -- Num_Prims. If the tagged type has no primitives we add a dummy
5688 -- slot whose address will be the tag of this type.
5689
5690 if Nb_Prim = 0 then
5691 New_Node := Make_Integer_Literal (Loc, 1);
5692 else
5693 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5694 end if;
5695
5696 Append_To (DT_Constr_List, New_Node);
5697 Append_To (DT_Aggr_List, New_Copy (New_Node));
5698
5699 -- Signature
5700
5701 if RTE_Record_Component_Available (RE_Signature) then
5702 Append_To (DT_Aggr_List,
5703 New_Occurrence_Of (RTE (RE_Primary_DT), Loc));
5704 end if;
5705
5706 -- Tag_Kind
5707
5708 if RTE_Record_Component_Available (RE_Tag_Kind) then
5709 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5710 end if;
5711
5712 -- Predef_Prims
5713
5714 Append_To (DT_Aggr_List,
5715 Make_Attribute_Reference (Loc,
5716 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
5717 Attribute_Name => Name_Address));
5718
5719 -- Offset_To_Top
5720
5721 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5722
5723 -- Typeinfo
5724
5725 Append_To (DT_Aggr_List,
5726 Make_Attribute_Reference (Loc,
5727 Prefix => New_Occurrence_Of (TSD, Loc),
5728 Attribute_Name => Name_Address));
5729
5730 -- Stage 2: Initialize the table of user-defined primitive operations
5731
5732 Prim_Ops_Aggr_List := New_List;
5733
5734 if Nb_Prim = 0 then
5735 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5736
5737 elsif not Building_Static_DT (Typ) then
5738 for J in 1 .. Nb_Prim loop
5739 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5740 end loop;
5741
5742 else
5743 declare
5744 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5745 E : Entity_Id;
5746 Prim : Entity_Id;
5747 Prim_Elmt : Elmt_Id;
5748 Prim_Pos : Nat;
5749 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5750
5751 begin
5752 Prim_Table := (others => Empty);
5753
5754 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5755 while Present (Prim_Elmt) loop
5756 Prim := Node (Prim_Elmt);
5757
5758 -- Retrieve the ultimate alias of the primitive for proper
5759 -- handling of renamings and eliminated primitives.
5760
5761 E := Ultimate_Alias (Prim);
5762 Prim_Pos := UI_To_Int (DT_Position (E));
5763
5764 -- Skip predefined primitives because they are located in a
5765 -- separate dispatch table.
5766
5767 if not Is_Predefined_Dispatching_Operation (Prim)
5768 and then not Is_Predefined_Dispatching_Operation (E)
5769
5770 -- Skip entities with attribute Interface_Alias because
5771 -- those are only required to build secondary dispatch
5772 -- tables.
5773
5774 and then not Present (Interface_Alias (Prim))
5775
5776 -- Skip abstract and eliminated primitives
5777
5778 and then not Is_Abstract_Subprogram (E)
5779 and then not Is_Eliminated (E)
5780
5781 -- For derivations of CPP types skip primitives located in
5782 -- the C++ part of the dispatch table because their slots
5783 -- are initialized by the IC routine.
5784
5785 and then (not Is_CPP_Class (Root_Type (Typ))
5786 or else Prim_Pos > CPP_Nb_Prims)
5787
5788 -- Skip ignored Ghost subprograms as those will be removed
5789 -- from the executable.
5790
5791 and then not Is_Ignored_Ghost_Entity (E)
5792 then
5793 pragma Assert
5794 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5795
5796 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5797 end if;
5798
5799 Next_Elmt (Prim_Elmt);
5800 end loop;
5801
5802 for J in Prim_Table'Range loop
5803 if Present (Prim_Table (J)) then
5804 New_Node :=
5805 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5806 Make_Attribute_Reference (Loc,
5807 Prefix =>
5808 New_Occurrence_Of (Prim_Table (J), Loc),
5809 Attribute_Name => Name_Unrestricted_Access));
5810 else
5811 New_Node := Make_Null (Loc);
5812 end if;
5813
5814 Append_To (Prim_Ops_Aggr_List, New_Node);
5815 end loop;
5816 end;
5817 end if;
5818
5819 New_Node :=
5820 Make_Aggregate (Loc,
5821 Expressions => Prim_Ops_Aggr_List);
5822
5823 Append_To (DT_Aggr_List, New_Node);
5824
5825 -- Remember aggregates initializing dispatch tables
5826
5827 Append_Elmt (New_Node, DT_Aggr);
5828
5829 -- In case of locally defined tagged types we have already declared
5830 -- and uninitialized object for the dispatch table, which is now
5831 -- initialized by means of an assignment.
5832
5833 if not Building_Static_DT (Typ) then
5834 Append_To (Result,
5835 Make_Assignment_Statement (Loc,
5836 Name => New_Occurrence_Of (DT, Loc),
5837 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5838
5839 -- In case of library level tagged types we declare now and export
5840 -- the constant object containing the dispatch table.
5841
5842 else
5843 Append_To (Result,
5844 Make_Object_Declaration (Loc,
5845 Defining_Identifier => DT,
5846 Aliased_Present => True,
5847 Constant_Present => True,
5848 Object_Definition =>
5849 Make_Subtype_Indication (Loc,
5850 Subtype_Mark => New_Occurrence_Of
5851 (RTE (RE_Dispatch_Table_Wrapper), Loc),
5852 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5853 Constraints => DT_Constr_List)),
5854 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5855
5856 Append_To (Result,
5857 Make_Attribute_Definition_Clause (Loc,
5858 Name => New_Occurrence_Of (DT, Loc),
5859 Chars => Name_Alignment,
5860 Expression =>
5861 Make_Attribute_Reference (Loc,
5862 Prefix =>
5863 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5864 Attribute_Name => Name_Alignment)));
5865
5866 Export_DT (Typ, DT);
5867 end if;
5868 end if;
5869
5870 -- Initialize the table of ancestor tags if not building static
5871 -- dispatch table
5872
5873 if not Building_Static_DT (Typ)
5874 and then not Is_Interface (Typ)
5875 and then not Is_CPP_Class (Typ)
5876 then
5877 Append_To (Result,
5878 Make_Assignment_Statement (Loc,
5879 Name =>
5880 Make_Indexed_Component (Loc,
5881 Prefix =>
5882 Make_Selected_Component (Loc,
5883 Prefix => New_Occurrence_Of (TSD, Loc),
5884 Selector_Name =>
5885 New_Occurrence_Of
5886 (RTE_Record_Component (RE_Tags_Table), Loc)),
5887 Expressions =>
5888 New_List (Make_Integer_Literal (Loc, 0))),
5889
5890 Expression =>
5891 New_Occurrence_Of
5892 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5893 end if;
5894
5895 -- Inherit the dispatch tables of the parent. There is no need to
5896 -- inherit anything from the parent when building static dispatch tables
5897 -- because the whole dispatch table (including inherited primitives) has
5898 -- been already built.
5899
5900 if Building_Static_DT (Typ) then
5901 null;
5902
5903 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5904 -- in the init proc, and we don't need to fill them in here.
5905
5906 elsif Is_CPP_Class (Parent_Typ) then
5907 null;
5908
5909 -- Otherwise we fill in the dispatch tables here
5910
5911 else
5912 if Typ /= Parent_Typ
5913 and then not Is_Interface (Typ)
5914 and then not Restriction_Active (No_Dispatching_Calls)
5915 then
5916 -- Inherit the dispatch table
5917
5918 if not Is_Interface (Typ)
5919 and then not Is_Interface (Parent_Typ)
5920 and then not Is_CPP_Class (Parent_Typ)
5921 then
5922 declare
5923 Nb_Prims : constant Int :=
5924 UI_To_Int (DT_Entry_Count
5925 (First_Tag_Component (Parent_Typ)));
5926
5927 begin
5928 Append_To (Elab_Code,
5929 Build_Inherit_Predefined_Prims (Loc,
5930 Old_Tag_Node =>
5931 New_Occurrence_Of
5932 (Node
5933 (Next_Elmt
5934 (First_Elmt
5935 (Access_Disp_Table (Parent_Typ)))), Loc),
5936 New_Tag_Node =>
5937 New_Occurrence_Of
5938 (Node
5939 (Next_Elmt
5940 (First_Elmt
5941 (Access_Disp_Table (Typ)))), Loc)));
5942
5943 if Nb_Prims /= 0 then
5944 Append_To (Elab_Code,
5945 Build_Inherit_Prims (Loc,
5946 Typ => Typ,
5947 Old_Tag_Node =>
5948 New_Occurrence_Of
5949 (Node
5950 (First_Elmt
5951 (Access_Disp_Table (Parent_Typ))), Loc),
5952 New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
5953 Num_Prims => Nb_Prims));
5954 end if;
5955 end;
5956 end if;
5957
5958 -- Inherit the secondary dispatch tables of the ancestor
5959
5960 if not Is_CPP_Class (Parent_Typ) then
5961 declare
5962 Sec_DT_Ancestor : Elmt_Id :=
5963 Next_Elmt
5964 (Next_Elmt
5965 (First_Elmt
5966 (Access_Disp_Table
5967 (Parent_Typ))));
5968 Sec_DT_Typ : Elmt_Id :=
5969 Next_Elmt
5970 (Next_Elmt
5971 (First_Elmt
5972 (Access_Disp_Table (Typ))));
5973
5974 procedure Copy_Secondary_DTs (Typ : Entity_Id);
5975 -- Local procedure required to climb through the ancestors
5976 -- and copy the contents of all their secondary dispatch
5977 -- tables.
5978
5979 ------------------------
5980 -- Copy_Secondary_DTs --
5981 ------------------------
5982
5983 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5984 E : Entity_Id;
5985 Iface : Elmt_Id;
5986
5987 begin
5988 -- Climb to the ancestor (if any) handling private types
5989
5990 if Present (Full_View (Etype (Typ))) then
5991 if Full_View (Etype (Typ)) /= Typ then
5992 Copy_Secondary_DTs (Full_View (Etype (Typ)));
5993 end if;
5994
5995 elsif Etype (Typ) /= Typ then
5996 Copy_Secondary_DTs (Etype (Typ));
5997 end if;
5998
5999 if Present (Interfaces (Typ))
6000 and then not Is_Empty_Elmt_List (Interfaces (Typ))
6001 then
6002 Iface := First_Elmt (Interfaces (Typ));
6003 E := First_Entity (Typ);
6004 while Present (E)
6005 and then Present (Node (Sec_DT_Ancestor))
6006 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6007 loop
6008 if Is_Tag (E) and then Chars (E) /= Name_uTag then
6009 declare
6010 Num_Prims : constant Int :=
6011 UI_To_Int (DT_Entry_Count (E));
6012
6013 begin
6014 if not Is_Interface (Etype (Typ)) then
6015
6016 -- Inherit first secondary dispatch table
6017
6018 Append_To (Elab_Code,
6019 Build_Inherit_Predefined_Prims (Loc,
6020 Old_Tag_Node =>
6021 Unchecked_Convert_To (RTE (RE_Tag),
6022 New_Occurrence_Of
6023 (Node
6024 (Next_Elmt (Sec_DT_Ancestor)),
6025 Loc)),
6026 New_Tag_Node =>
6027 Unchecked_Convert_To (RTE (RE_Tag),
6028 New_Occurrence_Of
6029 (Node (Next_Elmt (Sec_DT_Typ)),
6030 Loc))));
6031
6032 if Num_Prims /= 0 then
6033 Append_To (Elab_Code,
6034 Build_Inherit_Prims (Loc,
6035 Typ => Node (Iface),
6036 Old_Tag_Node =>
6037 Unchecked_Convert_To
6038 (RTE (RE_Tag),
6039 New_Occurrence_Of
6040 (Node (Sec_DT_Ancestor),
6041 Loc)),
6042 New_Tag_Node =>
6043 Unchecked_Convert_To
6044 (RTE (RE_Tag),
6045 New_Occurrence_Of
6046 (Node (Sec_DT_Typ), Loc)),
6047 Num_Prims => Num_Prims));
6048 end if;
6049 end if;
6050
6051 Next_Elmt (Sec_DT_Ancestor);
6052 Next_Elmt (Sec_DT_Typ);
6053
6054 -- Skip the secondary dispatch table of
6055 -- predefined primitives
6056
6057 Next_Elmt (Sec_DT_Ancestor);
6058 Next_Elmt (Sec_DT_Typ);
6059
6060 if not Is_Interface (Etype (Typ)) then
6061
6062 -- Inherit second secondary dispatch table
6063
6064 Append_To (Elab_Code,
6065 Build_Inherit_Predefined_Prims (Loc,
6066 Old_Tag_Node =>
6067 Unchecked_Convert_To (RTE (RE_Tag),
6068 New_Occurrence_Of
6069 (Node
6070 (Next_Elmt (Sec_DT_Ancestor)),
6071 Loc)),
6072 New_Tag_Node =>
6073 Unchecked_Convert_To (RTE (RE_Tag),
6074 New_Occurrence_Of
6075 (Node (Next_Elmt (Sec_DT_Typ)),
6076 Loc))));
6077
6078 if Num_Prims /= 0 then
6079 Append_To (Elab_Code,
6080 Build_Inherit_Prims (Loc,
6081 Typ => Node (Iface),
6082 Old_Tag_Node =>
6083 Unchecked_Convert_To
6084 (RTE (RE_Tag),
6085 New_Occurrence_Of
6086 (Node (Sec_DT_Ancestor),
6087 Loc)),
6088 New_Tag_Node =>
6089 Unchecked_Convert_To
6090 (RTE (RE_Tag),
6091 New_Occurrence_Of
6092 (Node (Sec_DT_Typ), Loc)),
6093 Num_Prims => Num_Prims));
6094 end if;
6095 end if;
6096 end;
6097
6098 Next_Elmt (Sec_DT_Ancestor);
6099 Next_Elmt (Sec_DT_Typ);
6100
6101 -- Skip the secondary dispatch table of
6102 -- predefined primitives
6103
6104 Next_Elmt (Sec_DT_Ancestor);
6105 Next_Elmt (Sec_DT_Typ);
6106
6107 Next_Elmt (Iface);
6108 end if;
6109
6110 Next_Entity (E);
6111 end loop;
6112 end if;
6113 end Copy_Secondary_DTs;
6114
6115 begin
6116 if Present (Node (Sec_DT_Ancestor))
6117 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6118 then
6119 -- Handle private types
6120
6121 if Present (Full_View (Typ)) then
6122 Copy_Secondary_DTs (Full_View (Typ));
6123 else
6124 Copy_Secondary_DTs (Typ);
6125 end if;
6126 end if;
6127 end;
6128 end if;
6129 end if;
6130 end if;
6131
6132 -- Generate code to check if the external tag of this type is the same
6133 -- as the external tag of some other declaration.
6134
6135 -- Check_TSD (TSD'Unrestricted_Access);
6136
6137 -- This check is a consequence of AI05-0113-1/06, so it officially
6138 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6139 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6140 -- this change, as it would be incompatible, and could conceivably
6141 -- cause a problem in existing Aa 95 code.
6142
6143 -- We check for No_Run_Time_Mode here, because we do not want to pick
6144 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6145
6146 if not No_Run_Time_Mode
6147 and then Ada_Version >= Ada_2005
6148 and then RTE_Available (RE_Check_TSD)
6149 and then not Duplicated_Tag_Checks_Suppressed (Typ)
6150 then
6151 Append_To (Elab_Code,
6152 Make_Procedure_Call_Statement (Loc,
6153 Name =>
6154 New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6155 Parameter_Associations => New_List (
6156 Make_Attribute_Reference (Loc,
6157 Prefix => New_Occurrence_Of (TSD, Loc),
6158 Attribute_Name => Name_Unchecked_Access))));
6159 end if;
6160
6161 -- Generate code to register the Tag in the External_Tag hash table for
6162 -- the pure Ada type only.
6163
6164 -- Register_Tag (Dt_Ptr);
6165
6166 -- Skip this action in the following cases:
6167 -- 1) if Register_Tag is not available.
6168 -- 2) in No_Run_Time mode.
6169 -- 3) if Typ is not defined at the library level (this is required
6170 -- to avoid adding concurrency control to the hash table used
6171 -- by the run-time to register the tags).
6172
6173 if not No_Run_Time_Mode
6174 and then Is_Library_Level_Entity (Typ)
6175 and then RTE_Available (RE_Register_Tag)
6176 then
6177 Append_To (Elab_Code,
6178 Make_Procedure_Call_Statement (Loc,
6179 Name =>
6180 New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
6181 Parameter_Associations =>
6182 New_List (New_Occurrence_Of (DT_Ptr, Loc))));
6183 end if;
6184
6185 if not Is_Empty_List (Elab_Code) then
6186 Append_List_To (Result, Elab_Code);
6187 end if;
6188
6189 -- Populate the two auxiliary tables used for dispatching asynchronous,
6190 -- conditional and timed selects for synchronized types that implement
6191 -- a limited interface. Skip this step in Ravenscar profile or when
6192 -- general dispatching is forbidden.
6193
6194 if Ada_Version >= Ada_2005
6195 and then Is_Concurrent_Record_Type (Typ)
6196 and then Has_Interfaces (Typ)
6197 and then not Restriction_Active (No_Dispatching_Calls)
6198 and then not Restriction_Active (No_Select_Statements)
6199 then
6200 Append_List_To (Result,
6201 Make_Select_Specific_Data_Table (Typ));
6202 end if;
6203
6204 -- Remember entities containing dispatch tables
6205
6206 Append_Elmt (Predef_Prims, DT_Decl);
6207 Append_Elmt (DT, DT_Decl);
6208
6209 Analyze_List (Result, Suppress => All_Checks);
6210 Set_Has_Dispatch_Table (Typ);
6211
6212 -- Mark entities containing dispatch tables. Required by the backend to
6213 -- handle them properly.
6214
6215 if Has_DT (Typ) then
6216 declare
6217 Elmt : Elmt_Id;
6218
6219 begin
6220 -- Object declarations
6221
6222 Elmt := First_Elmt (DT_Decl);
6223 while Present (Elmt) loop
6224 Set_Is_Dispatch_Table_Entity (Node (Elmt));
6225 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6226 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6227 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6228 Next_Elmt (Elmt);
6229 end loop;
6230
6231 -- Aggregates initializing dispatch tables
6232
6233 Elmt := First_Elmt (DT_Aggr);
6234 while Present (Elmt) loop
6235 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6236 Next_Elmt (Elmt);
6237 end loop;
6238 end;
6239 end if;
6240
6241 <<Early_Exit_For_SCIL>>
6242
6243 -- Register the tagged type in the call graph nodes table
6244
6245 Register_CG_Node (Typ);
6246
6247 Ghost_Mode := Save_Ghost_Mode;
6248 return Result;
6249 end Make_DT;
6250
6251 -------------------------------------
6252 -- Make_Select_Specific_Data_Table --
6253 -------------------------------------
6254
6255 function Make_Select_Specific_Data_Table
6256 (Typ : Entity_Id) return List_Id
6257 is
6258 Assignments : constant List_Id := New_List;
6259 Loc : constant Source_Ptr := Sloc (Typ);
6260
6261 Conc_Typ : Entity_Id;
6262 Decls : List_Id;
6263 Prim : Entity_Id;
6264 Prim_Als : Entity_Id;
6265 Prim_Elmt : Elmt_Id;
6266 Prim_Pos : Uint;
6267 Nb_Prim : Nat := 0;
6268
6269 type Examined_Array is array (Int range <>) of Boolean;
6270
6271 function Find_Entry_Index (E : Entity_Id) return Uint;
6272 -- Given an entry, find its index in the visible declarations of the
6273 -- corresponding concurrent type of Typ.
6274
6275 ----------------------
6276 -- Find_Entry_Index --
6277 ----------------------
6278
6279 function Find_Entry_Index (E : Entity_Id) return Uint is
6280 Index : Uint := Uint_1;
6281 Subp_Decl : Entity_Id;
6282
6283 begin
6284 if Present (Decls)
6285 and then not Is_Empty_List (Decls)
6286 then
6287 Subp_Decl := First (Decls);
6288 while Present (Subp_Decl) loop
6289 if Nkind (Subp_Decl) = N_Entry_Declaration then
6290 if Defining_Identifier (Subp_Decl) = E then
6291 return Index;
6292 end if;
6293
6294 Index := Index + 1;
6295 end if;
6296
6297 Next (Subp_Decl);
6298 end loop;
6299 end if;
6300
6301 return Uint_0;
6302 end Find_Entry_Index;
6303
6304 -- Local variables
6305
6306 Tag_Node : Node_Id;
6307
6308 -- Start of processing for Make_Select_Specific_Data_Table
6309
6310 begin
6311 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6312
6313 if Present (Corresponding_Concurrent_Type (Typ)) then
6314 Conc_Typ := Corresponding_Concurrent_Type (Typ);
6315
6316 if Present (Full_View (Conc_Typ)) then
6317 Conc_Typ := Full_View (Conc_Typ);
6318 end if;
6319
6320 if Ekind (Conc_Typ) = E_Protected_Type then
6321 Decls := Visible_Declarations (Protected_Definition (
6322 Parent (Conc_Typ)));
6323 else
6324 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6325 Decls := Visible_Declarations (Task_Definition (
6326 Parent (Conc_Typ)));
6327 end if;
6328 end if;
6329
6330 -- Count the non-predefined primitive operations
6331
6332 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6333 while Present (Prim_Elmt) loop
6334 Prim := Node (Prim_Elmt);
6335
6336 if not (Is_Predefined_Dispatching_Operation (Prim)
6337 or else Is_Predefined_Dispatching_Alias (Prim))
6338 then
6339 Nb_Prim := Nb_Prim + 1;
6340 end if;
6341
6342 Next_Elmt (Prim_Elmt);
6343 end loop;
6344
6345 declare
6346 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6347
6348 begin
6349 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6350 while Present (Prim_Elmt) loop
6351 Prim := Node (Prim_Elmt);
6352
6353 -- Look for primitive overriding an abstract interface subprogram
6354
6355 if Present (Interface_Alias (Prim))
6356 and then not
6357 Is_Ancestor
6358 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6359 Use_Full_View => True)
6360 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6361 then
6362 Prim_Pos := DT_Position (Alias (Prim));
6363 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6364 Examined (UI_To_Int (Prim_Pos)) := True;
6365
6366 -- Set the primitive operation kind regardless of subprogram
6367 -- type. Generate:
6368 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6369
6370 if Tagged_Type_Expansion then
6371 Tag_Node :=
6372 New_Occurrence_Of
6373 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6374
6375 else
6376 Tag_Node :=
6377 Make_Attribute_Reference (Loc,
6378 Prefix => New_Occurrence_Of (Typ, Loc),
6379 Attribute_Name => Name_Tag);
6380 end if;
6381
6382 Append_To (Assignments,
6383 Make_Procedure_Call_Statement (Loc,
6384 Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc),
6385 Parameter_Associations => New_List (
6386 Tag_Node,
6387 Make_Integer_Literal (Loc, Prim_Pos),
6388 Prim_Op_Kind (Alias (Prim), Typ))));
6389
6390 -- Retrieve the root of the alias chain
6391
6392 Prim_Als := Ultimate_Alias (Prim);
6393
6394 -- In the case of an entry wrapper, set the entry index
6395
6396 if Ekind (Prim) = E_Procedure
6397 and then Is_Primitive_Wrapper (Prim_Als)
6398 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6399 then
6400 -- Generate:
6401 -- Ada.Tags.Set_Entry_Index
6402 -- (DT_Ptr, <position>, <index>);
6403
6404 if Tagged_Type_Expansion then
6405 Tag_Node :=
6406 New_Occurrence_Of
6407 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6408 else
6409 Tag_Node :=
6410 Make_Attribute_Reference (Loc,
6411 Prefix => New_Occurrence_Of (Typ, Loc),
6412 Attribute_Name => Name_Tag);
6413 end if;
6414
6415 Append_To (Assignments,
6416 Make_Procedure_Call_Statement (Loc,
6417 Name =>
6418 New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc),
6419 Parameter_Associations => New_List (
6420 Tag_Node,
6421 Make_Integer_Literal (Loc, Prim_Pos),
6422 Make_Integer_Literal (Loc,
6423 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6424 end if;
6425 end if;
6426
6427 Next_Elmt (Prim_Elmt);
6428 end loop;
6429 end;
6430
6431 return Assignments;
6432 end Make_Select_Specific_Data_Table;
6433
6434 ---------------
6435 -- Make_Tags --
6436 ---------------
6437
6438 function Make_Tags (Typ : Entity_Id) return List_Id is
6439 Loc : constant Source_Ptr := Sloc (Typ);
6440 Result : constant List_Id := New_List;
6441
6442 procedure Import_DT
6443 (Tag_Typ : Entity_Id;
6444 DT : Entity_Id;
6445 Is_Secondary_DT : Boolean);
6446 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6447 -- generate forward references and statically allocate the table. For
6448 -- primary dispatch tables that require no dispatch table generate:
6449
6450 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6451 -- pragma Import (Ada, DT);
6452
6453 -- Otherwise generate:
6454
6455 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6456 -- pragma Import (Ada, DT);
6457
6458 ---------------
6459 -- Import_DT --
6460 ---------------
6461
6462 procedure Import_DT
6463 (Tag_Typ : Entity_Id;
6464 DT : Entity_Id;
6465 Is_Secondary_DT : Boolean)
6466 is
6467 DT_Constr_List : List_Id;
6468 Nb_Prim : Nat;
6469
6470 begin
6471 Set_Is_Imported (DT);
6472 Set_Ekind (DT, E_Constant);
6473 Set_Related_Type (DT, Typ);
6474
6475 -- The scope must be set now to call Get_External_Name
6476
6477 Set_Scope (DT, Current_Scope);
6478
6479 Get_External_Name (DT);
6480 Set_Interface_Name (DT,
6481 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
6482
6483 -- Ensure proper Sprint output of this implicit importation
6484
6485 Set_Is_Internal (DT);
6486
6487 -- Save this entity to allow Make_DT to generate its exportation
6488
6489 Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6490
6491 -- No dispatch table required
6492
6493 if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
6494 Append_To (Result,
6495 Make_Object_Declaration (Loc,
6496 Defining_Identifier => DT,
6497 Aliased_Present => True,
6498 Constant_Present => True,
6499 Object_Definition =>
6500 New_Occurrence_Of
6501 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6502
6503 else
6504 -- Calculate the number of primitives of the dispatch table and
6505 -- the size of the Type_Specific_Data record.
6506
6507 Nb_Prim :=
6508 UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6509
6510 -- If the tagged type has no primitives we add a dummy slot whose
6511 -- address will be the tag of this type.
6512
6513 if Nb_Prim = 0 then
6514 DT_Constr_List :=
6515 New_List (Make_Integer_Literal (Loc, 1));
6516 else
6517 DT_Constr_List :=
6518 New_List (Make_Integer_Literal (Loc, Nb_Prim));
6519 end if;
6520
6521 Append_To (Result,
6522 Make_Object_Declaration (Loc,
6523 Defining_Identifier => DT,
6524 Aliased_Present => True,
6525 Constant_Present => True,
6526 Object_Definition =>
6527 Make_Subtype_Indication (Loc,
6528 Subtype_Mark =>
6529 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
6530 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6531 Constraints => DT_Constr_List))));
6532 end if;
6533 end Import_DT;
6534
6535 -- Local variables
6536
6537 Tname : constant Name_Id := Chars (Typ);
6538 AI_Tag_Comp : Elmt_Id;
6539 DT : Node_Id := Empty;
6540 DT_Ptr : Node_Id;
6541 Predef_Prims_Ptr : Node_Id;
6542 Iface_DT : Node_Id := Empty;
6543 Iface_DT_Ptr : Node_Id;
6544 New_Node : Node_Id;
6545 Suffix_Index : Int;
6546 Typ_Name : Name_Id;
6547 Typ_Comps : Elist_Id;
6548
6549 -- Start of processing for Make_Tags
6550
6551 begin
6552 pragma Assert (No (Access_Disp_Table (Typ)));
6553 Set_Access_Disp_Table (Typ, New_Elmt_List);
6554
6555 -- 1) Generate the primary tag entities
6556
6557 -- Primary dispatch table containing user-defined primitives
6558
6559 DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
6560 Set_Etype (DT_Ptr, RTE (RE_Tag));
6561 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
6562
6563 -- Minimum decoration
6564
6565 Set_Ekind (DT_Ptr, E_Variable);
6566 Set_Related_Type (DT_Ptr, Typ);
6567
6568 -- Notify back end that the types are associated with a dispatch table
6569
6570 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6571 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6572
6573 -- For CPP types there is no need to build the dispatch tables since
6574 -- they are imported from the C++ side. If the CPP type has an IP then
6575 -- we declare now the variable that will store the copy of the C++ tag.
6576 -- If the CPP type is an interface, we need the variable as well because
6577 -- it becomes the pointer to the corresponding secondary table.
6578
6579 if Is_CPP_Class (Typ) then
6580 if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
6581 Append_To (Result,
6582 Make_Object_Declaration (Loc,
6583 Defining_Identifier => DT_Ptr,
6584 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
6585 Expression =>
6586 Unchecked_Convert_To (RTE (RE_Tag),
6587 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6588
6589 Set_Is_Statically_Allocated (DT_Ptr,
6590 Is_Library_Level_Tagged_Type (Typ));
6591 end if;
6592
6593 -- Ada types
6594
6595 else
6596 -- Primary dispatch table containing predefined primitives
6597
6598 Predef_Prims_Ptr :=
6599 Make_Defining_Identifier (Loc,
6600 Chars => New_External_Name (Tname, 'Y'));
6601 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
6602 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
6603
6604 -- Import the forward declaration of the Dispatch Table wrapper
6605 -- record (Make_DT will take care of exporting it).
6606
6607 if Building_Static_DT (Typ) then
6608 Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
6609
6610 DT :=
6611 Make_Defining_Identifier (Loc,
6612 Chars => New_External_Name (Tname, 'T'));
6613
6614 Import_DT (Typ, DT, Is_Secondary_DT => False);
6615
6616 if Has_DT (Typ) then
6617 Append_To (Result,
6618 Make_Object_Declaration (Loc,
6619 Defining_Identifier => DT_Ptr,
6620 Constant_Present => True,
6621 Object_Definition =>
6622 New_Occurrence_Of (RTE (RE_Tag), Loc),
6623 Expression =>
6624 Unchecked_Convert_To (RTE (RE_Tag),
6625 Make_Attribute_Reference (Loc,
6626 Prefix =>
6627 Make_Selected_Component (Loc,
6628 Prefix => New_Occurrence_Of (DT, Loc),
6629 Selector_Name =>
6630 New_Occurrence_Of
6631 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6632 Attribute_Name => Name_Address))));
6633
6634 -- Generate the SCIL node for the previous object declaration
6635 -- because it has a tag initialization.
6636
6637 if Generate_SCIL then
6638 New_Node :=
6639 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
6640 Set_SCIL_Entity (New_Node, Typ);
6641 Set_SCIL_Node (Last (Result), New_Node);
6642 end if;
6643
6644 Append_To (Result,
6645 Make_Object_Declaration (Loc,
6646 Defining_Identifier => Predef_Prims_Ptr,
6647 Constant_Present => True,
6648 Object_Definition =>
6649 New_Occurrence_Of (RTE (RE_Address), Loc),
6650 Expression =>
6651 Make_Attribute_Reference (Loc,
6652 Prefix =>
6653 Make_Selected_Component (Loc,
6654 Prefix => New_Occurrence_Of (DT, Loc),
6655 Selector_Name =>
6656 New_Occurrence_Of
6657 (RTE_Record_Component (RE_Predef_Prims), Loc)),
6658 Attribute_Name => Name_Address)));
6659
6660 -- No dispatch table required
6661
6662 else
6663 Append_To (Result,
6664 Make_Object_Declaration (Loc,
6665 Defining_Identifier => DT_Ptr,
6666 Constant_Present => True,
6667 Object_Definition =>
6668 New_Occurrence_Of (RTE (RE_Tag), Loc),
6669 Expression =>
6670 Unchecked_Convert_To (RTE (RE_Tag),
6671 Make_Attribute_Reference (Loc,
6672 Prefix =>
6673 Make_Selected_Component (Loc,
6674 Prefix => New_Occurrence_Of (DT, Loc),
6675 Selector_Name =>
6676 New_Occurrence_Of
6677 (RTE_Record_Component (RE_NDT_Prims_Ptr),
6678 Loc)),
6679 Attribute_Name => Name_Address))));
6680 end if;
6681
6682 Set_Is_True_Constant (DT_Ptr);
6683 Set_Is_Statically_Allocated (DT_Ptr);
6684 end if;
6685 end if;
6686
6687 -- 2) Generate the secondary tag entities
6688
6689 -- Collect the components associated with secondary dispatch tables
6690
6691 if Has_Interfaces (Typ) then
6692 Collect_Interface_Components (Typ, Typ_Comps);
6693
6694 -- For each interface type we build a unique external name associated
6695 -- with its secondary dispatch table. This name is used to declare an
6696 -- object that references this secondary dispatch table, whose value
6697 -- will be used for the elaboration of Typ objects, and also for the
6698 -- elaboration of objects of types derived from Typ that do not
6699 -- override the primitives of this interface type.
6700
6701 Suffix_Index := 1;
6702
6703 -- Note: The value of Suffix_Index must be in sync with the values of
6704 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
6705
6706 if Is_CPP_Class (Typ) then
6707 AI_Tag_Comp := First_Elmt (Typ_Comps);
6708 while Present (AI_Tag_Comp) loop
6709 Get_Secondary_DT_External_Name
6710 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6711 Typ_Name := Name_Find;
6712
6713 -- Declare variables to store copy of the C++ secondary tags
6714
6715 Iface_DT_Ptr :=
6716 Make_Defining_Identifier (Loc,
6717 Chars => New_External_Name (Typ_Name, 'P'));
6718 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6719 Set_Ekind (Iface_DT_Ptr, E_Variable);
6720 Set_Is_Tag (Iface_DT_Ptr);
6721
6722 Set_Has_Thunks (Iface_DT_Ptr);
6723 Set_Related_Type
6724 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6725 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6726
6727 Append_To (Result,
6728 Make_Object_Declaration (Loc,
6729 Defining_Identifier => Iface_DT_Ptr,
6730 Object_Definition => New_Occurrence_Of
6731 (RTE (RE_Interface_Tag), Loc),
6732 Expression =>
6733 Unchecked_Convert_To (RTE (RE_Interface_Tag),
6734 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6735
6736 Set_Is_Statically_Allocated (Iface_DT_Ptr,
6737 Is_Library_Level_Tagged_Type (Typ));
6738
6739 Next_Elmt (AI_Tag_Comp);
6740 end loop;
6741
6742 -- This is not a CPP_Class type
6743
6744 else
6745 AI_Tag_Comp := First_Elmt (Typ_Comps);
6746 while Present (AI_Tag_Comp) loop
6747 Get_Secondary_DT_External_Name
6748 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6749 Typ_Name := Name_Find;
6750
6751 if Building_Static_DT (Typ) then
6752 Iface_DT :=
6753 Make_Defining_Identifier (Loc,
6754 Chars => New_External_Name (Typ_Name, 'T'));
6755 Import_DT
6756 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
6757 DT => Iface_DT,
6758 Is_Secondary_DT => True);
6759 end if;
6760
6761 -- Secondary dispatch table referencing thunks to user-defined
6762 -- primitives covered by this interface.
6763
6764 Iface_DT_Ptr :=
6765 Make_Defining_Identifier (Loc,
6766 Chars => New_External_Name (Typ_Name, 'P'));
6767 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6768 Set_Ekind (Iface_DT_Ptr, E_Constant);
6769 Set_Is_Tag (Iface_DT_Ptr);
6770 Set_Has_Thunks (Iface_DT_Ptr);
6771 Set_Is_Statically_Allocated (Iface_DT_Ptr,
6772 Is_Library_Level_Tagged_Type (Typ));
6773 Set_Is_True_Constant (Iface_DT_Ptr);
6774 Set_Related_Type
6775 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6776 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6777
6778 if Building_Static_DT (Typ) then
6779 Append_To (Result,
6780 Make_Object_Declaration (Loc,
6781 Defining_Identifier => Iface_DT_Ptr,
6782 Constant_Present => True,
6783 Object_Definition => New_Occurrence_Of
6784 (RTE (RE_Interface_Tag), Loc),
6785 Expression =>
6786 Unchecked_Convert_To (RTE (RE_Interface_Tag),
6787 Make_Attribute_Reference (Loc,
6788 Prefix =>
6789 Make_Selected_Component (Loc,
6790 Prefix =>
6791 New_Occurrence_Of (Iface_DT, Loc),
6792 Selector_Name =>
6793 New_Occurrence_Of
6794 (RTE_Record_Component (RE_Prims_Ptr),
6795 Loc)),
6796 Attribute_Name => Name_Address))));
6797 end if;
6798
6799 -- Secondary dispatch table referencing thunks to predefined
6800 -- primitives.
6801
6802 Iface_DT_Ptr :=
6803 Make_Defining_Identifier (Loc,
6804 Chars => New_External_Name (Typ_Name, 'Y'));
6805 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6806 Set_Ekind (Iface_DT_Ptr, E_Constant);
6807 Set_Is_Tag (Iface_DT_Ptr);
6808 Set_Has_Thunks (Iface_DT_Ptr);
6809 Set_Is_Statically_Allocated (Iface_DT_Ptr,
6810 Is_Library_Level_Tagged_Type (Typ));
6811 Set_Is_True_Constant (Iface_DT_Ptr);
6812 Set_Related_Type
6813 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6814 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6815
6816 -- Secondary dispatch table referencing user-defined primitives
6817 -- covered by this interface.
6818
6819 Iface_DT_Ptr :=
6820 Make_Defining_Identifier (Loc,
6821 Chars => New_External_Name (Typ_Name, 'D'));
6822 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6823 Set_Ekind (Iface_DT_Ptr, E_Constant);
6824 Set_Is_Tag (Iface_DT_Ptr);
6825 Set_Is_Statically_Allocated (Iface_DT_Ptr,
6826 Is_Library_Level_Tagged_Type (Typ));
6827 Set_Is_True_Constant (Iface_DT_Ptr);
6828 Set_Related_Type
6829 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6830 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6831
6832 -- Secondary dispatch table referencing predefined primitives
6833
6834 Iface_DT_Ptr :=
6835 Make_Defining_Identifier (Loc,
6836 Chars => New_External_Name (Typ_Name, 'Z'));
6837 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6838 Set_Ekind (Iface_DT_Ptr, E_Constant);
6839 Set_Is_Tag (Iface_DT_Ptr);
6840 Set_Is_Statically_Allocated (Iface_DT_Ptr,
6841 Is_Library_Level_Tagged_Type (Typ));
6842 Set_Is_True_Constant (Iface_DT_Ptr);
6843 Set_Related_Type
6844 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6845 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6846
6847 Next_Elmt (AI_Tag_Comp);
6848 end loop;
6849 end if;
6850 end if;
6851
6852 -- 3) At the end of Access_Disp_Table, if the type has user-defined
6853 -- primitives, we add the entity of an access type declaration that
6854 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
6855 -- through the primary dispatch table.
6856
6857 if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
6858 Analyze_List (Result);
6859
6860 -- Generate:
6861 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
6862 -- type Typ_DT_Acc is access Typ_DT;
6863
6864 else
6865 declare
6866 Name_DT_Prims : constant Name_Id :=
6867 New_External_Name (Tname, 'G');
6868 Name_DT_Prims_Acc : constant Name_Id :=
6869 New_External_Name (Tname, 'H');
6870 DT_Prims : constant Entity_Id :=
6871 Make_Defining_Identifier (Loc,
6872 Name_DT_Prims);
6873 DT_Prims_Acc : constant Entity_Id :=
6874 Make_Defining_Identifier (Loc,
6875 Name_DT_Prims_Acc);
6876 begin
6877 Append_To (Result,
6878 Make_Full_Type_Declaration (Loc,
6879 Defining_Identifier => DT_Prims,
6880 Type_Definition =>
6881 Make_Constrained_Array_Definition (Loc,
6882 Discrete_Subtype_Definitions => New_List (
6883 Make_Range (Loc,
6884 Low_Bound => Make_Integer_Literal (Loc, 1),
6885 High_Bound => Make_Integer_Literal (Loc,
6886 DT_Entry_Count
6887 (First_Tag_Component (Typ))))),
6888 Component_Definition =>
6889 Make_Component_Definition (Loc,
6890 Subtype_Indication =>
6891 New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc)))));
6892
6893 Append_To (Result,
6894 Make_Full_Type_Declaration (Loc,
6895 Defining_Identifier => DT_Prims_Acc,
6896 Type_Definition =>
6897 Make_Access_To_Object_Definition (Loc,
6898 Subtype_Indication =>
6899 New_Occurrence_Of (DT_Prims, Loc))));
6900
6901 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
6902
6903 -- Analyze the resulting list and suppress the generation of the
6904 -- Init_Proc associated with the above array declaration because
6905 -- this type is never used in object declarations. It is only used
6906 -- to simplify the expansion associated with dispatching calls.
6907
6908 Analyze_List (Result);
6909 Set_Suppress_Initialization (Base_Type (DT_Prims));
6910
6911 -- Disable backend optimizations based on assumptions about the
6912 -- aliasing status of objects designated by the access to the
6913 -- dispatch table. Required to handle dispatch tables imported
6914 -- from C++.
6915
6916 Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
6917
6918 -- Add the freezing nodes of these declarations; required to avoid
6919 -- generating these freezing nodes in wrong scopes (for example in
6920 -- the IC routine of a derivation of Typ).
6921
6922 -- What is an "IC routine"? Is "init_proc" meant here???
6923
6924 Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
6925 Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
6926
6927 -- Mark entity of dispatch table. Required by the back end to
6928 -- handle them properly.
6929
6930 Set_Is_Dispatch_Table_Entity (DT_Prims);
6931 end;
6932 end if;
6933
6934 -- Mark entities of dispatch table. Required by the back end to handle
6935 -- them properly.
6936
6937 if Present (DT) then
6938 Set_Is_Dispatch_Table_Entity (DT);
6939 Set_Is_Dispatch_Table_Entity (Etype (DT));
6940 end if;
6941
6942 if Present (Iface_DT) then
6943 Set_Is_Dispatch_Table_Entity (Iface_DT);
6944 Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
6945 end if;
6946
6947 if Is_CPP_Class (Root_Type (Typ)) then
6948 Set_Ekind (DT_Ptr, E_Variable);
6949 else
6950 Set_Ekind (DT_Ptr, E_Constant);
6951 end if;
6952
6953 Set_Is_Tag (DT_Ptr);
6954 Set_Related_Type (DT_Ptr, Typ);
6955
6956 return Result;
6957 end Make_Tags;
6958
6959 ---------------
6960 -- New_Value --
6961 ---------------
6962
6963 function New_Value (From : Node_Id) return Node_Id is
6964 Res : constant Node_Id := Duplicate_Subexpr (From);
6965 begin
6966 if Is_Access_Type (Etype (From)) then
6967 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
6968 else
6969 return Res;
6970 end if;
6971 end New_Value;
6972
6973 -----------------------------------
6974 -- Original_View_In_Visible_Part --
6975 -----------------------------------
6976
6977 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
6978 Scop : constant Entity_Id := Scope (Typ);
6979
6980 begin
6981 -- The scope must be a package
6982
6983 if not Is_Package_Or_Generic_Package (Scop) then
6984 return False;
6985 end if;
6986
6987 -- A type with a private declaration has a private view declared in
6988 -- the visible part.
6989
6990 if Has_Private_Declaration (Typ) then
6991 return True;
6992 end if;
6993
6994 return List_Containing (Parent (Typ)) =
6995 Visible_Declarations (Package_Specification (Scop));
6996 end Original_View_In_Visible_Part;
6997
6998 ------------------
6999 -- Prim_Op_Kind --
7000 ------------------
7001
7002 function Prim_Op_Kind
7003 (Prim : Entity_Id;
7004 Typ : Entity_Id) return Node_Id
7005 is
7006 Full_Typ : Entity_Id := Typ;
7007 Loc : constant Source_Ptr := Sloc (Prim);
7008 Prim_Op : Entity_Id;
7009
7010 begin
7011 -- Retrieve the original primitive operation
7012
7013 Prim_Op := Ultimate_Alias (Prim);
7014
7015 if Ekind (Typ) = E_Record_Type
7016 and then Present (Corresponding_Concurrent_Type (Typ))
7017 then
7018 Full_Typ := Corresponding_Concurrent_Type (Typ);
7019 end if;
7020
7021 -- When a private tagged type is completed by a concurrent type,
7022 -- retrieve the full view.
7023
7024 if Is_Private_Type (Full_Typ) then
7025 Full_Typ := Full_View (Full_Typ);
7026 end if;
7027
7028 if Ekind (Prim_Op) = E_Function then
7029
7030 -- Protected function
7031
7032 if Ekind (Full_Typ) = E_Protected_Type then
7033 return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc);
7034
7035 -- Task function
7036
7037 elsif Ekind (Full_Typ) = E_Task_Type then
7038 return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc);
7039
7040 -- Regular function
7041
7042 else
7043 return New_Occurrence_Of (RTE (RE_POK_Function), Loc);
7044 end if;
7045
7046 else
7047 pragma Assert (Ekind (Prim_Op) = E_Procedure);
7048
7049 if Ekind (Full_Typ) = E_Protected_Type then
7050
7051 -- Protected entry
7052
7053 if Is_Primitive_Wrapper (Prim_Op)
7054 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7055 then
7056 return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc);
7057
7058 -- Protected procedure
7059
7060 else
7061 return
7062 New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc);
7063 end if;
7064
7065 elsif Ekind (Full_Typ) = E_Task_Type then
7066
7067 -- Task entry
7068
7069 if Is_Primitive_Wrapper (Prim_Op)
7070 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7071 then
7072 return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc);
7073
7074 -- Task "procedure". These are the internally Expander-generated
7075 -- procedures (task body for instance).
7076
7077 else
7078 return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc);
7079 end if;
7080
7081 -- Regular procedure
7082
7083 else
7084 return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc);
7085 end if;
7086 end if;
7087 end Prim_Op_Kind;
7088
7089 ------------------------
7090 -- Register_Primitive --
7091 ------------------------
7092
7093 function Register_Primitive
7094 (Loc : Source_Ptr;
7095 Prim : Entity_Id) return List_Id
7096 is
7097 DT_Ptr : Entity_Id;
7098 Iface_Prim : Entity_Id;
7099 Iface_Typ : Entity_Id;
7100 Iface_DT_Ptr : Entity_Id;
7101 Iface_DT_Elmt : Elmt_Id;
7102 L : constant List_Id := New_List;
7103 Pos : Uint;
7104 Tag : Entity_Id;
7105 Tag_Typ : Entity_Id;
7106 Thunk_Id : Entity_Id;
7107 Thunk_Code : Node_Id;
7108
7109 begin
7110 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7111
7112 -- Do not register in the dispatch table eliminated primitives
7113
7114 if not RTE_Available (RE_Tag)
7115 or else Is_Eliminated (Ultimate_Alias (Prim))
7116 or else Generate_SCIL
7117 then
7118 return L;
7119 end if;
7120
7121 if not Present (Interface_Alias (Prim)) then
7122 Tag_Typ := Scope (DTC_Entity (Prim));
7123 Pos := DT_Position (Prim);
7124 Tag := First_Tag_Component (Tag_Typ);
7125
7126 if Is_Predefined_Dispatching_Operation (Prim)
7127 or else Is_Predefined_Dispatching_Alias (Prim)
7128 then
7129 DT_Ptr :=
7130 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7131
7132 Append_To (L,
7133 Build_Set_Predefined_Prim_Op_Address (Loc,
7134 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7135 Position => Pos,
7136 Address_Node =>
7137 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7138 Make_Attribute_Reference (Loc,
7139 Prefix => New_Occurrence_Of (Prim, Loc),
7140 Attribute_Name => Name_Unrestricted_Access))));
7141
7142 -- Register copy of the pointer to the 'size primitive in the TSD
7143
7144 if Chars (Prim) = Name_uSize
7145 and then RTE_Record_Component_Available (RE_Size_Func)
7146 then
7147 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7148 Append_To (L,
7149 Build_Set_Size_Function (Loc,
7150 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7151 Size_Func => Prim));
7152 end if;
7153
7154 else
7155 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7156
7157 -- Skip registration of primitives located in the C++ part of the
7158 -- dispatch table. Their slot is set by the IC routine.
7159
7160 if not Is_CPP_Class (Root_Type (Tag_Typ))
7161 or else Pos > CPP_Num_Prims (Tag_Typ)
7162 then
7163 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7164 Append_To (L,
7165 Build_Set_Prim_Op_Address (Loc,
7166 Typ => Tag_Typ,
7167 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7168 Position => Pos,
7169 Address_Node =>
7170 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7171 Make_Attribute_Reference (Loc,
7172 Prefix => New_Occurrence_Of (Prim, Loc),
7173 Attribute_Name => Name_Unrestricted_Access))));
7174 end if;
7175 end if;
7176
7177 -- Ada 2005 (AI-251): Primitive associated with an interface type
7178
7179 -- Generate the code of the thunk only if the interface type is not an
7180 -- immediate ancestor of Typ; otherwise the dispatch table associated
7181 -- with the interface is the primary dispatch table and we have nothing
7182 -- else to do here.
7183
7184 else
7185 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
7186 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7187
7188 pragma Assert (Is_Interface (Iface_Typ));
7189
7190 -- No action needed for interfaces that are ancestors of Typ because
7191 -- their primitives are located in the primary dispatch table.
7192
7193 if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7194 return L;
7195
7196 -- No action needed for primitives located in the C++ part of the
7197 -- dispatch table. Their slot is set by the IC routine.
7198
7199 elsif Is_CPP_Class (Root_Type (Tag_Typ))
7200 and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7201 and then not Is_Predefined_Dispatching_Operation (Prim)
7202 and then not Is_Predefined_Dispatching_Alias (Prim)
7203 then
7204 return L;
7205 end if;
7206
7207 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7208
7209 if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7210 and then Present (Thunk_Code)
7211 then
7212 -- Generate the code necessary to fill the appropriate entry of
7213 -- the secondary dispatch table of Prim's controlling type with
7214 -- Thunk_Id's address.
7215
7216 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7217 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7218 pragma Assert (Has_Thunks (Iface_DT_Ptr));
7219
7220 Iface_Prim := Interface_Alias (Prim);
7221 Pos := DT_Position (Iface_Prim);
7222 Tag := First_Tag_Component (Iface_Typ);
7223
7224 Prepend_To (L, Thunk_Code);
7225
7226 if Is_Predefined_Dispatching_Operation (Prim)
7227 or else Is_Predefined_Dispatching_Alias (Prim)
7228 then
7229 Append_To (L,
7230 Build_Set_Predefined_Prim_Op_Address (Loc,
7231 Tag_Node =>
7232 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7233 Position => Pos,
7234 Address_Node =>
7235 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7236 Make_Attribute_Reference (Loc,
7237 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7238 Attribute_Name => Name_Unrestricted_Access))));
7239
7240 Next_Elmt (Iface_DT_Elmt);
7241 Next_Elmt (Iface_DT_Elmt);
7242 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7243 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7244
7245 Append_To (L,
7246 Build_Set_Predefined_Prim_Op_Address (Loc,
7247 Tag_Node =>
7248 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7249 Position => Pos,
7250 Address_Node =>
7251 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7252 Make_Attribute_Reference (Loc,
7253 Prefix =>
7254 New_Occurrence_Of (Alias (Prim), Loc),
7255 Attribute_Name => Name_Unrestricted_Access))));
7256
7257 else
7258 pragma Assert (Pos /= Uint_0
7259 and then Pos <= DT_Entry_Count (Tag));
7260
7261 Append_To (L,
7262 Build_Set_Prim_Op_Address (Loc,
7263 Typ => Iface_Typ,
7264 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7265 Position => Pos,
7266 Address_Node =>
7267 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7268 Make_Attribute_Reference (Loc,
7269 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7270 Attribute_Name => Name_Unrestricted_Access))));
7271
7272 Next_Elmt (Iface_DT_Elmt);
7273 Next_Elmt (Iface_DT_Elmt);
7274 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7275 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7276
7277 Append_To (L,
7278 Build_Set_Prim_Op_Address (Loc,
7279 Typ => Iface_Typ,
7280 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7281 Position => Pos,
7282 Address_Node =>
7283 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7284 Make_Attribute_Reference (Loc,
7285 Prefix =>
7286 New_Occurrence_Of (Alias (Prim), Loc),
7287 Attribute_Name => Name_Unrestricted_Access))));
7288
7289 end if;
7290 end if;
7291 end if;
7292
7293 return L;
7294 end Register_Primitive;
7295
7296 -------------------------
7297 -- Set_All_DT_Position --
7298 -------------------------
7299
7300 procedure Set_All_DT_Position (Typ : Entity_Id) is
7301
7302 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7303 -- Returns True if Prim is located in the dispatch table of
7304 -- predefined primitives
7305
7306 procedure Validate_Position (Prim : Entity_Id);
7307 -- Check that position assigned to Prim is completely safe (it has not
7308 -- been assigned to a previously defined primitive operation of Typ).
7309
7310 ------------------------
7311 -- In_Predef_Prims_DT --
7312 ------------------------
7313
7314 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7315 E : Entity_Id;
7316
7317 begin
7318 -- Predefined primitives
7319
7320 if Is_Predefined_Dispatching_Operation (Prim) then
7321 return True;
7322
7323 -- Renamings of predefined primitives
7324
7325 elsif Present (Alias (Prim))
7326 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7327 then
7328 if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7329 return True;
7330
7331 -- User-defined renamings of predefined equality have their own
7332 -- slot in the primary dispatch table
7333
7334 else
7335 E := Prim;
7336 while Present (Alias (E)) loop
7337 if Comes_From_Source (E) then
7338 return False;
7339 end if;
7340
7341 E := Alias (E);
7342 end loop;
7343
7344 return not Comes_From_Source (E);
7345 end if;
7346
7347 -- User-defined primitives
7348
7349 else
7350 return False;
7351 end if;
7352 end In_Predef_Prims_DT;
7353
7354 -----------------------
7355 -- Validate_Position --
7356 -----------------------
7357
7358 procedure Validate_Position (Prim : Entity_Id) is
7359 Op_Elmt : Elmt_Id;
7360 Op : Entity_Id;
7361
7362 begin
7363 -- Aliased primitives are safe
7364
7365 if Present (Alias (Prim)) then
7366 return;
7367 end if;
7368
7369 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7370 while Present (Op_Elmt) loop
7371 Op := Node (Op_Elmt);
7372
7373 -- No need to check against itself
7374
7375 if Op = Prim then
7376 null;
7377
7378 -- Primitive operations covering abstract interfaces are
7379 -- allocated later
7380
7381 elsif Present (Interface_Alias (Op)) then
7382 null;
7383
7384 -- Predefined dispatching operations are completely safe. They
7385 -- are allocated at fixed positions in a separate table.
7386
7387 elsif Is_Predefined_Dispatching_Operation (Op)
7388 or else Is_Predefined_Dispatching_Alias (Op)
7389 then
7390 null;
7391
7392 -- Aliased subprograms are safe
7393
7394 elsif Present (Alias (Op)) then
7395 null;
7396
7397 elsif DT_Position (Op) = DT_Position (Prim)
7398 and then not Is_Predefined_Dispatching_Operation (Op)
7399 and then not Is_Predefined_Dispatching_Operation (Prim)
7400 and then not Is_Predefined_Dispatching_Alias (Op)
7401 and then not Is_Predefined_Dispatching_Alias (Prim)
7402 then
7403 -- Handle aliased subprograms
7404
7405 declare
7406 Op_1 : Entity_Id;
7407 Op_2 : Entity_Id;
7408
7409 begin
7410 Op_1 := Op;
7411 loop
7412 if Present (Overridden_Operation (Op_1)) then
7413 Op_1 := Overridden_Operation (Op_1);
7414 elsif Present (Alias (Op_1)) then
7415 Op_1 := Alias (Op_1);
7416 else
7417 exit;
7418 end if;
7419 end loop;
7420
7421 Op_2 := Prim;
7422 loop
7423 if Present (Overridden_Operation (Op_2)) then
7424 Op_2 := Overridden_Operation (Op_2);
7425 elsif Present (Alias (Op_2)) then
7426 Op_2 := Alias (Op_2);
7427 else
7428 exit;
7429 end if;
7430 end loop;
7431
7432 if Op_1 /= Op_2 then
7433 raise Program_Error;
7434 end if;
7435 end;
7436 end if;
7437
7438 Next_Elmt (Op_Elmt);
7439 end loop;
7440 end Validate_Position;
7441
7442 -- Local variables
7443
7444 Parent_Typ : constant Entity_Id := Etype (Typ);
7445 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7446 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
7447
7448 Adjusted : Boolean := False;
7449 Finalized : Boolean := False;
7450
7451 Count_Prim : Nat;
7452 DT_Length : Nat;
7453 Nb_Prim : Nat;
7454 Prim : Entity_Id;
7455 Prim_Elmt : Elmt_Id;
7456
7457 -- Start of processing for Set_All_DT_Position
7458
7459 begin
7460 pragma Assert (Present (First_Tag_Component (Typ)));
7461
7462 -- Set the DT_Position for each primitive operation. Perform some sanity
7463 -- checks to avoid building inconsistent dispatch tables.
7464
7465 -- First stage: Set DTC entity of all the primitive operations. This is
7466 -- required to properly read the DT_Position attribute in latter stages.
7467
7468 Prim_Elmt := First_Prim;
7469 Count_Prim := 0;
7470 while Present (Prim_Elmt) loop
7471 Prim := Node (Prim_Elmt);
7472
7473 -- Predefined primitives have a separate dispatch table
7474
7475 if not In_Predef_Prims_DT (Prim) then
7476 Count_Prim := Count_Prim + 1;
7477 end if;
7478
7479 Set_DTC_Entity_Value (Typ, Prim);
7480
7481 -- Clear any previous value of the DT_Position attribute. In this
7482 -- way we ensure that the final position of all the primitives is
7483 -- established by the following stages of this algorithm.
7484
7485 Set_DT_Position_Value (Prim, No_Uint);
7486
7487 Next_Elmt (Prim_Elmt);
7488 end loop;
7489
7490 declare
7491 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7492 (others => False);
7493
7494 E : Entity_Id;
7495
7496 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7497 -- Called if Typ is declared in a nested package or a public child
7498 -- package to handle inherited primitives that were inherited by Typ
7499 -- in the visible part, but whose declaration was deferred because
7500 -- the parent operation was private and not visible at that point.
7501
7502 procedure Set_Fixed_Prim (Pos : Nat);
7503 -- Sets to true an element of the Fixed_Prim table to indicate
7504 -- that this entry of the dispatch table of Typ is occupied.
7505
7506 ------------------------------------------
7507 -- Handle_Inherited_Private_Subprograms --
7508 ------------------------------------------
7509
7510 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7511 Op_List : Elist_Id;
7512 Op_Elmt : Elmt_Id;
7513 Op_Elmt_2 : Elmt_Id;
7514 Prim_Op : Entity_Id;
7515 Parent_Subp : Entity_Id;
7516
7517 begin
7518 Op_List := Primitive_Operations (Typ);
7519
7520 Op_Elmt := First_Elmt (Op_List);
7521 while Present (Op_Elmt) loop
7522 Prim_Op := Node (Op_Elmt);
7523
7524 -- Search primitives that are implicit operations with an
7525 -- internal name whose parent operation has a normal name.
7526
7527 if Present (Alias (Prim_Op))
7528 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
7529 and then not Comes_From_Source (Prim_Op)
7530 and then Is_Internal_Name (Chars (Prim_Op))
7531 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
7532 then
7533 Parent_Subp := Alias (Prim_Op);
7534
7535 -- Check if the type has an explicit overriding for this
7536 -- primitive.
7537
7538 Op_Elmt_2 := Next_Elmt (Op_Elmt);
7539 while Present (Op_Elmt_2) loop
7540 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
7541 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
7542 then
7543 Set_DT_Position_Value (Prim_Op,
7544 DT_Position (Parent_Subp));
7545 Set_DT_Position_Value (Node (Op_Elmt_2),
7546 DT_Position (Parent_Subp));
7547 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
7548
7549 goto Next_Primitive;
7550 end if;
7551
7552 Next_Elmt (Op_Elmt_2);
7553 end loop;
7554 end if;
7555
7556 <<Next_Primitive>>
7557 Next_Elmt (Op_Elmt);
7558 end loop;
7559 end Handle_Inherited_Private_Subprograms;
7560
7561 --------------------
7562 -- Set_Fixed_Prim --
7563 --------------------
7564
7565 procedure Set_Fixed_Prim (Pos : Nat) is
7566 begin
7567 pragma Assert (Pos <= Count_Prim);
7568 Fixed_Prim (Pos) := True;
7569 exception
7570 when Constraint_Error =>
7571 raise Program_Error;
7572 end Set_Fixed_Prim;
7573
7574 begin
7575 -- In case of nested packages and public child package it may be
7576 -- necessary a special management on inherited subprograms so that
7577 -- the dispatch table is properly filled.
7578
7579 if Ekind (Scope (Scope (Typ))) = E_Package
7580 and then Scope (Scope (Typ)) /= Standard_Standard
7581 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
7582 or else
7583 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
7584 and then Is_Generic_Type (Typ)))
7585 and then In_Open_Scopes (Scope (Etype (Typ)))
7586 and then Is_Base_Type (Typ)
7587 then
7588 Handle_Inherited_Private_Subprograms (Typ);
7589 end if;
7590
7591 -- Second stage: Register fixed entries
7592
7593 Nb_Prim := 0;
7594 Prim_Elmt := First_Prim;
7595 while Present (Prim_Elmt) loop
7596 Prim := Node (Prim_Elmt);
7597
7598 -- Predefined primitives have a separate table and all its
7599 -- entries are at predefined fixed positions.
7600
7601 if In_Predef_Prims_DT (Prim) then
7602 if Is_Predefined_Dispatching_Operation (Prim) then
7603 Set_DT_Position_Value (Prim,
7604 Default_Prim_Op_Position (Prim));
7605
7606 else pragma Assert (Present (Alias (Prim)));
7607 Set_DT_Position_Value (Prim,
7608 Default_Prim_Op_Position (Ultimate_Alias (Prim)));
7609 end if;
7610
7611 -- Overriding primitives of ancestor abstract interfaces
7612
7613 elsif Present (Interface_Alias (Prim))
7614 and then Is_Ancestor
7615 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7616 Use_Full_View => True)
7617 then
7618 pragma Assert (DT_Position (Prim) = No_Uint
7619 and then Present (DTC_Entity (Interface_Alias (Prim))));
7620
7621 E := Interface_Alias (Prim);
7622 Set_DT_Position_Value (Prim, DT_Position (E));
7623
7624 pragma Assert
7625 (DT_Position (Alias (Prim)) = No_Uint
7626 or else DT_Position (Alias (Prim)) = DT_Position (E));
7627 Set_DT_Position_Value (Alias (Prim), DT_Position (E));
7628 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
7629
7630 -- Overriding primitives must use the same entry as the
7631 -- overridden primitive.
7632
7633 elsif not Present (Interface_Alias (Prim))
7634 and then Present (Alias (Prim))
7635 and then Chars (Prim) = Chars (Alias (Prim))
7636 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
7637 and then Is_Ancestor
7638 (Find_Dispatching_Type (Alias (Prim)), Typ,
7639 Use_Full_View => True)
7640 and then Present (DTC_Entity (Alias (Prim)))
7641 then
7642 E := Alias (Prim);
7643 Set_DT_Position_Value (Prim, DT_Position (E));
7644
7645 if not Is_Predefined_Dispatching_Alias (E) then
7646 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
7647 end if;
7648 end if;
7649
7650 Next_Elmt (Prim_Elmt);
7651 end loop;
7652
7653 -- Third stage: Fix the position of all the new primitives. Entries
7654 -- associated with primitives covering interfaces are handled in a
7655 -- latter round.
7656
7657 Prim_Elmt := First_Prim;
7658 while Present (Prim_Elmt) loop
7659 Prim := Node (Prim_Elmt);
7660
7661 -- Skip primitives previously set entries
7662
7663 if DT_Position (Prim) /= No_Uint then
7664 null;
7665
7666 -- Primitives covering interface primitives are handled later
7667
7668 elsif Present (Interface_Alias (Prim)) then
7669 null;
7670
7671 else
7672 -- Take the next available position in the DT
7673
7674 loop
7675 Nb_Prim := Nb_Prim + 1;
7676 pragma Assert (Nb_Prim <= Count_Prim);
7677 exit when not Fixed_Prim (Nb_Prim);
7678 end loop;
7679
7680 Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
7681 Set_Fixed_Prim (Nb_Prim);
7682 end if;
7683
7684 Next_Elmt (Prim_Elmt);
7685 end loop;
7686 end;
7687
7688 -- Fourth stage: Complete the decoration of primitives covering
7689 -- interfaces (that is, propagate the DT_Position attribute from
7690 -- the aliased primitive)
7691
7692 Prim_Elmt := First_Prim;
7693 while Present (Prim_Elmt) loop
7694 Prim := Node (Prim_Elmt);
7695
7696 if DT_Position (Prim) = No_Uint
7697 and then Present (Interface_Alias (Prim))
7698 then
7699 pragma Assert (Present (Alias (Prim))
7700 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
7701
7702 -- Check if this entry will be placed in the primary DT
7703
7704 if Is_Ancestor
7705 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7706 Use_Full_View => True)
7707 then
7708 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
7709 Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
7710
7711 -- Otherwise it will be placed in the secondary DT
7712
7713 else
7714 pragma Assert
7715 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
7716 Set_DT_Position_Value (Prim,
7717 DT_Position (Interface_Alias (Prim)));
7718 end if;
7719 end if;
7720
7721 Next_Elmt (Prim_Elmt);
7722 end loop;
7723
7724 -- Generate listing showing the contents of the dispatch tables. This
7725 -- action is done before some further static checks because in case of
7726 -- critical errors caused by a wrong dispatch table we need to see the
7727 -- contents of such table.
7728
7729 if Debug_Flag_ZZ then
7730 Write_DT (Typ);
7731 end if;
7732
7733 -- Final stage: Ensure that the table is correct plus some further
7734 -- verifications concerning the primitives.
7735
7736 Prim_Elmt := First_Prim;
7737 DT_Length := 0;
7738 while Present (Prim_Elmt) loop
7739 Prim := Node (Prim_Elmt);
7740
7741 -- At this point all the primitives MUST have a position in the
7742 -- dispatch table.
7743
7744 if DT_Position (Prim) = No_Uint then
7745 raise Program_Error;
7746 end if;
7747
7748 -- Calculate real size of the dispatch table
7749
7750 if not In_Predef_Prims_DT (Prim)
7751 and then UI_To_Int (DT_Position (Prim)) > DT_Length
7752 then
7753 DT_Length := UI_To_Int (DT_Position (Prim));
7754 end if;
7755
7756 -- Ensure that the assigned position to non-predefined dispatching
7757 -- operations in the dispatch table is correct.
7758
7759 if not Is_Predefined_Dispatching_Operation (Prim)
7760 and then not Is_Predefined_Dispatching_Alias (Prim)
7761 then
7762 Validate_Position (Prim);
7763 end if;
7764
7765 if Chars (Prim) = Name_Finalize then
7766 Finalized := True;
7767 end if;
7768
7769 if Chars (Prim) = Name_Adjust then
7770 Adjusted := True;
7771 end if;
7772
7773 -- An abstract operation cannot be declared in the private part for a
7774 -- visible abstract type, because it can't be overridden outside this
7775 -- package hierarchy. For explicit declarations this is checked at
7776 -- the point of declaration, but for inherited operations it must be
7777 -- done when building the dispatch table.
7778
7779 -- Ada 2005 (AI-251): Primitives associated with interfaces are
7780 -- excluded from this check because interfaces must be visible in
7781 -- the public and private part (RM 7.3 (7.3/2))
7782
7783 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
7784 -- legacy Ada code.
7785
7786 if not Relaxed_RM_Semantics
7787 and then Is_Abstract_Type (Typ)
7788 and then Is_Abstract_Subprogram (Prim)
7789 and then Present (Alias (Prim))
7790 and then not Is_Interface
7791 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
7792 and then not Present (Interface_Alias (Prim))
7793 and then Is_Derived_Type (Typ)
7794 and then In_Private_Part (Current_Scope)
7795 and then
7796 List_Containing (Parent (Prim)) =
7797 Private_Declarations (Package_Specification (Current_Scope))
7798 and then Original_View_In_Visible_Part (Typ)
7799 then
7800 -- We exclude Input and Output stream operations because
7801 -- Limited_Controlled inherits useless Input and Output stream
7802 -- operations from Root_Controlled, which can never be overridden.
7803
7804 if not Is_TSS (Prim, TSS_Stream_Input)
7805 and then
7806 not Is_TSS (Prim, TSS_Stream_Output)
7807 then
7808 Error_Msg_NE
7809 ("abstract inherited private operation&" &
7810 " must be overridden (RM 3.9.3(10))",
7811 Parent (Typ), Prim);
7812 end if;
7813 end if;
7814
7815 Next_Elmt (Prim_Elmt);
7816 end loop;
7817
7818 -- Additional check
7819
7820 if Is_Controlled (Typ) then
7821 if not Finalized then
7822 Error_Msg_N
7823 ("controlled type has no explicit Finalize method??", Typ);
7824
7825 elsif not Adjusted then
7826 Error_Msg_N
7827 ("controlled type has no explicit Adjust method??", Typ);
7828 end if;
7829 end if;
7830
7831 -- Set the final size of the Dispatch Table
7832
7833 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
7834
7835 -- The derived type must have at least as many components as its parent
7836 -- (for root types Etype points to itself and the test cannot fail).
7837
7838 if DT_Entry_Count (The_Tag) <
7839 DT_Entry_Count (First_Tag_Component (Parent_Typ))
7840 then
7841 raise Program_Error;
7842 end if;
7843 end Set_All_DT_Position;
7844
7845 --------------------------
7846 -- Set_CPP_Constructors --
7847 --------------------------
7848
7849 procedure Set_CPP_Constructors (Typ : Entity_Id) is
7850
7851 function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
7852 -- Duplicate the parameters profile of the imported C++ constructor
7853 -- adding an access to the object as an additional parameter.
7854
7855 ----------------------------
7856 -- Gen_Parameters_Profile --
7857 ----------------------------
7858
7859 function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
7860 Loc : constant Source_Ptr := Sloc (E);
7861 Parms : List_Id;
7862 P : Node_Id;
7863
7864 begin
7865 Parms :=
7866 New_List (
7867 Make_Parameter_Specification (Loc,
7868 Defining_Identifier =>
7869 Make_Defining_Identifier (Loc, Name_uInit),
7870 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
7871
7872 if Present (Parameter_Specifications (Parent (E))) then
7873 P := First (Parameter_Specifications (Parent (E)));
7874 while Present (P) loop
7875 Append_To (Parms,
7876 Make_Parameter_Specification (Loc,
7877 Defining_Identifier =>
7878 Make_Defining_Identifier (Loc,
7879 Chars => Chars (Defining_Identifier (P))),
7880 Parameter_Type => New_Copy_Tree (Parameter_Type (P)),
7881 Expression => New_Copy_Tree (Expression (P))));
7882 Next (P);
7883 end loop;
7884 end if;
7885
7886 return Parms;
7887 end Gen_Parameters_Profile;
7888
7889 -- Local variables
7890
7891 Loc : Source_Ptr;
7892 E : Entity_Id;
7893 Found : Boolean := False;
7894 IP : Entity_Id;
7895 IP_Body : Node_Id;
7896 P : Node_Id;
7897 Parms : List_Id;
7898
7899 Covers_Default_Constructor : Entity_Id := Empty;
7900
7901 -- Start of processing for Set_CPP_Constructor
7902
7903 begin
7904 pragma Assert (Is_CPP_Class (Typ));
7905
7906 -- Look for the constructor entities
7907
7908 E := Next_Entity (Typ);
7909 while Present (E) loop
7910 if Ekind (E) = E_Function
7911 and then Is_Constructor (E)
7912 then
7913 Found := True;
7914 Loc := Sloc (E);
7915 Parms := Gen_Parameters_Profile (E);
7916 IP :=
7917 Make_Defining_Identifier (Loc,
7918 Chars => Make_Init_Proc_Name (Typ));
7919
7920 -- Case 1: Constructor of untagged type
7921
7922 -- If the C++ class has no virtual methods then the matching Ada
7923 -- type is an untagged record type. In such case there is no need
7924 -- to generate a wrapper of the C++ constructor because the _tag
7925 -- component is not available.
7926
7927 if not Is_Tagged_Type (Typ) then
7928 Discard_Node
7929 (Make_Subprogram_Declaration (Loc,
7930 Specification =>
7931 Make_Procedure_Specification (Loc,
7932 Defining_Unit_Name => IP,
7933 Parameter_Specifications => Parms)));
7934
7935 Set_Init_Proc (Typ, IP);
7936 Set_Is_Imported (IP);
7937 Set_Is_Constructor (IP);
7938 Set_Interface_Name (IP, Interface_Name (E));
7939 Set_Convention (IP, Convention_CPP);
7940 Set_Is_Public (IP);
7941 Set_Has_Completion (IP);
7942
7943 -- Case 2: Constructor of a tagged type
7944
7945 -- In this case we generate the IP as a wrapper of the the
7946 -- C++ constructor because IP must also save copy of the _tag
7947 -- generated in the C++ side. The copy of the _tag is used by
7948 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
7949
7950 -- Generate:
7951 -- procedure IP (_init : Typ; ...) is
7952 -- procedure ConstructorP (_init : Typ; ...);
7953 -- pragma Import (ConstructorP);
7954 -- begin
7955 -- ConstructorP (_init, ...);
7956 -- if Typ._tag = null then
7957 -- Typ._tag := _init._tag;
7958 -- end if;
7959 -- end IP;
7960
7961 else
7962 declare
7963 Body_Stmts : constant List_Id := New_List;
7964 Constructor_Id : Entity_Id;
7965 Constructor_Decl_Node : Node_Id;
7966 Init_Tags_List : List_Id;
7967
7968 begin
7969 Constructor_Id := Make_Temporary (Loc, 'P');
7970
7971 Constructor_Decl_Node :=
7972 Make_Subprogram_Declaration (Loc,
7973 Make_Procedure_Specification (Loc,
7974 Defining_Unit_Name => Constructor_Id,
7975 Parameter_Specifications => Parms));
7976
7977 Set_Is_Imported (Constructor_Id);
7978 Set_Is_Constructor (Constructor_Id);
7979 Set_Interface_Name (Constructor_Id, Interface_Name (E));
7980 Set_Convention (Constructor_Id, Convention_CPP);
7981 Set_Is_Public (Constructor_Id);
7982 Set_Has_Completion (Constructor_Id);
7983
7984 -- Build the init procedure as a wrapper of this constructor
7985
7986 Parms := Gen_Parameters_Profile (E);
7987
7988 -- Invoke the C++ constructor
7989
7990 declare
7991 Actuals : constant List_Id := New_List;
7992
7993 begin
7994 P := First (Parms);
7995 while Present (P) loop
7996 Append_To (Actuals,
7997 New_Occurrence_Of (Defining_Identifier (P), Loc));
7998 Next (P);
7999 end loop;
8000
8001 Append_To (Body_Stmts,
8002 Make_Procedure_Call_Statement (Loc,
8003 Name => New_Occurrence_Of (Constructor_Id, Loc),
8004 Parameter_Associations => Actuals));
8005 end;
8006
8007 -- Initialize copies of C++ primary and secondary tags
8008
8009 Init_Tags_List := New_List;
8010
8011 declare
8012 Tag_Elmt : Elmt_Id;
8013 Tag_Comp : Node_Id;
8014
8015 begin
8016 Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8017 Tag_Comp := First_Tag_Component (Typ);
8018
8019 while Present (Tag_Elmt)
8020 and then Is_Tag (Node (Tag_Elmt))
8021 loop
8022 -- Skip the following assertion with primary tags
8023 -- because Related_Type is not set on primary tag
8024 -- components
8025
8026 pragma Assert
8027 (Tag_Comp = First_Tag_Component (Typ)
8028 or else Related_Type (Node (Tag_Elmt))
8029 = Related_Type (Tag_Comp));
8030
8031 Append_To (Init_Tags_List,
8032 Make_Assignment_Statement (Loc,
8033 Name =>
8034 New_Occurrence_Of (Node (Tag_Elmt), Loc),
8035 Expression =>
8036 Make_Selected_Component (Loc,
8037 Prefix =>
8038 Make_Identifier (Loc, Name_uInit),
8039 Selector_Name =>
8040 New_Occurrence_Of (Tag_Comp, Loc))));
8041
8042 Tag_Comp := Next_Tag_Component (Tag_Comp);
8043 Next_Elmt (Tag_Elmt);
8044 end loop;
8045 end;
8046
8047 Append_To (Body_Stmts,
8048 Make_If_Statement (Loc,
8049 Condition =>
8050 Make_Op_Eq (Loc,
8051 Left_Opnd =>
8052 New_Occurrence_Of
8053 (Node (First_Elmt (Access_Disp_Table (Typ))),
8054 Loc),
8055 Right_Opnd =>
8056 Unchecked_Convert_To (RTE (RE_Tag),
8057 New_Occurrence_Of (RTE (RE_Null_Address), Loc))),
8058 Then_Statements => Init_Tags_List));
8059
8060 IP_Body :=
8061 Make_Subprogram_Body (Loc,
8062 Specification =>
8063 Make_Procedure_Specification (Loc,
8064 Defining_Unit_Name => IP,
8065 Parameter_Specifications => Parms),
8066 Declarations => New_List (Constructor_Decl_Node),
8067 Handled_Statement_Sequence =>
8068 Make_Handled_Sequence_Of_Statements (Loc,
8069 Statements => Body_Stmts,
8070 Exception_Handlers => No_List));
8071
8072 Discard_Node (IP_Body);
8073 Set_Init_Proc (Typ, IP);
8074 end;
8075 end if;
8076
8077 -- If this constructor has parameters and all its parameters have
8078 -- defaults then it covers the default constructor. The semantic
8079 -- analyzer ensures that only one constructor with defaults covers
8080 -- the default constructor.
8081
8082 if Present (Parameter_Specifications (Parent (E)))
8083 and then Needs_No_Actuals (E)
8084 then
8085 Covers_Default_Constructor := IP;
8086 end if;
8087 end if;
8088
8089 Next_Entity (E);
8090 end loop;
8091
8092 -- If there are no constructors, mark the type as abstract since we
8093 -- won't be able to declare objects of that type.
8094
8095 if not Found then
8096 Set_Is_Abstract_Type (Typ);
8097 end if;
8098
8099 -- Handle constructor that has all its parameters with defaults and
8100 -- hence it covers the default constructor. We generate a wrapper IP
8101 -- which calls the covering constructor.
8102
8103 if Present (Covers_Default_Constructor) then
8104 declare
8105 Body_Stmts : List_Id;
8106
8107 begin
8108 Loc := Sloc (Covers_Default_Constructor);
8109
8110 Body_Stmts := New_List (
8111 Make_Procedure_Call_Statement (Loc,
8112 Name =>
8113 New_Occurrence_Of (Covers_Default_Constructor, Loc),
8114 Parameter_Associations => New_List (
8115 Make_Identifier (Loc, Name_uInit))));
8116
8117 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8118
8119 IP_Body :=
8120 Make_Subprogram_Body (Loc,
8121 Specification =>
8122 Make_Procedure_Specification (Loc,
8123 Defining_Unit_Name => IP,
8124 Parameter_Specifications => New_List (
8125 Make_Parameter_Specification (Loc,
8126 Defining_Identifier =>
8127 Make_Defining_Identifier (Loc, Name_uInit),
8128 Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
8129
8130 Declarations => No_List,
8131
8132 Handled_Statement_Sequence =>
8133 Make_Handled_Sequence_Of_Statements (Loc,
8134 Statements => Body_Stmts,
8135 Exception_Handlers => No_List));
8136
8137 Discard_Node (IP_Body);
8138 Set_Init_Proc (Typ, IP);
8139 end;
8140 end if;
8141
8142 -- If the CPP type has constructors then it must import also the default
8143 -- C++ constructor. It is required for default initialization of objects
8144 -- of the type. It is also required to elaborate objects of Ada types
8145 -- that are defined as derivations of this CPP type.
8146
8147 if Has_CPP_Constructors (Typ)
8148 and then No (Init_Proc (Typ))
8149 then
8150 Error_Msg_N ("??default constructor must be imported from C++", Typ);
8151 end if;
8152 end Set_CPP_Constructors;
8153
8154 ---------------------------
8155 -- Set_DT_Position_Value --
8156 ---------------------------
8157
8158 procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
8159 begin
8160 Set_DT_Position (Prim, Value);
8161
8162 -- Propagate the value to the wrapped subprogram (if one is present)
8163
8164 if Ekind_In (Prim, E_Function, E_Procedure)
8165 and then Is_Primitive_Wrapper (Prim)
8166 and then Present (Wrapped_Entity (Prim))
8167 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8168 then
8169 Set_DT_Position (Wrapped_Entity (Prim), Value);
8170 end if;
8171 end Set_DT_Position_Value;
8172
8173 --------------------------
8174 -- Set_DTC_Entity_Value --
8175 --------------------------
8176
8177 procedure Set_DTC_Entity_Value
8178 (Tagged_Type : Entity_Id;
8179 Prim : Entity_Id)
8180 is
8181 begin
8182 if Present (Interface_Alias (Prim))
8183 and then Is_Interface
8184 (Find_Dispatching_Type (Interface_Alias (Prim)))
8185 then
8186 Set_DTC_Entity (Prim,
8187 Find_Interface_Tag
8188 (T => Tagged_Type,
8189 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8190 else
8191 Set_DTC_Entity (Prim,
8192 First_Tag_Component (Tagged_Type));
8193 end if;
8194
8195 -- Propagate the value to the wrapped subprogram (if one is present)
8196
8197 if Ekind_In (Prim, E_Function, E_Procedure)
8198 and then Is_Primitive_Wrapper (Prim)
8199 and then Present (Wrapped_Entity (Prim))
8200 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8201 then
8202 Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
8203 end if;
8204 end Set_DTC_Entity_Value;
8205
8206 -----------------
8207 -- Tagged_Kind --
8208 -----------------
8209
8210 function Tagged_Kind (T : Entity_Id) return Node_Id is
8211 Conc_Typ : Entity_Id;
8212 Loc : constant Source_Ptr := Sloc (T);
8213
8214 begin
8215 pragma Assert
8216 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8217
8218 -- Abstract kinds
8219
8220 if Is_Abstract_Type (T) then
8221 if Is_Limited_Record (T) then
8222 return New_Occurrence_Of
8223 (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8224 else
8225 return New_Occurrence_Of
8226 (RTE (RE_TK_Abstract_Tagged), Loc);
8227 end if;
8228
8229 -- Concurrent kinds
8230
8231 elsif Is_Concurrent_Record_Type (T) then
8232 Conc_Typ := Corresponding_Concurrent_Type (T);
8233
8234 if Present (Full_View (Conc_Typ)) then
8235 Conc_Typ := Full_View (Conc_Typ);
8236 end if;
8237
8238 if Ekind (Conc_Typ) = E_Protected_Type then
8239 return New_Occurrence_Of (RTE (RE_TK_Protected), Loc);
8240 else
8241 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8242 return New_Occurrence_Of (RTE (RE_TK_Task), Loc);
8243 end if;
8244
8245 -- Regular tagged kinds
8246
8247 else
8248 if Is_Limited_Record (T) then
8249 return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc);
8250 else
8251 return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc);
8252 end if;
8253 end if;
8254 end Tagged_Kind;
8255
8256 --------------
8257 -- Write_DT --
8258 --------------
8259
8260 procedure Write_DT (Typ : Entity_Id) is
8261 Elmt : Elmt_Id;
8262 Prim : Node_Id;
8263
8264 begin
8265 -- Protect this procedure against wrong usage. Required because it will
8266 -- be used directly from GDB
8267
8268 if not (Typ <= Last_Node_Id)
8269 or else not Is_Tagged_Type (Typ)
8270 then
8271 Write_Str ("wrong usage: Write_DT must be used with tagged types");
8272 Write_Eol;
8273 return;
8274 end if;
8275
8276 Write_Int (Int (Typ));
8277 Write_Str (": ");
8278 Write_Name (Chars (Typ));
8279
8280 if Is_Interface (Typ) then
8281 Write_Str (" is interface");
8282 end if;
8283
8284 Write_Eol;
8285
8286 Elmt := First_Elmt (Primitive_Operations (Typ));
8287 while Present (Elmt) loop
8288 Prim := Node (Elmt);
8289 Write_Str (" - ");
8290
8291 -- Indicate if this primitive will be allocated in the primary
8292 -- dispatch table or in a secondary dispatch table associated
8293 -- with an abstract interface type
8294
8295 if Present (DTC_Entity (Prim)) then
8296 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8297 Write_Str ("[P] ");
8298 else
8299 Write_Str ("[s] ");
8300 end if;
8301 end if;
8302
8303 -- Output the node of this primitive operation and its name
8304
8305 Write_Int (Int (Prim));
8306 Write_Str (": ");
8307
8308 if Is_Predefined_Dispatching_Operation (Prim) then
8309 Write_Str ("(predefined) ");
8310 end if;
8311
8312 -- Prefix the name of the primitive with its corresponding tagged
8313 -- type to facilitate seeing inherited primitives.
8314
8315 if Present (Alias (Prim)) then
8316 Write_Name
8317 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8318 else
8319 Write_Name (Chars (Typ));
8320 end if;
8321
8322 Write_Str (".");
8323 Write_Name (Chars (Prim));
8324
8325 -- Indicate if this primitive has an aliased primitive
8326
8327 if Present (Alias (Prim)) then
8328 Write_Str (" (alias = ");
8329 Write_Int (Int (Alias (Prim)));
8330
8331 -- If the DTC_Entity attribute is already set we can also output
8332 -- the name of the interface covered by this primitive (if any).
8333
8334 if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8335 and then Present (DTC_Entity (Alias (Prim)))
8336 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8337 then
8338 Write_Str (" from interface ");
8339 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8340 end if;
8341
8342 if Present (Interface_Alias (Prim)) then
8343 Write_Str (", AI_Alias of ");
8344
8345 if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8346 Write_Str ("null primitive ");
8347 end if;
8348
8349 Write_Name
8350 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8351 Write_Char (':');
8352 Write_Int (Int (Interface_Alias (Prim)));
8353 end if;
8354
8355 Write_Str (")");
8356 end if;
8357
8358 -- Display the final position of this primitive in its associated
8359 -- (primary or secondary) dispatch table.
8360
8361 if Present (DTC_Entity (Prim))
8362 and then DT_Position (Prim) /= No_Uint
8363 then
8364 Write_Str (" at #");
8365 Write_Int (UI_To_Int (DT_Position (Prim)));
8366 end if;
8367
8368 if Is_Abstract_Subprogram (Prim) then
8369 Write_Str (" is abstract;");
8370
8371 -- Check if this is a null primitive
8372
8373 elsif Comes_From_Source (Prim)
8374 and then Ekind (Prim) = E_Procedure
8375 and then Null_Present (Parent (Prim))
8376 then
8377 Write_Str (" is null;");
8378 end if;
8379
8380 if Is_Eliminated (Ultimate_Alias (Prim)) then
8381 Write_Str (" (eliminated)");
8382 end if;
8383
8384 if Is_Imported (Prim)
8385 and then Convention (Prim) = Convention_CPP
8386 then
8387 Write_Str (" (C++)");
8388 end if;
8389
8390 Write_Eol;
8391
8392 Next_Elmt (Elmt);
8393 end loop;
8394 end Write_DT;
8395
8396 end Exp_Disp;