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